From 50cee5c0039c2641cf7d317929a597ea8b0e64c1 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Thu, 12 Jul 2012 13:39:10 +0000 Subject: [PATCH] psblas3: base/serial/impl/psb_c_base_mat_impl.F90 base/serial/impl/psb_d_base_mat_impl.F90 base/serial/impl/psb_s_base_mat_impl.F90 base/serial/impl/psb_z_base_mat_impl.F90 krylov/psb_cbicg.f90 krylov/psb_ccg.f90 krylov/psb_ccgs.f90 krylov/psb_ccgstab.f90 krylov/psb_ccgstabl.f90 krylov/psb_ckrylov.f90 krylov/psb_crgmres.f90 krylov/psb_dbicg.f90 krylov/psb_dcg.f90 krylov/psb_dcgs.f90 krylov/psb_dcgstab.f90 krylov/psb_dcgstabl.f90 krylov/psb_dkrylov.f90 krylov/psb_drgmres.f90 krylov/psb_sbicg.f90 krylov/psb_scg.f90 krylov/psb_scgs.f90 krylov/psb_scgstab.f90 krylov/psb_scgstabl.f90 krylov/psb_skrylov.f90 krylov/psb_srgmres.f90 krylov/psb_zbicg.f90 krylov/psb_zcg.f90 krylov/psb_zcgs.f90 krylov/psb_zcgstab.f90 krylov/psb_zcgstabl.f90 krylov/psb_zkrylov.f90 krylov/psb_zrgmres.f90 Added missing set_host() in vect_mv. Cleaned up the krylov methods. --- base/serial/impl/psb_c_base_mat_impl.F90 | 2 +- base/serial/impl/psb_d_base_mat_impl.F90 | 2 +- base/serial/impl/psb_s_base_mat_impl.F90 | 2 +- base/serial/impl/psb_z_base_mat_impl.F90 | 2 +- krylov/psb_cbicg.f90 | 237 --------------- krylov/psb_ccg.f90 | 184 ------------ krylov/psb_ccgs.f90 | 232 -------------- krylov/psb_ccgstab.f90 | 257 ---------------- krylov/psb_ccgstabl.f90 | 305 ------------------- krylov/psb_ckrylov.f90 | 256 +++------------- krylov/psb_crgmres.f90 | 367 +---------------------- krylov/psb_dbicg.f90 | 237 --------------- krylov/psb_dcg.f90 | 184 ------------ krylov/psb_dcgs.f90 | 232 -------------- krylov/psb_dcgstab.f90 | 257 ---------------- krylov/psb_dcgstabl.f90 | 305 ------------------- krylov/psb_dkrylov.f90 | 256 +++------------- krylov/psb_drgmres.f90 | 367 +---------------------- krylov/psb_sbicg.f90 | 237 --------------- krylov/psb_scg.f90 | 184 ------------ krylov/psb_scgs.f90 | 232 -------------- krylov/psb_scgstab.f90 | 257 ---------------- krylov/psb_scgstabl.f90 | 305 ------------------- krylov/psb_skrylov.f90 | 256 +++------------- krylov/psb_srgmres.f90 | 367 +---------------------- krylov/psb_zbicg.f90 | 237 --------------- krylov/psb_zcg.f90 | 184 ------------ krylov/psb_zcgs.f90 | 232 -------------- krylov/psb_zcgstab.f90 | 257 ---------------- krylov/psb_zcgstabl.f90 | 305 ------------------- krylov/psb_zkrylov.f90 | 256 +++------------- krylov/psb_zrgmres.f90 | 367 +---------------------- 32 files changed, 192 insertions(+), 7168 deletions(-) diff --git a/base/serial/impl/psb_c_base_mat_impl.F90 b/base/serial/impl/psb_c_base_mat_impl.F90 index 294b7aa9..d28393a1 100644 --- a/base/serial/impl/psb_c_base_mat_impl.F90 +++ b/base/serial/impl/psb_c_base_mat_impl.F90 @@ -1483,7 +1483,7 @@ subroutine psb_c_base_vect_mv(alpha,a,x,beta,y,info,trans) call x%sync() call y%sync() call a%csmm(alpha,x%v,beta,y%v,info,trans) - + call y%set_host() end subroutine psb_c_base_vect_mv subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) diff --git a/base/serial/impl/psb_d_base_mat_impl.F90 b/base/serial/impl/psb_d_base_mat_impl.F90 index de2bb1ce..ada6a211 100644 --- a/base/serial/impl/psb_d_base_mat_impl.F90 +++ b/base/serial/impl/psb_d_base_mat_impl.F90 @@ -1483,7 +1483,7 @@ subroutine psb_d_base_vect_mv(alpha,a,x,beta,y,info,trans) call x%sync() call y%sync() call a%csmm(alpha,x%v,beta,y%v,info,trans) - + call y%set_host() end subroutine psb_d_base_vect_mv subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) diff --git a/base/serial/impl/psb_s_base_mat_impl.F90 b/base/serial/impl/psb_s_base_mat_impl.F90 index 7e0cfc98..638cf925 100644 --- a/base/serial/impl/psb_s_base_mat_impl.F90 +++ b/base/serial/impl/psb_s_base_mat_impl.F90 @@ -1483,7 +1483,7 @@ subroutine psb_s_base_vect_mv(alpha,a,x,beta,y,info,trans) call x%sync() call y%sync() call a%csmm(alpha,x%v,beta,y%v,info,trans) - + call y%set_host() end subroutine psb_s_base_vect_mv subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) diff --git a/base/serial/impl/psb_z_base_mat_impl.F90 b/base/serial/impl/psb_z_base_mat_impl.F90 index fb9f80d4..c016c8c1 100644 --- a/base/serial/impl/psb_z_base_mat_impl.F90 +++ b/base/serial/impl/psb_z_base_mat_impl.F90 @@ -1483,7 +1483,7 @@ subroutine psb_z_base_vect_mv(alpha,a,x,beta,y,info,trans) call x%sync() call y%sync() call a%csmm(alpha,x%v,beta,y%v,info,trans) - + call y%set_host() end subroutine psb_z_base_vect_mv subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) diff --git a/krylov/psb_cbicg.f90 b/krylov/psb_cbicg.f90 index 1beb3ad1..25d8b93b 100644 --- a/krylov/psb_cbicg.f90 +++ b/krylov/psb_cbicg.f90 @@ -93,243 +93,6 @@ ! estimate of) residual. ! ! -!!$subroutine psb_cbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_c_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ implicit none -!!$ -!!$! !$ parameters -!!$ type(psb_cspmat_type), intent(in) :: a -!!$ class(psb_cprec_type), intent(in) :: prec -!!$ type(psb_desc_type), intent(in) :: desc_a -!!$ complex(psb_spk_), intent(in) :: b(:) -!!$ complex(psb_spk_), intent(inout) :: x(:) -!!$ real(psb_spk_), intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), optional, intent(in) :: itmax, itrace, istop -!!$ integer(psb_ipk_), optional, intent(out) :: iter -!!$ real(psb_spk_), optional, intent(out) :: err -!!$! !$ local data -!!$ complex(psb_spk_), allocatable, target :: aux(:),wwrk(:,:) -!!$ complex(psb_spk_), pointer :: ww(:), q(:),& -!!$ & r(:), p(:), zt(:), pt(:), z(:), rt(:),qt(:) -!!$ integer(psb_ipk_) :: int_err(5) -!!$ integer(psb_ipk_) ::itmax_, naux, mglob, it, itrace_,& -!!$ & np,me, n_row, n_col, istop_, err_act -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ logical, parameter :: exchange=.true., noexchange=.false. -!!$ integer(psb_ipk_), parameter :: irmax = 8 -!!$ integer(psb_ipk_) :: itx, ictxt -!!$ complex(psb_spk_) :: alpha, beta, rho, rho_old, sigma -!!$ type(psb_itconv_type) :: stopdat -!!$ real(psb_dpk_) :: derr -!!$ character(len=20) :: name,ch_err -!!$ character(len=*), parameter :: methdname='BiCG' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_cbicg' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ ictxt = desc_a%get_context() -!!$ call psb_info(ictxt, me, np) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ -!!$ if (present(istop)) then -!!$ istop_ = istop -!!$ else -!!$ istop_ = 2 -!!$ endif -!!$ ! -!!$ ! istop_ = 1: normwise backward error, infinity norm -!!$ ! istop_ = 2: ||r||/||b|| norm 2 -!!$ ! -!!$ -!!$ if ((istop_ < 1 ).or.(istop_ > 2 ) ) then -!!$ info=psb_err_invalid_istop_ -!!$ int_err=istop_ -!!$ err=info -!!$ call psb_errpush(info,name,i_err=int_err) -!!$ goto 9999 -!!$ endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X') -!!$ goto 9999 -!!$ end if -!!$ call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ naux=4*n_col -!!$ -!!$ allocate(aux(naux),stat=info) -!!$ if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=9) -!!$ if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ ch_err='psb_asb' -!!$ err=info -!!$ call psb_errpush(info,name,a_err=ch_err) -!!$ goto 9999 -!!$ end if -!!$ -!!$ q => wwrk(:,1) -!!$ qt => wwrk(:,2) -!!$ r => wwrk(:,3) -!!$ rt => wwrk(:,4) -!!$ p => wwrk(:,5) -!!$ pt => wwrk(:,6) -!!$ z => wwrk(:,7) -!!$ zt => wwrk(:,8) -!!$ ww => wwrk(:,9) -!!$ -!!$ if (present(itmax)) then -!!$ itmax_ = itmax -!!$ else -!!$ itmax_ = 1000 -!!$ endif -!!$ -!!$ if (present(itrace)) then -!!$ itrace_ = itrace -!!$ else -!!$ itrace_ = 0 -!!$ end if -!!$ -!!$ itx = 0 -!!$ -!!$ -!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ restart: do -!!$! !$ -!!$! !$ r0 = b-ax0 -!!$! !$ -!!$ if (itx >= itmax_) exit restart -!!$ it = 0 -!!$ call psb_geaxpby(cone,b,czero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),' cone spmm',info -!!$ if (info == psb_success_) call psb_geaxpby(cone,r,czero,rt,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ rho = czero -!!$ -!!$ ! Perhaps we already satisfy the convergence criterion... -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ iteration: do -!!$ it = it + 1 -!!$ itx = itx + 1 -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),'iteration: ',itx -!!$ -!!$ call prec%apply(r,z,desc_a,info,work=aux) -!!$ if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='c',work=aux) -!!$ -!!$ rho_old = rho -!!$ rho = psb_gedot(rt,z,desc_a,info) -!!$ if (rho == czero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' iteration breakdown r',rho -!!$ exit iteration -!!$ endif -!!$ -!!$ if (it == 1) then -!!$ call psb_geaxpby(cone,z,czero,p,desc_a,info) -!!$ call psb_geaxpby(cone,zt,czero,pt,desc_a,info) -!!$ else -!!$ beta = (rho/rho_old) -!!$ call psb_geaxpby(cone,z,(beta),p,desc_a,info) -!!$ call psb_geaxpby(cone,zt,(beta),pt,desc_a,info) -!!$ end if -!!$ -!!$ call psb_spmm(cone,a,p,czero,q,desc_a,info,& -!!$ & work=aux) -!!$ call psb_spmm(cone,a,pt,czero,qt,desc_a,info,& -!!$ & work=aux,trans='c') -!!$ -!!$ sigma = psb_gedot(pt,q,desc_a,info) -!!$ if (sigma == czero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' iteration breakdown s1', sigma -!!$ exit iteration -!!$ endif -!!$ -!!$ alpha = rho/sigma -!!$ -!!$ -!!$ call psb_geaxpby((alpha),p,cone,x,desc_a,info) -!!$ call psb_geaxpby(-(alpha),q,cone,r,desc_a,info) -!!$ call psb_geaxpby(-(alpha),qt,cone,rt,desc_a,info) -!!$ -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ end do iteration -!!$ end do restart -!!$ -!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ deallocate(aux, stat=info) -!!$ if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$end subroutine psb_cbicg -!!$ - subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,istop) diff --git a/krylov/psb_ccg.f90 b/krylov/psb_ccg.f90 index 3ea0e53a..06c715d1 100644 --- a/krylov/psb_ccg.f90 +++ b/krylov/psb_ccg.f90 @@ -95,190 +95,6 @@ ! estimate of) residual. ! ! -!!$subroutine psb_ccg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_c_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ implicit none -!!$ -!!$! = Parameters -!!$ Type(psb_cspmat_type), Intent(in) :: a -!!$ class(psb_cprec_type), Intent(in) :: prec -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ complex(psb_spk_), Intent(in) :: b(:) -!!$ complex(psb_spk_), Intent(inout) :: x(:) -!!$ Real(psb_spk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_spk_), Optional, Intent(out) :: err -!!$! = Local data -!!$ complex(psb_spk_), allocatable, target :: aux(:), wwrk(:,:) -!!$ complex(psb_spk_), pointer :: q(:), p(:), r(:), z(:), w(:) -!!$ complex(psb_spk_) :: alpha, beta, rho, rho_old, sigma -!!$ integer(psb_ipk_) :: itmax_, istop_, naux, mglob, it, itx, itrace_,& -!!$ & np,me, n_col, isvch, ictxt, n_row,err_act, int_err(5) -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ type(psb_itconv_type) :: stopdat -!!$ real(psb_dpk_) :: derr -!!$ character(len=20) :: name -!!$ character(len=*), parameter :: methdname='CG' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_ccg' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ ictxt = desc_a%get_context() -!!$ -!!$ call psb_info(ictxt, me, np) -!!$ -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ if (present(istop)) then -!!$ istop_ = istop -!!$ else -!!$ istop_ = 2 -!!$ endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,ione),ione,ione,desc_a,info) -!!$ if (info == psb_success_) call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X/B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ naux=4*n_col -!!$ allocate(aux(naux), stat=info) -!!$ if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=psb_err_invalid_input_) -!!$ if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ p => wwrk(:,1) -!!$ q => wwrk(:,2) -!!$ r => wwrk(:,3) -!!$ z => wwrk(:,4) -!!$ w => wwrk(:,5) -!!$ -!!$ -!!$ if (present(itmax)) then -!!$ itmax_ = itmax -!!$ else -!!$ itmax_ = 1000 -!!$ endif -!!$ -!!$ if (present(itrace)) then -!!$ itrace_ = itrace -!!$ else -!!$ itrace_ = 0 -!!$ end if -!!$ -!!$ itx=0 -!!$ -!!$ restart: do -!!$! = -!!$! = r0 = b-Ax0 -!!$! = -!!$ if (itx>= itmax_) exit restart -!!$ -!!$ it = 0 -!!$ call psb_geaxpby(cone,b,czero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ rho = czero -!!$ -!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ iteration: do -!!$ -!!$ it = it + 1 -!!$ itx = itx + 1 -!!$ -!!$ call prec%apply(r,z,desc_a,info,work=aux) -!!$ rho_old = rho -!!$ rho = psb_gedot(r,z,desc_a,info) -!!$ -!!$ if (it == 1) then -!!$ call psb_geaxpby(cone,z,czero,p,desc_a,info) -!!$ else -!!$ if (rho_old == czero) then -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ': CG Iteration breakdown rho' -!!$ exit iteration -!!$ endif -!!$ beta = rho/rho_old -!!$ call psb_geaxpby(cone,z,beta,p,desc_a,info) -!!$ end if -!!$ -!!$ call psb_spmm(cone,a,p,czero,q,desc_a,info,work=aux) -!!$ sigma = psb_gedot(p,q,desc_a,info) -!!$ if (sigma == czero) then -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ': CG Iteration breakdown sigma' -!!$ exit iteration -!!$ endif -!!$ -!!$ alpha = rho/sigma -!!$ call psb_geaxpby(alpha,p,cone,x,desc_a,info) -!!$ call psb_geaxpby(-alpha,q,cone,r,desc_a,info) -!!$ -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ end do iteration -!!$ end do restart -!!$ -!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ call psb_gefree(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$end subroutine psb_ccg -!!$ - subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,istop) use psb_base_mod diff --git a/krylov/psb_ccgs.f90 b/krylov/psb_ccgs.f90 index d9203e0f..f021d35b 100644 --- a/krylov/psb_ccgs.f90 +++ b/krylov/psb_ccgs.f90 @@ -92,238 +92,6 @@ ! where r is the (preconditioned, recursive ! estimate of) residual. ! -!!$Subroutine psb_ccgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_c_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ implicit none -!!$ -!!$! = parameters -!!$ Type(psb_cspmat_type), Intent(in) :: a -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ class(psb_cprec_type), Intent(in) :: prec -!!$ complex(psb_spk_), Intent(in) :: b(:) -!!$ complex(psb_spk_), Intent(inout) :: x(:) -!!$ Real(psb_spk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_spk_), Optional, Intent(out) :: err -!!$! = local data -!!$ complex(psb_spk_), allocatable, target :: aux(:),wwrk(:,:) -!!$ complex(psb_spk_), Pointer :: ww(:), q(:),& -!!$ & r(:), p(:), v(:), s(:), z(:), f(:), rt(:),qt(:),uv(:) -!!$ integer(psb_ipk_) :: itmax_, naux, mglob, it, itrace_,int_err(5),& -!!$ & np,me, n_row, n_col,istop_, err_act -!!$ integer(psb_ipk_) :: itx, isvch, ictxt -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ complex(psb_spk_) :: alpha, beta, rho, rho_old, sigma -!!$ type(psb_itconv_type) :: stopdat -!!$ real(psb_dpk_) :: derr -!!$ character(len=20) :: name -!!$ character(len=*), parameter :: methdname='CGS' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_ccgs' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ ictxt = desc_a%get_context() -!!$ Call psb_info(ictxt, me, np) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ If (Present(istop)) Then -!!$ istop_ = istop -!!$ Else -!!$ istop_ = 2 -!!$ Endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,ione),ione,ione,desc_a,info) -!!$ if (info == psb_success_) call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X/B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ naux=4*n_col -!!$ Allocate(aux(naux),stat=info) -!!$ if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=11) -!!$ if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info) -!!$ if (info /= psb_success_) Then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ q => wwrk(:,1) -!!$ qt => wwrk(:,2) -!!$ r => wwrk(:,3) -!!$ rt => wwrk(:,4) -!!$ p => wwrk(:,5) -!!$ v => wwrk(:,6) -!!$ uv => wwrk(:,7) -!!$ z => wwrk(:,8) -!!$ f => wwrk(:,9) -!!$ s => wwrk(:,10) -!!$ ww => wwrk(:,11) -!!$ -!!$ -!!$ If (Present(itmax)) Then -!!$ itmax_ = itmax -!!$ Else -!!$ itmax_ = 1000 -!!$ Endif -!!$ -!!$ If (Present(itrace)) Then -!!$ itrace_ = itrace -!!$ Else -!!$ itrace_ = 0 -!!$ End If -!!$ -!!$ -!!$ itx = 0 -!!$ -!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ restart: Do -!!$! = -!!$! = r0 = b-ax0 -!!$! = -!!$ if (itx >= itmax_) exit restart -!!$ it = 0 -!!$ call psb_geaxpby(cone,b,czero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux) -!!$ if (info == psb_success_) call psb_geaxpby(cone,r,czero,rt,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ ! Perhaps we already satisfy the convergence criterion... -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ rho = czero -!!$ -!!$ iteration: do -!!$ it = it + 1 -!!$ itx = itx + 1 -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),'iteration: ',itx -!!$ -!!$ rho_old = rho -!!$ rho = psb_gedot(rt,r,desc_a,info) -!!$ -!!$ if (rho == czero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' iteration breakdown r',rho -!!$ exit iteration -!!$ endif -!!$ -!!$ if (it == 1) then -!!$ call psb_geaxpby(cone,r,czero,uv,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(cone,r,czero,p,desc_a,info) -!!$ else -!!$ beta = (rho/rho_old) -!!$ call psb_geaxpby(cone,r,czero,uv,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(beta,q,cone,uv,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(cone,q,beta,p,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(cone,uv,beta,p,desc_a,info) -!!$ end if -!!$ -!!$ if (info == psb_success_) call prec%apply(p,f,desc_a,info,work=aux) -!!$ -!!$ if (info == psb_success_) call psb_spmm(cone,a,f,czero,v,desc_a,info,& -!!$ & work=aux) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='First loop part ') -!!$ goto 9999 -!!$ end if -!!$ -!!$ sigma = psb_gedot(rt,v,desc_a,info) -!!$ if (sigma == czero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' iteration breakdown s1', sigma -!!$ exit iteration -!!$ endif -!!$ -!!$ alpha = rho/sigma -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(cone,uv,czero,q,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(-alpha,v,cone,q,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(cone,uv,czero,s,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(cone,q,cone,s,desc_a,info) -!!$ -!!$ if (info == psb_success_) call prec%apply(s,z,desc_a,info,work=aux) -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(alpha,z,cone,x,desc_a,info) -!!$ -!!$ if (info == psb_success_) call psb_spmm(cone,a,z,czero,qt,desc_a,info,& -!!$ & work=aux) -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(-alpha,qt,cone,r,desc_a,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='X update ') -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ end do iteration -!!$ end do restart -!!$ -!!$ -!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ deallocate(aux,stat=info) -!!$ if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$end subroutine psb_ccgs - Subroutine psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,istop) use psb_base_mod diff --git a/krylov/psb_ccgstab.f90 b/krylov/psb_ccgstab.f90 index 65f8f709..423f58e6 100644 --- a/krylov/psb_ccgstab.f90 +++ b/krylov/psb_ccgstab.f90 @@ -93,263 +93,6 @@ ! where r is the (preconditioned, recursive ! estimate of) residual. ! -!!$subroutine psb_ccgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_c_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ Implicit None -!!$! = parameters -!!$ Type(psb_cspmat_type), Intent(in) :: a -!!$ class(psb_cprec_type), Intent(in) :: prec -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ complex(psb_spk_), Intent(in) :: b(:) -!!$ complex(psb_spk_), Intent(inout) :: x(:) -!!$ Real(psb_spk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_spk_), Optional, Intent(out) :: err -!!$! = Local data -!!$ complex(psb_spk_), allocatable, target :: aux(:),wwrk(:,:) -!!$ complex(psb_spk_), Pointer :: q(:),& -!!$ & r(:), p(:), v(:), s(:), t(:), z(:), f(:) -!!$ integer(psb_ipk_) :: itmax_, naux, mglob, it,itrace_,& -!!$ & np,me, n_row, n_col -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ integer(psb_ipk_) :: itx, isvch, ictxt, err_act -!!$ integer(psb_ipk_) :: istop_ -!!$ complex(psb_spk_) :: alpha, beta, rho, rho_old, sigma, omega, tau -!!$ type(psb_itconv_type) :: stopdat -!!$ real(psb_dpk_) :: derr -!!$ character(len=20) :: name -!!$ character(len=*), parameter :: methdname='BiCGStab' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_ccgstab' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ ictxt = desc_a%get_context() -!!$ call psb_info(ictxt, me, np) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ If (Present(istop)) Then -!!$ istop_ = istop -!!$ Else -!!$ istop_ = 2 -!!$ Endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X') -!!$ goto 9999 -!!$ end if -!!$ call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ naux=6*n_col -!!$ allocate(aux(naux),stat=info) -!!$ if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=8) -!!$ if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ Q => WWRK(:,1) -!!$ R => WWRK(:,2) -!!$ P => WWRK(:,3) -!!$ V => WWRK(:,4) -!!$ F => WWRK(:,5) -!!$ S => WWRK(:,6) -!!$ T => WWRK(:,7) -!!$ Z => WWRK(:,8) -!!$ -!!$ if (present(itmax)) then -!!$ itmax_ = itmax -!!$ else -!!$ itmax_ = 1000 -!!$ endif -!!$ -!!$ if (present(itrace)) then -!!$ itrace_ = itrace -!!$ else -!!$ itrace_ = 0 -!!$ end if -!!$ -!!$ itx = 0 -!!$ -!!$ -!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ -!!$ restart: Do -!!$! = -!!$! = r0 = b-Ax0 -!!$! = -!!$ if (itx >= itmax_) exit restart -!!$ it = 0 -!!$ call psb_geaxpby(cone,b,czero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux) -!!$ if (info == psb_success_) call psb_geaxpby(cone,r,czero,q,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ rho = czero -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' On entry to AMAX: B: ',Size(b) -!!$ -!!$ -!!$ ! Perhaps we already satisfy the convergence criterion... -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ iteration: Do -!!$ it = it + 1 -!!$ itx = itx + 1 -!!$ If (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Iteration: ',itx -!!$ -!!$ rho_old = rho -!!$ rho = psb_gedot(q,r,desc_a,info) -!!$ -!!$ if (rho == czero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Iteration breakdown R',rho -!!$ exit iteration -!!$ endif -!!$ -!!$ if (it == 1) then -!!$ call psb_geaxpby(cone,r,czero,p,desc_a,info) -!!$ else -!!$ beta = (rho/rho_old)*(alpha/omega) -!!$ call psb_geaxpby(-omega,v,cone,p,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(cone,r,beta,p,desc_a,info) -!!$ end if -!!$ -!!$ if (info == psb_success_) call prec%apply(p,f,desc_a,info,work=aux) -!!$ -!!$ if (info == psb_success_) call psb_spmm(cone,a,f,czero,v,desc_a,info,& -!!$ & work=aux) -!!$ -!!$ if (info == psb_success_) sigma = psb_gedot(q,v,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='First step') -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (sigma == czero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Iteration breakdown S1', sigma -!!$ exit iteration -!!$ endif -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' SIGMA:',sigma -!!$ alpha = rho/sigma -!!$ -!!$ call psb_geaxpby(cone,r,czero,s,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(-alpha,v,cone,s,desc_a,info) -!!$ if (info == psb_success_) call prec%apply(s,z,desc_a,info,work=aux) -!!$ if (info == psb_success_) call psb_spmm(cone,a,z,czero,t,desc_a,info,& -!!$ & work=aux) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='Second step ') -!!$ goto 9999 -!!$ end if -!!$ -!!$ sigma = psb_gedot(t,t,desc_a,info) -!!$ if (sigma == czero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Iteration breakdown S2', sigma -!!$ exit iteration -!!$ endif -!!$ -!!$ tau = psb_gedot(t,s,desc_a,info) -!!$ omega = tau/sigma -!!$ -!!$ if (omega == czero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Iteration breakdown O',omega -!!$ exit iteration -!!$ endif -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(alpha,f,cone,x,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(omega,z,cone,x,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(cone,s,czero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(-omega,t,cone,r,desc_a,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='X update ') -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ end do iteration -!!$ end do restart -!!$ -!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ deallocate(aux,stat=info) -!!$ if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error(ictxt) -!!$ return -!!$ end if -!!$ return -!!$ -!!$End Subroutine psb_ccgstab - - Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) use psb_base_mod use psb_prec_mod diff --git a/krylov/psb_ccgstabl.f90 b/krylov/psb_ccgstabl.f90 index d4971c3d..e5bb652c 100644 --- a/krylov/psb_ccgstabl.f90 +++ b/krylov/psb_ccgstabl.f90 @@ -103,311 +103,6 @@ ! ! ! -!!$Subroutine psb_ccgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_c_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ implicit none -!!$ -!!$! = parameters -!!$ Type(psb_cspmat_type), Intent(in) :: a -!!$ class(psb_cprec_type), Intent(in) :: prec -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ complex(psb_spk_), Intent(in) :: b(:) -!!$ complex(psb_spk_), Intent(inout) :: x(:) -!!$ Real(psb_spk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_spk_), Optional, Intent(out) :: err -!!$! = local data -!!$ complex(psb_spk_), allocatable, target :: aux(:),wwrk(:,:),uh(:,:), rh(:,:) -!!$ complex(psb_spk_), Pointer :: ww(:), q(:), r(:), rt0(:), p(:), v(:), & -!!$ & s(:), t(:), z(:), f(:), gamma(:), gamma1(:), gamma2(:), taum(:,:), sigma(:) -!!$ -!!$ integer(psb_ipk_) :: itmax_, naux, mglob, it, itrace_,& -!!$ & np,me, n_row, n_col, nl, err_act -!!$ Logical, Parameter :: exchange=.True., noexchange=.False. -!!$ integer(psb_ipk_), Parameter :: irmax = 8 -!!$ integer(psb_ipk_) :: itx, i, isvch, ictxt,istop_,j, int_err(5) -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ complex(psb_spk_) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,& -!!$ & omega -!!$ type(psb_itconv_type) :: stopdat -!!$ real(psb_dpk_) :: derr -!!$ character(len=20) :: name -!!$ character(len=*), parameter :: methdname='BiCGStab(L)' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_ccgstabl' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ ictxt = desc_a%get_context() -!!$ Call psb_info(ictxt, me, np) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np -!!$ -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ if (present(istop)) then -!!$ istop_ = istop -!!$ else -!!$ istop_ = 2 -!!$ endif -!!$ -!!$ if (present(itmax)) then -!!$ itmax_ = itmax -!!$ else -!!$ itmax_ = 1000 -!!$ endif -!!$ -!!$ if (present(itrace)) then -!!$ itrace_ = itrace -!!$ else -!!$ itrace_ = 0 -!!$ end if -!!$ -!!$ if (present(irst)) then -!!$ nl = irst -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & 'present: irst: ',irst,nl -!!$ else -!!$ nl = 1 -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' not present: irst: ',irst,nl -!!$ endif -!!$ if (nl <=0 ) then -!!$ info=psb_err_invalid_istop_ -!!$ int_err(1)=nl -!!$ err=info -!!$ call psb_errpush(info,name,i_err=int_err) -!!$ goto 9999 -!!$ endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,ione),ione,ione,desc_a,info) -!!$ if (info == psb_success_) call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X/B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ naux=4*n_col -!!$ allocate(aux(naux),gamma(0:nl),gamma1(nl),& -!!$ &gamma2(nl),taum(nl,nl),sigma(nl), stat=info) -!!$ -!!$ if (info /= psb_success_) then -!!$ info=psb_err_alloc_dealloc_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=psb_err_iarg_neg_) -!!$ if (info == psb_success_) Call psb_geall(uh,desc_a,info,n=nl+1,lb=0) -!!$ if (info == psb_success_) Call psb_geall(rh,desc_a,info,n=nl+1,lb=0) -!!$ if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(uh,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(rh,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ q => wwrk(:,1) -!!$ r => wwrk(:,2) -!!$ p => wwrk(:,3) -!!$ v => wwrk(:,4) -!!$ f => wwrk(:,5) -!!$ s => wwrk(:,6) -!!$ t => wwrk(:,7) -!!$ z => wwrk(:,8) -!!$ ww => wwrk(:,9) -!!$ rt0 => wwrk(:,10) -!!$ -!!$ -!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ itx = 0 -!!$ restart: do -!!$! = -!!$! = r0 = b-ax0 -!!$! = -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),' restart: ',itx,it -!!$ if (itx >= itmax_) exit restart -!!$ -!!$ it = 0 -!!$ call psb_geaxpby(cone,b,czero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux) -!!$ -!!$ if (info == psb_success_) call prec%apply(r,desc_a,info) -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(cone,r,czero,rt0,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(cone,r,czero,rh(:,0),desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(czero,r,czero,uh(:,0),desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ rho = cone -!!$ alpha = czero -!!$ omega = cone -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' on entry to amax: b: ',Size(b) -!!$ -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ iteration: do -!!$ it = it + nl -!!$ itx = itx + nl -!!$ rho = -omega*rho -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' iteration: ',itx, rho,rh(1,0) -!!$ -!!$ do j = 0, nl -1 -!!$ If (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),'bicg part: ',j, nl -!!$ -!!$ rho_old = rho -!!$ rho = psb_gedot(rh(:,j),rt0,desc_a,info) -!!$ if (rho == czero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' bi-cgstab iteration breakdown r',rho -!!$ exit iteration -!!$ endif -!!$ -!!$ beta = alpha*rho/rho_old -!!$ rho_old = rho -!!$ call psb_geaxpby(cone,rh(:,0:j),-beta,uh(:,0:j),desc_a,info) -!!$ call psb_spmm(cone,a,uh(:,j),czero,uh(:,j+1),desc_a,info,work=aux) -!!$ -!!$ call prec%apply(uh(:,j+1),desc_a,info) -!!$ -!!$ gamma(j) = psb_gedot(uh(:,j+1),rt0,desc_a,info) -!!$ -!!$ if (gamma(j) == czero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' bi-cgstab iteration breakdown s2',gamma(j) -!!$ exit iteration -!!$ endif -!!$ alpha = rho/gamma(j) -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' bicg part: alpha=r/g ',alpha,rho,gamma(j) -!!$ -!!$ call psb_geaxpby(-alpha,uh(:,1:j+1),cone,rh(:,0:j),desc_a,info) -!!$ call psb_geaxpby(alpha,uh(:,0),cone,x,desc_a,info) -!!$ call psb_spmm(cone,a,rh(:,j),czero,rh(:,j+1),desc_a,info,work=aux) -!!$ -!!$ call prec%apply(rh(:,j+1),desc_a,info) -!!$ -!!$ enddo -!!$ -!!$ do j=1, nl -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' mod g-s part: ',j, nl,rh(1,0) -!!$ -!!$ do i=1, j-1 -!!$ taum(i,j) = psb_gedot(rh(:,i),rh(:,j),desc_a,info) -!!$ taum(i,j) = taum(i,j)/sigma(i) -!!$ call psb_geaxpby(-taum(i,j),rh(:,i),cone,rh(:,j),desc_a,info) -!!$ enddo -!!$ sigma(j) = psb_gedot(rh(:,j),rh(:,j),desc_a,info) -!!$ gamma1(j) = psb_gedot(rh(:,0),rh(:,j),desc_a,info) -!!$ gamma1(j) = gamma1(j)/sigma(j) -!!$ enddo -!!$ -!!$ gamma(nl) = gamma1(nl) -!!$ omega = gamma(nl) -!!$ -!!$ do j=nl-1,1,-1 -!!$ gamma(j) = gamma1(j) -!!$ do i=j+1,nl -!!$ gamma(j) = gamma(j) - taum(j,i) * gamma(i) -!!$ enddo -!!$ enddo -!!$ -!!$ do j=1,nl-1 -!!$ gamma2(j) = gamma(j+1) -!!$ do i=j+1,nl-1 -!!$ gamma2(j) = gamma2(j) + taum(j,i) * gamma(i+1) -!!$ enddo -!!$ enddo -!!$ -!!$ call psb_geaxpby(gamma(1),rh(:,0),cone,x,desc_a,info) -!!$ call psb_geaxpby(-gamma1(nl),rh(:,nl),cone,rh(:,0),desc_a,info) -!!$ call psb_geaxpby(-gamma(nl),uh(:,nl),cone,uh(:,0),desc_a,info) -!!$ -!!$ do j=1, nl-1 -!!$ call psb_geaxpby(-gamma(j),uh(:,j),cone,uh(:,0),desc_a,info) -!!$ call psb_geaxpby(gamma2(j),rh(:,j),cone,x,desc_a,info) -!!$ call psb_geaxpby(-gamma1(j),rh(:,j),cone,rh(:,0),desc_a,info) -!!$ enddo -!!$ -!!$ if (psb_check_conv(methdname,itx,x,rh(:,0),desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ end do iteration -!!$ end do restart -!!$ -!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ deallocate(aux,stat=info) -!!$ if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) -!!$ if (info == psb_success_) call psb_gefree(uh,desc_a,info) -!!$ if (info == psb_success_) call psb_gefree(rh,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$End Subroutine psb_ccgstabl -!!$ - - Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,irst,istop) use psb_base_mod diff --git a/krylov/psb_ckrylov.f90 b/krylov/psb_ckrylov.f90 index bdd0ff77..098ddc37 100644 --- a/krylov/psb_ckrylov.f90 +++ b/krylov/psb_ckrylov.f90 @@ -33,217 +33,51 @@ ! File: psb_krylov_mod.f90 ! Interfaces for Krylov subspace iterative methods. ! - - ! - ! Subroutine: psb_ckrylov - ! - ! Front-end for the Krylov subspace iterations, complexversion - ! - ! Arguments: - ! - ! methd - character The specific method; can take the values: - ! CG - ! CGS - ! BICG - ! BICGSTAB - ! BICGSTABL - ! RGMRES - ! - ! a - type(psb_cspmat_type) Input: sparse matrix containing A. - ! prec - class(psb_cprec_type) Input: preconditioner - ! b - complex,dimension(:) Input: vector containing the - ! right hand side B - ! x - complex,dimension(:) Input/Output: vector containing the - ! initial guess and final solution X. - ! eps - real Input: Stopping tolerance; the iteration is - ! stopped when the error - ! estimate |err| <= eps - ! - ! desc_a - type(psb_desc_type). Input: The communication descriptor. - ! info - integer. Output: Return code - ! - ! itmax - integer(optional) Input: maximum number of iterations to be - ! performed. - ! iter - integer(optional) Output: how many iterations have been - ! performed. - ! err - real (optional) Output: error estimate on exit - ! itrace - integer(optional) Input: print an informational message - ! with the error estimate every itrace - ! iterations - ! irst - integer(optional) Input: restart parameter for RGMRES and - ! BICGSTAB(L) methods - ! istop - integer(optional) Input: stopping criterion, or how - ! to estimate the error. - ! 1: err = |r|/(|a||x|+|b|) - ! 2: err = |r|/|b| - ! where r is the (preconditioned, recursive - ! estimate of) residual - ! -!!$Subroutine psb_ckrylov(method,a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod,only : psb_sprec_type, psb_dprec_type, psb_cprec_type, psb_zprec_type -!!$ use psb_krylov_mod, psb_protect_name => psb_ckrylov -!!$ character(len=*) :: method -!!$ Type(psb_cspmat_type), Intent(in) :: a -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ class(psb_cprec_type), intent(in) :: prec -!!$ complex(psb_spk_), Intent(in) :: b(:) -!!$ complex(psb_spk_), Intent(inout) :: x(:) -!!$ Real(psb_spk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_spk_), Optional, Intent(out) :: err -!!$ interface -!!$ subroutine psb_ccg(a,prec,b,x,eps,& -!!$ & desc_a,info,itmax,iter,err,itrace,istop) -!!$ import :: psb_ipk_, psb_spk_, psb_desc_type, & -!!$ & psb_cspmat_type, psb_cprec_type -!!$ type(psb_cspmat_type), intent(in) :: a -!!$ type(psb_desc_type), intent(in) :: desc_a -!!$ complex(psb_spk_), intent(in) :: b(:) -!!$ complex(psb_spk_), intent(inout) :: x(:) -!!$ real(psb_spk_), intent(in) :: eps -!!$ class(psb_cprec_type), intent(in) :: prec -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), optional, intent(in) :: itmax, itrace,istop -!!$ integer(psb_ipk_), optional, intent(out) :: iter -!!$ real(psb_spk_), optional, intent(out) :: err -!!$ end subroutine psb_ccg -!!$ subroutine psb_cbicg(a,prec,b,x,eps,& -!!$ & desc_a,info,itmax,iter,err,itrace,istop) -!!$ import :: psb_ipk_, psb_spk_, psb_desc_type, & -!!$ & psb_cspmat_type, psb_cprec_type -!!$ type(psb_cspmat_type), intent(in) :: a -!!$ type(psb_desc_type), intent(in) :: desc_a -!!$ complex(psb_spk_), intent(in) :: b(:) -!!$ complex(psb_spk_), intent(inout) :: x(:) -!!$ real(psb_spk_), intent(in) :: eps -!!$ class(psb_cprec_type), intent(in) :: prec -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), optional, intent(in) :: itmax, itrace,istop -!!$ integer(psb_ipk_), optional, intent(out) :: iter -!!$ real(psb_spk_), optional, intent(out) :: err -!!$ end subroutine psb_cbicg -!!$ subroutine psb_ccgstab(a,prec,b,x,eps,& -!!$ & desc_a,info,itmax,iter,err,itrace,istop) -!!$ import :: psb_ipk_, psb_spk_, psb_desc_type, & -!!$ & psb_cspmat_type, psb_cprec_type -!!$ type(psb_cspmat_type), intent(in) :: a -!!$ type(psb_desc_type), intent(in) :: desc_a -!!$ complex(psb_spk_), intent(in) :: b(:) -!!$ complex(psb_spk_), intent(inout) :: x(:) -!!$ real(psb_spk_), intent(in) :: eps -!!$ class(psb_cprec_type), intent(in) :: prec -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), optional, intent(in) :: itmax, itrace,istop -!!$ integer(psb_ipk_), optional, intent(out) :: iter -!!$ real(psb_spk_), optional, intent(out) :: err -!!$ end subroutine psb_ccgstab -!!$ Subroutine psb_ccgstabl(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,irst,istop) -!!$ import :: psb_ipk_, psb_spk_, psb_desc_type, & -!!$ & psb_cspmat_type, psb_cprec_type -!!$ Type(psb_cspmat_type), Intent(in) :: a -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ class(psb_cprec_type), intent(in) :: prec -!!$ complex(psb_spk_), Intent(in) :: b(:) -!!$ complex(psb_spk_), Intent(inout) :: x(:) -!!$ Real(psb_spk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_spk_), Optional, Intent(out) :: err -!!$ end subroutine psb_ccgstabl -!!$ Subroutine psb_crgmres(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,irst,istop) -!!$ import :: psb_ipk_, psb_spk_, psb_desc_type, & -!!$ & psb_cspmat_type, psb_cprec_type -!!$ Type(psb_cspmat_type), Intent(in) :: a -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ class(psb_cprec_type), intent(in) :: prec -!!$ complex(psb_spk_), Intent(in) :: b(:) -!!$ complex(psb_spk_), Intent(inout) :: x(:) -!!$ Real(psb_spk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_spk_), Optional, Intent(out) :: err -!!$ end subroutine psb_crgmres -!!$ subroutine psb_ccgs(a,prec,b,x,eps,& -!!$ & desc_a,info,itmax,iter,err,itrace,istop) -!!$ import :: psb_ipk_, psb_spk_, psb_desc_type, & -!!$ & psb_cspmat_type, psb_cprec_type -!!$ type(psb_cspmat_type), intent(in) :: a -!!$ type(psb_desc_type), intent(in) :: desc_a -!!$ complex(psb_spk_), intent(in) :: b(:) -!!$ complex(psb_spk_), intent(inout) :: x(:) -!!$ real(psb_spk_), intent(in) :: eps -!!$ class(psb_cprec_type), intent(in) :: prec -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), optional, intent(in) :: itmax, itrace,istop -!!$ integer(psb_ipk_), optional, intent(out) :: iter -!!$ real(psb_spk_), optional, intent(out) :: err -!!$ end subroutine psb_ccgs -!!$ end interface -!!$ -!!$ -!!$ integer(psb_ipk_) :: ictxt,me,np,err_act -!!$ character(len=20) :: name -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_krylov' -!!$ call psb_erractionsave(err_act) -!!$ -!!$ -!!$ ictxt=desc_a%get_context() -!!$ -!!$ call psb_info(ictxt, me, np) -!!$ -!!$ -!!$ select case(psb_toupper(method)) -!!$ case('CG') -!!$ call psb_ccg(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,istop) -!!$ case('CGS') -!!$ call psb_ccgs(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,istop) -!!$ case('BICG') -!!$ call psb_cbicg(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,istop) -!!$ case('BICGSTAB') -!!$ call psb_ccgstab(a,prec,b,x,eps,desc_a,info,& -!!$ & itmax,iter,err,itrace,istop) -!!$ case('RGMRES') -!!$ call psb_crgmres(a,prec,b,x,eps,desc_a,info,& -!!$ & itmax,iter,err,itrace,irst,istop) -!!$ case('BICGSTABL') -!!$ call psb_ccgstabl(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,irst,istop) -!!$ case default -!!$ if (me == 0) write(psb_err_unit,*) trim(name),': Warning: Unknown method ',method,& -!!$ & ', defaulting to BiCGSTAB' -!!$ call psb_ccgstab(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,istop) -!!$ end select -!!$ -!!$ if(info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error(ictxt) -!!$ return -!!$ end if -!!$ -!!$end subroutine psb_ckrylov - +! +! Subroutine: psb_ckrylov +! +! Front-end for the Krylov subspace iterations, complexversion +! +! Arguments: +! +! methd - character The specific method; can take the values: +! CG +! CGS +! BICG +! BICGSTAB +! BICGSTABL +! RGMRES +! +! a - type(psb_cspmat_type) Input: sparse matrix containing A. +! prec - class(psb_cprec_type) Input: preconditioner +! b - complex,dimension(:) Input: vector containing the +! right hand side B +! x - complex,dimension(:) Input/Output: vector containing the +! initial guess and final solution X. +! eps - real Input: Stopping tolerance; the iteration is +! stopped when the error +! estimate |err| <= eps +! +! desc_a - type(psb_desc_type). Input: The communication descriptor. +! info - integer. Output: Return code +! +! itmax - integer(optional) Input: maximum number of iterations to be +! performed. +! iter - integer(optional) Output: how many iterations have been +! performed. +! err - real (optional) Output: error estimate on exit +! itrace - integer(optional) Input: print an informational message +! with the error estimate every itrace +! iterations +! irst - integer(optional) Input: restart parameter for RGMRES and +! BICGSTAB(L) methods +! istop - integer(optional) Input: stopping criterion, or how +! to estimate the error. +! 1: err = |r|/(|a||x|+|b|) +! 2: err = |r|/|b| +! where r is the (preconditioned, recursive +! estimate of) residual +! Subroutine psb_ckrylov_vect(method,a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,irst,istop,cond) diff --git a/krylov/psb_crgmres.f90 b/krylov/psb_crgmres.f90 index f2d73164..1fbcf053 100644 --- a/krylov/psb_crgmres.f90 +++ b/krylov/psb_crgmres.f90 @@ -105,369 +105,6 @@ ! estimate of) residual. ! irst - integer(optional) Input: restart parameter ! -!!$Subroutine psb_crgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_c_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ implicit none -!!$ -!!$! = Parameters -!!$ Type(psb_cspmat_type), Intent(in) :: a -!!$ class(psb_cprec_type), Intent(in) :: prec -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ complex(psb_spk_), Intent(in) :: b(:) -!!$ complex(psb_spk_), Intent(inout) :: x(:) -!!$ Real(psb_spk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_spk_), Optional, Intent(out) :: err -!!$! = local data -!!$ complex(psb_spk_), allocatable, target :: aux(:),w(:),w1(:), v(:,:) -!!$ complex(psb_spk_), allocatable :: c(:),s(:), h(:,:), rs(:),rst(:),xt(:) -!!$ Real(psb_spk_) :: tmp -!!$ complex(psb_spk_) :: rti, rti1, scal -!!$ integer(psb_ipk_) ::litmax, naux, mglob, it,k, itrace_,& -!!$ & np,me, n_row, n_col, nl, int_err(5) -!!$ Logical, Parameter :: exchange=.True., noexchange=.False. -!!$ integer(psb_ipk_), Parameter :: irmax = 8 -!!$ integer(psb_ipk_) :: itx, i, isvch, ictxt,istop_, err_act -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ Real(psb_dpk_) :: rni, xni, bni, ani,bn2 -!!$ real(psb_dpk_) :: errnum, errden, deps, derr -!!$ character(len=20) :: name -!!$ character(len=*), parameter :: methdname='RGMRES' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_cgmres' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ ictxt = desc_a%get_context() -!!$ Call psb_info(ictxt, me, np) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ if (present(istop)) then -!!$ istop_ = istop -!!$ else -!!$ istop_ = 2 -!!$ endif -!!$ ! -!!$ ! ISTOP_ = 1: Normwise backward error, infinity norm -!!$ ! ISTOP_ = 2: ||r||/||b||, 2-norm -!!$ ! -!!$ -!!$ if ((istop_ < 1 ).or.(istop_ > 2 ) ) then -!!$ info=psb_err_invalid_istop_ -!!$ int_err(1)=istop_ -!!$ err=info -!!$ call psb_errpush(info,name,i_err=int_err) -!!$ goto 9999 -!!$ endif -!!$ -!!$ if (present(itmax)) then -!!$ litmax = itmax -!!$ else -!!$ litmax = 1000 -!!$ endif -!!$ -!!$ if (present(itrace)) then -!!$ itrace_ = itrace -!!$ else -!!$ itrace_ = 0 -!!$ end if -!!$ -!!$ if (present(irst)) then -!!$ nl = irst -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' present: irst: ',irst,nl -!!$ else -!!$ nl = 10 -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' not present: irst: ',irst,nl -!!$ endif -!!$ if (nl <=0 ) then -!!$ info=psb_err_invalid_istop_ -!!$ int_err(1)=nl -!!$ err=info -!!$ call psb_errpush(info,name,i_err=int_err) -!!$ goto 9999 -!!$ endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,1),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X') -!!$ goto 9999 -!!$ end if -!!$ call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ naux=4*n_col -!!$ allocate(aux(naux),h(nl+1,nl+1),& -!!$ &c(nl+1),s(nl+1),rs(nl+1), rst(nl+1),stat=info) -!!$ -!!$ if (info == psb_success_) Call psb_geall(v,desc_a,info,n=nl+1) -!!$ if (info == psb_success_) Call psb_geall(w,desc_a,info) -!!$ if (info == psb_success_) Call psb_geall(w1,desc_a,info) -!!$ if (info == psb_success_) Call psb_geall(xt,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(v,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(w,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(w1,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(xt,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Size of V,W,W1 ',size(v),size(v,1),& -!!$ & size(w),size(w,1),size(w1),size(w1,1), size(v(:,1)) -!!$ -!!$ -!!$ if (istop_ == 1) then -!!$ ani = psb_spnrmi(a,desc_a,info) -!!$ bni = psb_geamax(b,desc_a,info) -!!$ else if (istop_ == 2) then -!!$ bn2 = psb_genrm2(b,desc_a,info) -!!$ endif -!!$ errnum = dzero -!!$ errden = done -!!$ deps = eps -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ if ((itrace_ > 0).and.(me == 0)) call log_header(methdname) -!!$ -!!$ itx = 0 -!!$ restart: do -!!$ -!!$ ! compute r0 = b-ax0 -!!$ ! check convergence -!!$ ! compute v1 = r0/||r0||_2 -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' restart: ',itx,it -!!$ it = 0 -!!$ call psb_geaxpby(cone,b,czero,v(:,1),desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_spmm(-cone,a,x,cone,v(:,1),desc_a,info,work=aux) -!!$ if (info /= psb_success_) Then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ rs(1) = psb_genrm2(v(:,1),desc_a,info) -!!$ rs(2:) = czero -!!$ if (info /= psb_success_) Then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ scal=done/rs(1) ! rs(1) MIGHT BE VERY SMALL - USE DSCAL TO DEAL WITH IT? -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' on entry to amax: b: ',Size(b),rs(1),scal -!!$ -!!$ ! -!!$ ! check convergence -!!$ ! -!!$ if (istop_ == 1) then -!!$ rni = psb_geamax(v(:,1),desc_a,info) -!!$ xni = psb_geamax(x,desc_a,info) -!!$ errnum = rni -!!$ errden = (ani*xni+bni) -!!$ else if (istop_ == 2) then -!!$ rni = psb_genrm2(v(:,1),desc_a,info) -!!$ errnum = rni -!!$ errden = bn2 -!!$ endif -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (errnum <= deps*errden) exit restart -!!$ -!!$ if (itrace_ > 0) & -!!$ & call log_conv(methdname,me,itx,itrace_,errnum,errden,deps) -!!$ -!!$ v(:,1) = v(:,1) * scal -!!$ -!!$ if (itx >= litmax) exit restart -!!$ -!!$ ! -!!$ ! inner iterations -!!$ ! -!!$ -!!$ inner: Do i=1,nl -!!$ itx = itx + 1 -!!$ -!!$ call prec%apply(v(:,i),w1,desc_a,info) -!!$ Call psb_spmm(cone,a,w1,czero,w,desc_a,info,work=aux) -!!$ ! -!!$ -!!$ do k = 1, i -!!$ h(k,i) = psb_gedot(v(:,k),w,desc_a,info) -!!$ call psb_geaxpby(-h(k,i),v(:,k),cone,w,desc_a,info) -!!$ end do -!!$ h(i+1,i) = psb_genrm2(w,desc_a,info) -!!$ scal=done/h(i+1,i) -!!$ call psb_geaxpby(scal,w,czero,v(:,i+1),desc_a,info) -!!$ do k=2,i -!!$ call crot(1,h(k-1,i),1,h(k,i),1,real(c(k-1)),s(k-1)) -!!$ enddo -!!$ -!!$ rti = h(i,i) -!!$ rti1 = h(i+1,i) -!!$ call crotg(rti,rti1,tmp,s(i)) -!!$ c(i) = cmplx(tmp,szero) -!!$ call crot(1,h(i,i),1,h(i+1,i),1,real(c(i)),s(i)) -!!$ h(i+1,i) = czero -!!$ call crot(1,rs(i),1,rs(i+1),1,real(c(i)),s(i)) -!!$ -!!$ if (istop_ == 1) then -!!$ ! -!!$ ! build x and then compute the residual and its infinity norm -!!$ ! -!!$ rst = rs -!!$ xt = czero -!!$ call ctrsm('l','u','n','n',i,1,cone,h,size(h,1),rst,size(rst,1)) -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Rebuild x-> RS:',rst(1:nl) -!!$ do k=1, i -!!$ call psb_geaxpby(rst(k),v(:,k),cone,xt,desc_a,info) -!!$ end do -!!$ call prec%apply(xt,desc_a,info) -!!$ call psb_geaxpby(cone,x,cone,xt,desc_a,info) -!!$ call psb_geaxpby(cone,b,czero,w1,desc_a,info) -!!$ call psb_spmm(-cone,a,xt,cone,w1,desc_a,info,work=aux) -!!$ rni = psb_geamax(w1,desc_a,info) -!!$ xni = psb_geamax(xt,desc_a,info) -!!$ errnum = rni -!!$ errden = (ani*xni+bni) -!!$ ! -!!$ -!!$ else if (istop_ == 2) then -!!$ ! -!!$ ! compute the residual 2-norm as byproduct of the solution -!!$ ! procedure of the least-squares problem -!!$ ! -!!$ rni = abs(rs(i+1)) -!!$ errnum = rni -!!$ errden = bn2 -!!$ endif -!!$ -!!$ If (errnum <= deps*errden) Then -!!$ -!!$ if (istop_ == 1) then -!!$ x = xt -!!$ else if (istop_ == 2) then -!!$ ! -!!$ ! build x -!!$ ! -!!$ call ctrsm('l','u','n','n',i,1,cone,h,size(h,1),rs,size(rs,1)) -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Rebuild x-> RS:',rs(1:nl) -!!$ w1 = czero -!!$ do k=1, i -!!$ call psb_geaxpby(rs(k),v(:,k),cone,w1,desc_a,info) -!!$ end do -!!$ call prec%apply(w1,w,desc_a,info) -!!$ call psb_geaxpby(cone,w,cone,x,desc_a,info) -!!$ end if -!!$ -!!$ exit restart -!!$ -!!$ end if -!!$ -!!$ if (itrace_ > 0) & -!!$ & call log_conv(methdname,me,itx,itrace_,errnum,errden,deps) -!!$ -!!$ end do inner -!!$ -!!$ if (istop_ == 1) then -!!$ x = xt -!!$ else if (istop_ == 2) then -!!$ ! -!!$ ! build x -!!$ ! -!!$ call ctrsm('l','u','n','n',nl,1,cone,h,size(h,1),rs,size(rs,1)) -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Rebuild x-> RS:',rs(1:nl) -!!$ w1 = czero -!!$ do k=1, nl -!!$ call psb_geaxpby(rs(k),v(:,k),cone,w1,desc_a,info) -!!$ end do -!!$ call prec%apply(w1,w,desc_a,info) -!!$ call psb_geaxpby(cone,w,cone,x,desc_a,info) -!!$ end if -!!$ -!!$ end do restart -!!$ if (itrace_ > 0) & -!!$ & call log_conv(methdname,me,itx,ione,errnum,errden,deps) -!!$ -!!$ call log_end(methdname,me,itx,errnum,errden,deps,err=derr,iter=iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ -!!$ deallocate(aux,h,c,s,rs,rst, stat=info) -!!$ if (info == psb_success_) call psb_gefree(v,desc_a,info) -!!$ if (info == psb_success_) call psb_gefree(w,desc_a,info) -!!$ if (info == psb_success_) call psb_gefree(w1,desc_a,info) -!!$ if (info == psb_success_) call psb_gefree(xt,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$End Subroutine psb_crgmres - - subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,irst,istop) @@ -738,7 +375,7 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,& call ctrsm('l','u','n','n',i,1,cone,h,size(h,1),rst,size(rst,1)) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& - & ' Rebuild x-> RS:',rst(1:nl) + & ' Rebuild x-> RS:',rst(1:i) do k=1, i call psb_geaxpby(rst(k),v(k),cone,xt,desc_a,info) end do @@ -774,7 +411,7 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,& call ctrsm('l','u','n','n',i,1,cone,h,size(h,1),rs,size(rs,1)) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& - & ' Rebuild x-> RS:',rs(1:nl) + & ' Rebuild x-> RS:',rs(1:i) call w1%set(czero) do k=1, i call psb_geaxpby(rs(k),v(k),cone,w1,desc_a,info) diff --git a/krylov/psb_dbicg.f90 b/krylov/psb_dbicg.f90 index 088841a0..fa3796a3 100644 --- a/krylov/psb_dbicg.f90 +++ b/krylov/psb_dbicg.f90 @@ -93,243 +93,6 @@ ! estimate of) residual. ! ! -!!$subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_d_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ implicit none -!!$ -!!$! !$ parameters -!!$ type(psb_dspmat_type), intent(in) :: a -!!$ class(psb_dprec_type), intent(in) :: prec -!!$ type(psb_desc_type), intent(in) :: desc_a -!!$ real(psb_dpk_), intent(in) :: b(:) -!!$ real(psb_dpk_), intent(inout) :: x(:) -!!$ real(psb_dpk_), intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), optional, intent(in) :: itmax, itrace, istop -!!$ integer(psb_ipk_), optional, intent(out) :: iter -!!$ real(psb_dpk_), optional, intent(out) :: err -!!$! !$ local data -!!$ real(psb_dpk_), allocatable, target :: aux(:),wwrk(:,:) -!!$ real(psb_dpk_), pointer :: ww(:), q(:),& -!!$ & r(:), p(:), zt(:), pt(:), z(:), rt(:),qt(:) -!!$ integer(psb_ipk_) :: int_err(5) -!!$ integer(psb_ipk_) ::itmax_, naux, mglob, it, itrace_,& -!!$ & np,me, n_row, n_col, istop_, err_act -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ logical, parameter :: exchange=.true., noexchange=.false. -!!$ integer(psb_ipk_), parameter :: irmax = 8 -!!$ integer(psb_ipk_) :: itx, ictxt -!!$ real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma -!!$ type(psb_itconv_type) :: stopdat -!!$ real(psb_dpk_) :: derr -!!$ character(len=20) :: name,ch_err -!!$ character(len=*), parameter :: methdname='BiCG' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_dbicg' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ ictxt = desc_a%get_context() -!!$ call psb_info(ictxt, me, np) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ -!!$ if (present(istop)) then -!!$ istop_ = istop -!!$ else -!!$ istop_ = 2 -!!$ endif -!!$ ! -!!$ ! istop_ = 1: normwise backward error, infinity norm -!!$ ! istop_ = 2: ||r||/||b|| norm 2 -!!$ ! -!!$ -!!$ if ((istop_ < 1 ).or.(istop_ > 2 ) ) then -!!$ info=psb_err_invalid_istop_ -!!$ int_err=istop_ -!!$ err=info -!!$ call psb_errpush(info,name,i_err=int_err) -!!$ goto 9999 -!!$ endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X') -!!$ goto 9999 -!!$ end if -!!$ call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ naux=4*n_col -!!$ -!!$ allocate(aux(naux),stat=info) -!!$ if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=9) -!!$ if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ ch_err='psb_asb' -!!$ err=info -!!$ call psb_errpush(info,name,a_err=ch_err) -!!$ goto 9999 -!!$ end if -!!$ -!!$ q => wwrk(:,1) -!!$ qt => wwrk(:,2) -!!$ r => wwrk(:,3) -!!$ rt => wwrk(:,4) -!!$ p => wwrk(:,5) -!!$ pt => wwrk(:,6) -!!$ z => wwrk(:,7) -!!$ zt => wwrk(:,8) -!!$ ww => wwrk(:,9) -!!$ -!!$ if (present(itmax)) then -!!$ itmax_ = itmax -!!$ else -!!$ itmax_ = 1000 -!!$ endif -!!$ -!!$ if (present(itrace)) then -!!$ itrace_ = itrace -!!$ else -!!$ itrace_ = 0 -!!$ end if -!!$ -!!$ itx = 0 -!!$ -!!$ -!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ restart: do -!!$! !$ -!!$! !$ r0 = b-ax0 -!!$! !$ -!!$ if (itx >= itmax_) exit restart -!!$ it = 0 -!!$ call psb_geaxpby(done,b,dzero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),' done spmm',info -!!$ if (info == psb_success_) call psb_geaxpby(done,r,dzero,rt,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ rho = dzero -!!$ -!!$ ! Perhaps we already satisfy the convergence criterion... -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ iteration: do -!!$ it = it + 1 -!!$ itx = itx + 1 -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),'iteration: ',itx -!!$ -!!$ call prec%apply(r,z,desc_a,info,work=aux) -!!$ if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='c',work=aux) -!!$ -!!$ rho_old = rho -!!$ rho = psb_gedot(rt,z,desc_a,info) -!!$ if (rho == dzero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' iteration breakdown r',rho -!!$ exit iteration -!!$ endif -!!$ -!!$ if (it == 1) then -!!$ call psb_geaxpby(done,z,dzero,p,desc_a,info) -!!$ call psb_geaxpby(done,zt,dzero,pt,desc_a,info) -!!$ else -!!$ beta = (rho/rho_old) -!!$ call psb_geaxpby(done,z,(beta),p,desc_a,info) -!!$ call psb_geaxpby(done,zt,(beta),pt,desc_a,info) -!!$ end if -!!$ -!!$ call psb_spmm(done,a,p,dzero,q,desc_a,info,& -!!$ & work=aux) -!!$ call psb_spmm(done,a,pt,dzero,qt,desc_a,info,& -!!$ & work=aux,trans='c') -!!$ -!!$ sigma = psb_gedot(pt,q,desc_a,info) -!!$ if (sigma == dzero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' iteration breakdown s1', sigma -!!$ exit iteration -!!$ endif -!!$ -!!$ alpha = rho/sigma -!!$ -!!$ -!!$ call psb_geaxpby((alpha),p,done,x,desc_a,info) -!!$ call psb_geaxpby(-(alpha),q,done,r,desc_a,info) -!!$ call psb_geaxpby(-(alpha),qt,done,rt,desc_a,info) -!!$ -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ end do iteration -!!$ end do restart -!!$ -!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ deallocate(aux, stat=info) -!!$ if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$end subroutine psb_dbicg -!!$ - subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,istop) diff --git a/krylov/psb_dcg.f90 b/krylov/psb_dcg.f90 index 2d0997ac..0d145c8d 100644 --- a/krylov/psb_dcg.f90 +++ b/krylov/psb_dcg.f90 @@ -95,190 +95,6 @@ ! estimate of) residual. ! ! -!!$subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_d_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ implicit none -!!$ -!!$! = Parameters -!!$ Type(psb_dspmat_type), Intent(in) :: a -!!$ class(psb_dprec_type), Intent(in) :: prec -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ real(psb_dpk_), Intent(in) :: b(:) -!!$ real(psb_dpk_), Intent(inout) :: x(:) -!!$ Real(psb_dpk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_dpk_), Optional, Intent(out) :: err -!!$! = Local data -!!$ real(psb_dpk_), allocatable, target :: aux(:), wwrk(:,:) -!!$ real(psb_dpk_), pointer :: q(:), p(:), r(:), z(:), w(:) -!!$ real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma -!!$ integer(psb_ipk_) :: itmax_, istop_, naux, mglob, it, itx, itrace_,& -!!$ & np,me, n_col, isvch, ictxt, n_row,err_act, int_err(5) -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ type(psb_itconv_type) :: stopdat -!!$ real(psb_dpk_) :: derr -!!$ character(len=20) :: name -!!$ character(len=*), parameter :: methdname='CG' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_dcg' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ ictxt = desc_a%get_context() -!!$ -!!$ call psb_info(ictxt, me, np) -!!$ -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ if (present(istop)) then -!!$ istop_ = istop -!!$ else -!!$ istop_ = 2 -!!$ endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,ione),ione,ione,desc_a,info) -!!$ if (info == psb_success_) call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X/B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ naux=4*n_col -!!$ allocate(aux(naux), stat=info) -!!$ if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=psb_err_invalid_input_) -!!$ if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ p => wwrk(:,1) -!!$ q => wwrk(:,2) -!!$ r => wwrk(:,3) -!!$ z => wwrk(:,4) -!!$ w => wwrk(:,5) -!!$ -!!$ -!!$ if (present(itmax)) then -!!$ itmax_ = itmax -!!$ else -!!$ itmax_ = 1000 -!!$ endif -!!$ -!!$ if (present(itrace)) then -!!$ itrace_ = itrace -!!$ else -!!$ itrace_ = 0 -!!$ end if -!!$ -!!$ itx=0 -!!$ -!!$ restart: do -!!$! = -!!$! = r0 = b-Ax0 -!!$! = -!!$ if (itx>= itmax_) exit restart -!!$ -!!$ it = 0 -!!$ call psb_geaxpby(done,b,dzero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ rho = dzero -!!$ -!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ iteration: do -!!$ -!!$ it = it + 1 -!!$ itx = itx + 1 -!!$ -!!$ call prec%apply(r,z,desc_a,info,work=aux) -!!$ rho_old = rho -!!$ rho = psb_gedot(r,z,desc_a,info) -!!$ -!!$ if (it == 1) then -!!$ call psb_geaxpby(done,z,dzero,p,desc_a,info) -!!$ else -!!$ if (rho_old == dzero) then -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ': CG Iteration breakdown rho' -!!$ exit iteration -!!$ endif -!!$ beta = rho/rho_old -!!$ call psb_geaxpby(done,z,beta,p,desc_a,info) -!!$ end if -!!$ -!!$ call psb_spmm(done,a,p,dzero,q,desc_a,info,work=aux) -!!$ sigma = psb_gedot(p,q,desc_a,info) -!!$ if (sigma == dzero) then -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ': CG Iteration breakdown sigma' -!!$ exit iteration -!!$ endif -!!$ -!!$ alpha = rho/sigma -!!$ call psb_geaxpby(alpha,p,done,x,desc_a,info) -!!$ call psb_geaxpby(-alpha,q,done,r,desc_a,info) -!!$ -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ end do iteration -!!$ end do restart -!!$ -!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ call psb_gefree(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$end subroutine psb_dcg -!!$ - subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,istop) use psb_base_mod diff --git a/krylov/psb_dcgs.f90 b/krylov/psb_dcgs.f90 index b9508199..0bc6ecc8 100644 --- a/krylov/psb_dcgs.f90 +++ b/krylov/psb_dcgs.f90 @@ -92,238 +92,6 @@ ! where r is the (preconditioned, recursive ! estimate of) residual. ! -!!$Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_d_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ implicit none -!!$ -!!$! = parameters -!!$ Type(psb_dspmat_type), Intent(in) :: a -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ class(psb_dprec_type), Intent(in) :: prec -!!$ real(psb_dpk_), Intent(in) :: b(:) -!!$ real(psb_dpk_), Intent(inout) :: x(:) -!!$ Real(psb_dpk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_dpk_), Optional, Intent(out) :: err -!!$! = local data -!!$ real(psb_dpk_), allocatable, target :: aux(:),wwrk(:,:) -!!$ real(psb_dpk_), Pointer :: ww(:), q(:),& -!!$ & r(:), p(:), v(:), s(:), z(:), f(:), rt(:),qt(:),uv(:) -!!$ integer(psb_ipk_) :: itmax_, naux, mglob, it, itrace_,int_err(5),& -!!$ & np,me, n_row, n_col,istop_, err_act -!!$ integer(psb_ipk_) :: itx, isvch, ictxt -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma -!!$ type(psb_itconv_type) :: stopdat -!!$ real(psb_dpk_) :: derr -!!$ character(len=20) :: name -!!$ character(len=*), parameter :: methdname='CGS' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_dcgs' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ ictxt = desc_a%get_context() -!!$ Call psb_info(ictxt, me, np) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ If (Present(istop)) Then -!!$ istop_ = istop -!!$ Else -!!$ istop_ = 2 -!!$ Endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,ione),ione,ione,desc_a,info) -!!$ if (info == psb_success_) call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X/B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ naux=4*n_col -!!$ Allocate(aux(naux),stat=info) -!!$ if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=11) -!!$ if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info) -!!$ if (info /= psb_success_) Then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ q => wwrk(:,1) -!!$ qt => wwrk(:,2) -!!$ r => wwrk(:,3) -!!$ rt => wwrk(:,4) -!!$ p => wwrk(:,5) -!!$ v => wwrk(:,6) -!!$ uv => wwrk(:,7) -!!$ z => wwrk(:,8) -!!$ f => wwrk(:,9) -!!$ s => wwrk(:,10) -!!$ ww => wwrk(:,11) -!!$ -!!$ -!!$ If (Present(itmax)) Then -!!$ itmax_ = itmax -!!$ Else -!!$ itmax_ = 1000 -!!$ Endif -!!$ -!!$ If (Present(itrace)) Then -!!$ itrace_ = itrace -!!$ Else -!!$ itrace_ = 0 -!!$ End If -!!$ -!!$ -!!$ itx = 0 -!!$ -!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ restart: Do -!!$! = -!!$! = r0 = b-ax0 -!!$! = -!!$ if (itx >= itmax_) exit restart -!!$ it = 0 -!!$ call psb_geaxpby(done,b,dzero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux) -!!$ if (info == psb_success_) call psb_geaxpby(done,r,dzero,rt,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ ! Perhaps we already satisfy the convergence criterion... -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ rho = dzero -!!$ -!!$ iteration: do -!!$ it = it + 1 -!!$ itx = itx + 1 -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),'iteration: ',itx -!!$ -!!$ rho_old = rho -!!$ rho = psb_gedot(rt,r,desc_a,info) -!!$ -!!$ if (rho == dzero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' iteration breakdown r',rho -!!$ exit iteration -!!$ endif -!!$ -!!$ if (it == 1) then -!!$ call psb_geaxpby(done,r,dzero,uv,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(done,r,dzero,p,desc_a,info) -!!$ else -!!$ beta = (rho/rho_old) -!!$ call psb_geaxpby(done,r,dzero,uv,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(beta,q,done,uv,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(done,q,beta,p,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(done,uv,beta,p,desc_a,info) -!!$ end if -!!$ -!!$ if (info == psb_success_) call prec%apply(p,f,desc_a,info,work=aux) -!!$ -!!$ if (info == psb_success_) call psb_spmm(done,a,f,dzero,v,desc_a,info,& -!!$ & work=aux) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='First loop part ') -!!$ goto 9999 -!!$ end if -!!$ -!!$ sigma = psb_gedot(rt,v,desc_a,info) -!!$ if (sigma == dzero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' iteration breakdown s1', sigma -!!$ exit iteration -!!$ endif -!!$ -!!$ alpha = rho/sigma -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(done,uv,dzero,q,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(-alpha,v,done,q,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(done,uv,dzero,s,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(done,q,done,s,desc_a,info) -!!$ -!!$ if (info == psb_success_) call prec%apply(s,z,desc_a,info,work=aux) -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(alpha,z,done,x,desc_a,info) -!!$ -!!$ if (info == psb_success_) call psb_spmm(done,a,z,dzero,qt,desc_a,info,& -!!$ & work=aux) -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(-alpha,qt,done,r,desc_a,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='X update ') -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ end do iteration -!!$ end do restart -!!$ -!!$ -!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ deallocate(aux,stat=info) -!!$ if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$end subroutine psb_dcgs - Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,istop) use psb_base_mod diff --git a/krylov/psb_dcgstab.f90 b/krylov/psb_dcgstab.f90 index 4ce62d74..132f2e19 100644 --- a/krylov/psb_dcgstab.f90 +++ b/krylov/psb_dcgstab.f90 @@ -93,263 +93,6 @@ ! where r is the (preconditioned, recursive ! estimate of) residual. ! -!!$subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_d_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ Implicit None -!!$! = parameters -!!$ Type(psb_dspmat_type), Intent(in) :: a -!!$ class(psb_dprec_type), Intent(in) :: prec -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ real(psb_dpk_), Intent(in) :: b(:) -!!$ real(psb_dpk_), Intent(inout) :: x(:) -!!$ Real(psb_dpk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_dpk_), Optional, Intent(out) :: err -!!$! = Local data -!!$ real(psb_dpk_), allocatable, target :: aux(:),wwrk(:,:) -!!$ real(psb_dpk_), Pointer :: q(:),& -!!$ & r(:), p(:), v(:), s(:), t(:), z(:), f(:) -!!$ integer(psb_ipk_) :: itmax_, naux, mglob, it,itrace_,& -!!$ & np,me, n_row, n_col -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ integer(psb_ipk_) :: itx, isvch, ictxt, err_act -!!$ integer(psb_ipk_) :: istop_ -!!$ real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma, omega, tau -!!$ type(psb_itconv_type) :: stopdat -!!$ real(psb_dpk_) :: derr -!!$ character(len=20) :: name -!!$ character(len=*), parameter :: methdname='BiCGStab' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_dcgstab' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ ictxt = desc_a%get_context() -!!$ call psb_info(ictxt, me, np) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ If (Present(istop)) Then -!!$ istop_ = istop -!!$ Else -!!$ istop_ = 2 -!!$ Endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X') -!!$ goto 9999 -!!$ end if -!!$ call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ naux=6*n_col -!!$ allocate(aux(naux),stat=info) -!!$ if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=8) -!!$ if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ Q => WWRK(:,1) -!!$ R => WWRK(:,2) -!!$ P => WWRK(:,3) -!!$ V => WWRK(:,4) -!!$ F => WWRK(:,5) -!!$ S => WWRK(:,6) -!!$ T => WWRK(:,7) -!!$ Z => WWRK(:,8) -!!$ -!!$ if (present(itmax)) then -!!$ itmax_ = itmax -!!$ else -!!$ itmax_ = 1000 -!!$ endif -!!$ -!!$ if (present(itrace)) then -!!$ itrace_ = itrace -!!$ else -!!$ itrace_ = 0 -!!$ end if -!!$ -!!$ itx = 0 -!!$ -!!$ -!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ -!!$ restart: Do -!!$! = -!!$! = r0 = b-Ax0 -!!$! = -!!$ if (itx >= itmax_) exit restart -!!$ it = 0 -!!$ call psb_geaxpby(done,b,dzero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux) -!!$ if (info == psb_success_) call psb_geaxpby(done,r,dzero,q,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ rho = dzero -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' On entry to AMAX: B: ',Size(b) -!!$ -!!$ -!!$ ! Perhaps we already satisfy the convergence criterion... -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ iteration: Do -!!$ it = it + 1 -!!$ itx = itx + 1 -!!$ If (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Iteration: ',itx -!!$ -!!$ rho_old = rho -!!$ rho = psb_gedot(q,r,desc_a,info) -!!$ -!!$ if (rho == dzero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Iteration breakdown R',rho -!!$ exit iteration -!!$ endif -!!$ -!!$ if (it == 1) then -!!$ call psb_geaxpby(done,r,dzero,p,desc_a,info) -!!$ else -!!$ beta = (rho/rho_old)*(alpha/omega) -!!$ call psb_geaxpby(-omega,v,done,p,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(done,r,beta,p,desc_a,info) -!!$ end if -!!$ -!!$ if (info == psb_success_) call prec%apply(p,f,desc_a,info,work=aux) -!!$ -!!$ if (info == psb_success_) call psb_spmm(done,a,f,dzero,v,desc_a,info,& -!!$ & work=aux) -!!$ -!!$ if (info == psb_success_) sigma = psb_gedot(q,v,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='First step') -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (sigma == dzero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Iteration breakdown S1', sigma -!!$ exit iteration -!!$ endif -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' SIGMA:',sigma -!!$ alpha = rho/sigma -!!$ -!!$ call psb_geaxpby(done,r,dzero,s,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(-alpha,v,done,s,desc_a,info) -!!$ if (info == psb_success_) call prec%apply(s,z,desc_a,info,work=aux) -!!$ if (info == psb_success_) call psb_spmm(done,a,z,dzero,t,desc_a,info,& -!!$ & work=aux) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='Second step ') -!!$ goto 9999 -!!$ end if -!!$ -!!$ sigma = psb_gedot(t,t,desc_a,info) -!!$ if (sigma == dzero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Iteration breakdown S2', sigma -!!$ exit iteration -!!$ endif -!!$ -!!$ tau = psb_gedot(t,s,desc_a,info) -!!$ omega = tau/sigma -!!$ -!!$ if (omega == dzero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Iteration breakdown O',omega -!!$ exit iteration -!!$ endif -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(alpha,f,done,x,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(omega,z,done,x,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(done,s,dzero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(-omega,t,done,r,desc_a,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='X update ') -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ end do iteration -!!$ end do restart -!!$ -!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ deallocate(aux,stat=info) -!!$ if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error(ictxt) -!!$ return -!!$ end if -!!$ return -!!$ -!!$End Subroutine psb_dcgstab - - Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) use psb_base_mod use psb_prec_mod diff --git a/krylov/psb_dcgstabl.f90 b/krylov/psb_dcgstabl.f90 index 7933e36b..829b27ed 100644 --- a/krylov/psb_dcgstabl.f90 +++ b/krylov/psb_dcgstabl.f90 @@ -103,311 +103,6 @@ ! ! ! -!!$Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_d_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ implicit none -!!$ -!!$! = parameters -!!$ Type(psb_dspmat_type), Intent(in) :: a -!!$ class(psb_dprec_type), Intent(in) :: prec -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ real(psb_dpk_), Intent(in) :: b(:) -!!$ real(psb_dpk_), Intent(inout) :: x(:) -!!$ Real(psb_dpk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_dpk_), Optional, Intent(out) :: err -!!$! = local data -!!$ real(psb_dpk_), allocatable, target :: aux(:),wwrk(:,:),uh(:,:), rh(:,:) -!!$ real(psb_dpk_), Pointer :: ww(:), q(:), r(:), rt0(:), p(:), v(:), & -!!$ & s(:), t(:), z(:), f(:), gamma(:), gamma1(:), gamma2(:), taum(:,:), sigma(:) -!!$ -!!$ integer(psb_ipk_) :: itmax_, naux, mglob, it, itrace_,& -!!$ & np,me, n_row, n_col, nl, err_act -!!$ Logical, Parameter :: exchange=.True., noexchange=.False. -!!$ integer(psb_ipk_), Parameter :: irmax = 8 -!!$ integer(psb_ipk_) :: itx, i, isvch, ictxt,istop_,j, int_err(5) -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ real(psb_dpk_) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,& -!!$ & omega -!!$ type(psb_itconv_type) :: stopdat -!!$ real(psb_dpk_) :: derr -!!$ character(len=20) :: name -!!$ character(len=*), parameter :: methdname='BiCGStab(L)' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_dcgstabl' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ ictxt = desc_a%get_context() -!!$ Call psb_info(ictxt, me, np) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np -!!$ -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ if (present(istop)) then -!!$ istop_ = istop -!!$ else -!!$ istop_ = 2 -!!$ endif -!!$ -!!$ if (present(itmax)) then -!!$ itmax_ = itmax -!!$ else -!!$ itmax_ = 1000 -!!$ endif -!!$ -!!$ if (present(itrace)) then -!!$ itrace_ = itrace -!!$ else -!!$ itrace_ = 0 -!!$ end if -!!$ -!!$ if (present(irst)) then -!!$ nl = irst -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & 'present: irst: ',irst,nl -!!$ else -!!$ nl = 1 -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' not present: irst: ',irst,nl -!!$ endif -!!$ if (nl <=0 ) then -!!$ info=psb_err_invalid_istop_ -!!$ int_err(1)=nl -!!$ err=info -!!$ call psb_errpush(info,name,i_err=int_err) -!!$ goto 9999 -!!$ endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,ione),ione,ione,desc_a,info) -!!$ if (info == psb_success_) call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X/B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ naux=4*n_col -!!$ allocate(aux(naux),gamma(0:nl),gamma1(nl),& -!!$ &gamma2(nl),taum(nl,nl),sigma(nl), stat=info) -!!$ -!!$ if (info /= psb_success_) then -!!$ info=psb_err_alloc_dealloc_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=psb_err_iarg_neg_) -!!$ if (info == psb_success_) Call psb_geall(uh,desc_a,info,n=nl+1,lb=0) -!!$ if (info == psb_success_) Call psb_geall(rh,desc_a,info,n=nl+1,lb=0) -!!$ if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(uh,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(rh,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ q => wwrk(:,1) -!!$ r => wwrk(:,2) -!!$ p => wwrk(:,3) -!!$ v => wwrk(:,4) -!!$ f => wwrk(:,5) -!!$ s => wwrk(:,6) -!!$ t => wwrk(:,7) -!!$ z => wwrk(:,8) -!!$ ww => wwrk(:,9) -!!$ rt0 => wwrk(:,10) -!!$ -!!$ -!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ itx = 0 -!!$ restart: do -!!$! = -!!$! = r0 = b-ax0 -!!$! = -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),' restart: ',itx,it -!!$ if (itx >= itmax_) exit restart -!!$ -!!$ it = 0 -!!$ call psb_geaxpby(done,b,dzero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux) -!!$ -!!$ if (info == psb_success_) call prec%apply(r,desc_a,info) -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(done,r,dzero,rt0,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(done,r,dzero,rh(:,0),desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(dzero,r,dzero,uh(:,0),desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ rho = done -!!$ alpha = dzero -!!$ omega = done -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' on entry to amax: b: ',Size(b) -!!$ -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ iteration: do -!!$ it = it + nl -!!$ itx = itx + nl -!!$ rho = -omega*rho -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' iteration: ',itx, rho,rh(1,0) -!!$ -!!$ do j = 0, nl -1 -!!$ If (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),'bicg part: ',j, nl -!!$ -!!$ rho_old = rho -!!$ rho = psb_gedot(rh(:,j),rt0,desc_a,info) -!!$ if (rho == dzero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' bi-cgstab iteration breakdown r',rho -!!$ exit iteration -!!$ endif -!!$ -!!$ beta = alpha*rho/rho_old -!!$ rho_old = rho -!!$ call psb_geaxpby(done,rh(:,0:j),-beta,uh(:,0:j),desc_a,info) -!!$ call psb_spmm(done,a,uh(:,j),dzero,uh(:,j+1),desc_a,info,work=aux) -!!$ -!!$ call prec%apply(uh(:,j+1),desc_a,info) -!!$ -!!$ gamma(j) = psb_gedot(uh(:,j+1),rt0,desc_a,info) -!!$ -!!$ if (gamma(j) == dzero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' bi-cgstab iteration breakdown s2',gamma(j) -!!$ exit iteration -!!$ endif -!!$ alpha = rho/gamma(j) -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' bicg part: alpha=r/g ',alpha,rho,gamma(j) -!!$ -!!$ call psb_geaxpby(-alpha,uh(:,1:j+1),done,rh(:,0:j),desc_a,info) -!!$ call psb_geaxpby(alpha,uh(:,0),done,x,desc_a,info) -!!$ call psb_spmm(done,a,rh(:,j),dzero,rh(:,j+1),desc_a,info,work=aux) -!!$ -!!$ call prec%apply(rh(:,j+1),desc_a,info) -!!$ -!!$ enddo -!!$ -!!$ do j=1, nl -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' mod g-s part: ',j, nl,rh(1,0) -!!$ -!!$ do i=1, j-1 -!!$ taum(i,j) = psb_gedot(rh(:,i),rh(:,j),desc_a,info) -!!$ taum(i,j) = taum(i,j)/sigma(i) -!!$ call psb_geaxpby(-taum(i,j),rh(:,i),done,rh(:,j),desc_a,info) -!!$ enddo -!!$ sigma(j) = psb_gedot(rh(:,j),rh(:,j),desc_a,info) -!!$ gamma1(j) = psb_gedot(rh(:,0),rh(:,j),desc_a,info) -!!$ gamma1(j) = gamma1(j)/sigma(j) -!!$ enddo -!!$ -!!$ gamma(nl) = gamma1(nl) -!!$ omega = gamma(nl) -!!$ -!!$ do j=nl-1,1,-1 -!!$ gamma(j) = gamma1(j) -!!$ do i=j+1,nl -!!$ gamma(j) = gamma(j) - taum(j,i) * gamma(i) -!!$ enddo -!!$ enddo -!!$ -!!$ do j=1,nl-1 -!!$ gamma2(j) = gamma(j+1) -!!$ do i=j+1,nl-1 -!!$ gamma2(j) = gamma2(j) + taum(j,i) * gamma(i+1) -!!$ enddo -!!$ enddo -!!$ -!!$ call psb_geaxpby(gamma(1),rh(:,0),done,x,desc_a,info) -!!$ call psb_geaxpby(-gamma1(nl),rh(:,nl),done,rh(:,0),desc_a,info) -!!$ call psb_geaxpby(-gamma(nl),uh(:,nl),done,uh(:,0),desc_a,info) -!!$ -!!$ do j=1, nl-1 -!!$ call psb_geaxpby(-gamma(j),uh(:,j),done,uh(:,0),desc_a,info) -!!$ call psb_geaxpby(gamma2(j),rh(:,j),done,x,desc_a,info) -!!$ call psb_geaxpby(-gamma1(j),rh(:,j),done,rh(:,0),desc_a,info) -!!$ enddo -!!$ -!!$ if (psb_check_conv(methdname,itx,x,rh(:,0),desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ end do iteration -!!$ end do restart -!!$ -!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ deallocate(aux,stat=info) -!!$ if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) -!!$ if (info == psb_success_) call psb_gefree(uh,desc_a,info) -!!$ if (info == psb_success_) call psb_gefree(rh,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$End Subroutine psb_dcgstabl -!!$ - - Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,irst,istop) use psb_base_mod diff --git a/krylov/psb_dkrylov.f90 b/krylov/psb_dkrylov.f90 index eaae5d4c..10777a2d 100644 --- a/krylov/psb_dkrylov.f90 +++ b/krylov/psb_dkrylov.f90 @@ -33,217 +33,51 @@ ! File: psb_krylov_mod.f90 ! Interfaces for Krylov subspace iterative methods. ! - - ! - ! Subroutine: psb_dkrylov - ! - ! Front-end for the Krylov subspace iterations, realversion - ! - ! Arguments: - ! - ! methd - character The specific method; can take the values: - ! CG - ! CGS - ! BICG - ! BICGSTAB - ! BICGSTABL - ! RGMRES - ! - ! a - type(psb_dspmat_type) Input: sparse matrix containing A. - ! prec - class(psb_dprec_type) Input: preconditioner - ! b - real,dimension(:) Input: vector containing the - ! right hand side B - ! x - real,dimension(:) Input/Output: vector containing the - ! initial guess and final solution X. - ! eps - real Input: Stopping tolerance; the iteration is - ! stopped when the error - ! estimate |err| <= eps - ! - ! desc_a - type(psb_desc_type). Input: The communication descriptor. - ! info - integer. Output: Return code - ! - ! itmax - integer(optional) Input: maximum number of iterations to be - ! performed. - ! iter - integer(optional) Output: how many iterations have been - ! performed. - ! err - real (optional) Output: error estimate on exit - ! itrace - integer(optional) Input: print an informational message - ! with the error estimate every itrace - ! iterations - ! irst - integer(optional) Input: restart parameter for RGMRES and - ! BICGSTAB(L) methods - ! istop - integer(optional) Input: stopping criterion, or how - ! to estimate the error. - ! 1: err = |r|/(|a||x|+|b|) - ! 2: err = |r|/|b| - ! where r is the (preconditioned, recursive - ! estimate of) residual - ! -!!$Subroutine psb_dkrylov(method,a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod,only : psb_sprec_type, psb_dprec_type, psb_dprec_type, psb_zprec_type -!!$ use psb_krylov_mod, psb_protect_name => psb_dkrylov -!!$ character(len=*) :: method -!!$ Type(psb_dspmat_type), Intent(in) :: a -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ class(psb_dprec_type), intent(in) :: prec -!!$ real(psb_dpk_), Intent(in) :: b(:) -!!$ real(psb_dpk_), Intent(inout) :: x(:) -!!$ Real(psb_dpk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_dpk_), Optional, Intent(out) :: err -!!$ interface -!!$ subroutine psb_dcg(a,prec,b,x,eps,& -!!$ & desc_a,info,itmax,iter,err,itrace,istop) -!!$ import :: psb_ipk_, psb_dpk_, psb_desc_type, & -!!$ & psb_dspmat_type, psb_dprec_type -!!$ type(psb_dspmat_type), intent(in) :: a -!!$ type(psb_desc_type), intent(in) :: desc_a -!!$ real(psb_dpk_), intent(in) :: b(:) -!!$ real(psb_dpk_), intent(inout) :: x(:) -!!$ real(psb_dpk_), intent(in) :: eps -!!$ class(psb_dprec_type), intent(in) :: prec -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), optional, intent(in) :: itmax, itrace,istop -!!$ integer(psb_ipk_), optional, intent(out) :: iter -!!$ real(psb_dpk_), optional, intent(out) :: err -!!$ end subroutine psb_dcg -!!$ subroutine psb_dbicg(a,prec,b,x,eps,& -!!$ & desc_a,info,itmax,iter,err,itrace,istop) -!!$ import :: psb_ipk_, psb_dpk_, psb_desc_type, & -!!$ & psb_dspmat_type, psb_dprec_type -!!$ type(psb_dspmat_type), intent(in) :: a -!!$ type(psb_desc_type), intent(in) :: desc_a -!!$ real(psb_dpk_), intent(in) :: b(:) -!!$ real(psb_dpk_), intent(inout) :: x(:) -!!$ real(psb_dpk_), intent(in) :: eps -!!$ class(psb_dprec_type), intent(in) :: prec -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), optional, intent(in) :: itmax, itrace,istop -!!$ integer(psb_ipk_), optional, intent(out) :: iter -!!$ real(psb_dpk_), optional, intent(out) :: err -!!$ end subroutine psb_dbicg -!!$ subroutine psb_dcgstab(a,prec,b,x,eps,& -!!$ & desc_a,info,itmax,iter,err,itrace,istop) -!!$ import :: psb_ipk_, psb_dpk_, psb_desc_type, & -!!$ & psb_dspmat_type, psb_dprec_type -!!$ type(psb_dspmat_type), intent(in) :: a -!!$ type(psb_desc_type), intent(in) :: desc_a -!!$ real(psb_dpk_), intent(in) :: b(:) -!!$ real(psb_dpk_), intent(inout) :: x(:) -!!$ real(psb_dpk_), intent(in) :: eps -!!$ class(psb_dprec_type), intent(in) :: prec -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), optional, intent(in) :: itmax, itrace,istop -!!$ integer(psb_ipk_), optional, intent(out) :: iter -!!$ real(psb_dpk_), optional, intent(out) :: err -!!$ end subroutine psb_dcgstab -!!$ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,irst,istop) -!!$ import :: psb_ipk_, psb_dpk_, psb_desc_type, & -!!$ & psb_dspmat_type, psb_dprec_type -!!$ Type(psb_dspmat_type), Intent(in) :: a -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ class(psb_dprec_type), intent(in) :: prec -!!$ real(psb_dpk_), Intent(in) :: b(:) -!!$ real(psb_dpk_), Intent(inout) :: x(:) -!!$ Real(psb_dpk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_dpk_), Optional, Intent(out) :: err -!!$ end subroutine psb_dcgstabl -!!$ Subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,irst,istop) -!!$ import :: psb_ipk_, psb_dpk_, psb_desc_type, & -!!$ & psb_dspmat_type, psb_dprec_type -!!$ Type(psb_dspmat_type), Intent(in) :: a -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ class(psb_dprec_type), intent(in) :: prec -!!$ real(psb_dpk_), Intent(in) :: b(:) -!!$ real(psb_dpk_), Intent(inout) :: x(:) -!!$ Real(psb_dpk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_dpk_), Optional, Intent(out) :: err -!!$ end subroutine psb_drgmres -!!$ subroutine psb_dcgs(a,prec,b,x,eps,& -!!$ & desc_a,info,itmax,iter,err,itrace,istop) -!!$ import :: psb_ipk_, psb_dpk_, psb_desc_type, & -!!$ & psb_dspmat_type, psb_dprec_type -!!$ type(psb_dspmat_type), intent(in) :: a -!!$ type(psb_desc_type), intent(in) :: desc_a -!!$ real(psb_dpk_), intent(in) :: b(:) -!!$ real(psb_dpk_), intent(inout) :: x(:) -!!$ real(psb_dpk_), intent(in) :: eps -!!$ class(psb_dprec_type), intent(in) :: prec -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), optional, intent(in) :: itmax, itrace,istop -!!$ integer(psb_ipk_), optional, intent(out) :: iter -!!$ real(psb_dpk_), optional, intent(out) :: err -!!$ end subroutine psb_dcgs -!!$ end interface -!!$ -!!$ -!!$ integer(psb_ipk_) :: ictxt,me,np,err_act -!!$ character(len=20) :: name -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_krylov' -!!$ call psb_erractionsave(err_act) -!!$ -!!$ -!!$ ictxt=desc_a%get_context() -!!$ -!!$ call psb_info(ictxt, me, np) -!!$ -!!$ -!!$ select case(psb_toupper(method)) -!!$ case('CG') -!!$ call psb_dcg(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,istop) -!!$ case('CGS') -!!$ call psb_dcgs(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,istop) -!!$ case('BICG') -!!$ call psb_dbicg(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,istop) -!!$ case('BICGSTAB') -!!$ call psb_dcgstab(a,prec,b,x,eps,desc_a,info,& -!!$ & itmax,iter,err,itrace,istop) -!!$ case('RGMRES') -!!$ call psb_drgmres(a,prec,b,x,eps,desc_a,info,& -!!$ & itmax,iter,err,itrace,irst,istop) -!!$ case('BICGSTABL') -!!$ call psb_dcgstabl(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,irst,istop) -!!$ case default -!!$ if (me == 0) write(psb_err_unit,*) trim(name),': Warning: Unknown method ',method,& -!!$ & ', defaulting to BiCGSTAB' -!!$ call psb_dcgstab(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,istop) -!!$ end select -!!$ -!!$ if(info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error(ictxt) -!!$ return -!!$ end if -!!$ -!!$end subroutine psb_dkrylov - +! +! Subroutine: psb_dkrylov +! +! Front-end for the Krylov subspace iterations, realversion +! +! Arguments: +! +! methd - character The specific method; can take the values: +! CG +! CGS +! BICG +! BICGSTAB +! BICGSTABL +! RGMRES +! +! a - type(psb_dspmat_type) Input: sparse matrix containing A. +! prec - class(psb_dprec_type) Input: preconditioner +! b - real,dimension(:) Input: vector containing the +! right hand side B +! x - real,dimension(:) Input/Output: vector containing the +! initial guess and final solution X. +! eps - real Input: Stopping tolerance; the iteration is +! stopped when the error +! estimate |err| <= eps +! +! desc_a - type(psb_desc_type). Input: The communication descriptor. +! info - integer. Output: Return code +! +! itmax - integer(optional) Input: maximum number of iterations to be +! performed. +! iter - integer(optional) Output: how many iterations have been +! performed. +! err - real (optional) Output: error estimate on exit +! itrace - integer(optional) Input: print an informational message +! with the error estimate every itrace +! iterations +! irst - integer(optional) Input: restart parameter for RGMRES and +! BICGSTAB(L) methods +! istop - integer(optional) Input: stopping criterion, or how +! to estimate the error. +! 1: err = |r|/(|a||x|+|b|) +! 2: err = |r|/|b| +! where r is the (preconditioned, recursive +! estimate of) residual +! Subroutine psb_dkrylov_vect(method,a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,irst,istop,cond) diff --git a/krylov/psb_drgmres.f90 b/krylov/psb_drgmres.f90 index 8bf4701a..2d4d65d9 100644 --- a/krylov/psb_drgmres.f90 +++ b/krylov/psb_drgmres.f90 @@ -105,369 +105,6 @@ ! estimate of) residual. ! irst - integer(optional) Input: restart parameter ! -!!$Subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_d_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ implicit none -!!$ -!!$! = Parameters -!!$ Type(psb_dspmat_type), Intent(in) :: a -!!$ class(psb_dprec_type), Intent(in) :: prec -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ real(psb_dpk_), Intent(in) :: b(:) -!!$ real(psb_dpk_), Intent(inout) :: x(:) -!!$ Real(psb_dpk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_dpk_), Optional, Intent(out) :: err -!!$! = local data -!!$ real(psb_dpk_), allocatable, target :: aux(:),w(:),w1(:), v(:,:) -!!$ real(psb_dpk_), allocatable :: c(:),s(:), h(:,:), rs(:),rst(:),xt(:) -!!$ Real(psb_dpk_) :: tmp -!!$ real(psb_dpk_) :: rti, rti1, scal -!!$ integer(psb_ipk_) ::litmax, naux, mglob, it,k, itrace_,& -!!$ & np,me, n_row, n_col, nl, int_err(5) -!!$ Logical, Parameter :: exchange=.True., noexchange=.False. -!!$ integer(psb_ipk_), Parameter :: irmax = 8 -!!$ integer(psb_ipk_) :: itx, i, isvch, ictxt,istop_, err_act -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ Real(psb_dpk_) :: rni, xni, bni, ani,bn2 -!!$ real(psb_dpk_) :: errnum, errden, deps, derr -!!$ character(len=20) :: name -!!$ character(len=*), parameter :: methdname='RGMRES' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_dgmres' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ ictxt = desc_a%get_context() -!!$ Call psb_info(ictxt, me, np) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ if (present(istop)) then -!!$ istop_ = istop -!!$ else -!!$ istop_ = 2 -!!$ endif -!!$ ! -!!$ ! ISTOP_ = 1: Normwise backward error, infinity norm -!!$ ! ISTOP_ = 2: ||r||/||b||, 2-norm -!!$ ! -!!$ -!!$ if ((istop_ < 1 ).or.(istop_ > 2 ) ) then -!!$ info=psb_err_invalid_istop_ -!!$ int_err(1)=istop_ -!!$ err=info -!!$ call psb_errpush(info,name,i_err=int_err) -!!$ goto 9999 -!!$ endif -!!$ -!!$ if (present(itmax)) then -!!$ litmax = itmax -!!$ else -!!$ litmax = 1000 -!!$ endif -!!$ -!!$ if (present(itrace)) then -!!$ itrace_ = itrace -!!$ else -!!$ itrace_ = 0 -!!$ end if -!!$ -!!$ if (present(irst)) then -!!$ nl = irst -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' present: irst: ',irst,nl -!!$ else -!!$ nl = 10 -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' not present: irst: ',irst,nl -!!$ endif -!!$ if (nl <=0 ) then -!!$ info=psb_err_invalid_istop_ -!!$ int_err(1)=nl -!!$ err=info -!!$ call psb_errpush(info,name,i_err=int_err) -!!$ goto 9999 -!!$ endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,1),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X') -!!$ goto 9999 -!!$ end if -!!$ call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ naux=4*n_col -!!$ allocate(aux(naux),h(nl+1,nl+1),& -!!$ &c(nl+1),s(nl+1),rs(nl+1), rst(nl+1),stat=info) -!!$ -!!$ if (info == psb_success_) Call psb_geall(v,desc_a,info,n=nl+1) -!!$ if (info == psb_success_) Call psb_geall(w,desc_a,info) -!!$ if (info == psb_success_) Call psb_geall(w1,desc_a,info) -!!$ if (info == psb_success_) Call psb_geall(xt,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(v,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(w,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(w1,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(xt,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Size of V,W,W1 ',size(v),size(v,1),& -!!$ & size(w),size(w,1),size(w1),size(w1,1), size(v(:,1)) -!!$ -!!$ -!!$ if (istop_ == 1) then -!!$ ani = psb_spnrmi(a,desc_a,info) -!!$ bni = psb_geamax(b,desc_a,info) -!!$ else if (istop_ == 2) then -!!$ bn2 = psb_genrm2(b,desc_a,info) -!!$ endif -!!$ errnum = dzero -!!$ errden = done -!!$ deps = eps -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ if ((itrace_ > 0).and.(me == 0)) call log_header(methdname) -!!$ -!!$ itx = 0 -!!$ restart: do -!!$ -!!$ ! compute r0 = b-ax0 -!!$ ! check convergence -!!$ ! compute v1 = r0/||r0||_2 -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' restart: ',itx,it -!!$ it = 0 -!!$ call psb_geaxpby(done,b,dzero,v(:,1),desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_spmm(-done,a,x,done,v(:,1),desc_a,info,work=aux) -!!$ if (info /= psb_success_) Then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ rs(1) = psb_genrm2(v(:,1),desc_a,info) -!!$ rs(2:) = dzero -!!$ if (info /= psb_success_) Then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ scal=done/rs(1) ! rs(1) MIGHT BE VERY SMALL - USE DSCAL TO DEAL WITH IT? -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' on entry to amax: b: ',Size(b),rs(1),scal -!!$ -!!$ ! -!!$ ! check convergence -!!$ ! -!!$ if (istop_ == 1) then -!!$ rni = psb_geamax(v(:,1),desc_a,info) -!!$ xni = psb_geamax(x,desc_a,info) -!!$ errnum = rni -!!$ errden = (ani*xni+bni) -!!$ else if (istop_ == 2) then -!!$ rni = psb_genrm2(v(:,1),desc_a,info) -!!$ errnum = rni -!!$ errden = bn2 -!!$ endif -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (errnum <= deps*errden) exit restart -!!$ -!!$ if (itrace_ > 0) & -!!$ & call log_conv(methdname,me,itx,itrace_,errnum,errden,deps) -!!$ -!!$ v(:,1) = v(:,1) * scal -!!$ -!!$ if (itx >= litmax) exit restart -!!$ -!!$ ! -!!$ ! inner iterations -!!$ ! -!!$ -!!$ inner: Do i=1,nl -!!$ itx = itx + 1 -!!$ -!!$ call prec%apply(v(:,i),w1,desc_a,info) -!!$ Call psb_spmm(done,a,w1,dzero,w,desc_a,info,work=aux) -!!$ ! -!!$ -!!$ do k = 1, i -!!$ h(k,i) = psb_gedot(v(:,k),w,desc_a,info) -!!$ call psb_geaxpby(-h(k,i),v(:,k),done,w,desc_a,info) -!!$ end do -!!$ h(i+1,i) = psb_genrm2(w,desc_a,info) -!!$ scal=done/h(i+1,i) -!!$ call psb_geaxpby(scal,w,dzero,v(:,i+1),desc_a,info) -!!$ do k=2,i -!!$ call drot(1,h(k-1,i),1,h(k,i),1,real(c(k-1)),s(k-1)) -!!$ enddo -!!$ -!!$ rti = h(i,i) -!!$ rti1 = h(i+1,i) -!!$ call drotg(rti,rti1,tmp,s(i)) -!!$ c(i) = cmplx(tmp,szero) -!!$ call drot(1,h(i,i),1,h(i+1,i),1,real(c(i)),s(i)) -!!$ h(i+1,i) = dzero -!!$ call drot(1,rs(i),1,rs(i+1),1,real(c(i)),s(i)) -!!$ -!!$ if (istop_ == 1) then -!!$ ! -!!$ ! build x and then compute the residual and its infinity norm -!!$ ! -!!$ rst = rs -!!$ xt = dzero -!!$ call dtrsm('l','u','n','n',i,1,done,h,size(h,1),rst,size(rst,1)) -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Rebuild x-> RS:',rst(1:nl) -!!$ do k=1, i -!!$ call psb_geaxpby(rst(k),v(:,k),done,xt,desc_a,info) -!!$ end do -!!$ call prec%apply(xt,desc_a,info) -!!$ call psb_geaxpby(done,x,done,xt,desc_a,info) -!!$ call psb_geaxpby(done,b,dzero,w1,desc_a,info) -!!$ call psb_spmm(-done,a,xt,done,w1,desc_a,info,work=aux) -!!$ rni = psb_geamax(w1,desc_a,info) -!!$ xni = psb_geamax(xt,desc_a,info) -!!$ errnum = rni -!!$ errden = (ani*xni+bni) -!!$ ! -!!$ -!!$ else if (istop_ == 2) then -!!$ ! -!!$ ! compute the residual 2-norm as byproduct of the solution -!!$ ! procedure of the least-squares problem -!!$ ! -!!$ rni = abs(rs(i+1)) -!!$ errnum = rni -!!$ errden = bn2 -!!$ endif -!!$ -!!$ If (errnum <= deps*errden) Then -!!$ -!!$ if (istop_ == 1) then -!!$ x = xt -!!$ else if (istop_ == 2) then -!!$ ! -!!$ ! build x -!!$ ! -!!$ call dtrsm('l','u','n','n',i,1,done,h,size(h,1),rs,size(rs,1)) -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Rebuild x-> RS:',rs(1:nl) -!!$ w1 = dzero -!!$ do k=1, i -!!$ call psb_geaxpby(rs(k),v(:,k),done,w1,desc_a,info) -!!$ end do -!!$ call prec%apply(w1,w,desc_a,info) -!!$ call psb_geaxpby(done,w,done,x,desc_a,info) -!!$ end if -!!$ -!!$ exit restart -!!$ -!!$ end if -!!$ -!!$ if (itrace_ > 0) & -!!$ & call log_conv(methdname,me,itx,itrace_,errnum,errden,deps) -!!$ -!!$ end do inner -!!$ -!!$ if (istop_ == 1) then -!!$ x = xt -!!$ else if (istop_ == 2) then -!!$ ! -!!$ ! build x -!!$ ! -!!$ call dtrsm('l','u','n','n',nl,1,done,h,size(h,1),rs,size(rs,1)) -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Rebuild x-> RS:',rs(1:nl) -!!$ w1 = dzero -!!$ do k=1, nl -!!$ call psb_geaxpby(rs(k),v(:,k),done,w1,desc_a,info) -!!$ end do -!!$ call prec%apply(w1,w,desc_a,info) -!!$ call psb_geaxpby(done,w,done,x,desc_a,info) -!!$ end if -!!$ -!!$ end do restart -!!$ if (itrace_ > 0) & -!!$ & call log_conv(methdname,me,itx,ione,errnum,errden,deps) -!!$ -!!$ call log_end(methdname,me,itx,errnum,errden,deps,err=derr,iter=iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ -!!$ deallocate(aux,h,c,s,rs,rst, stat=info) -!!$ if (info == psb_success_) call psb_gefree(v,desc_a,info) -!!$ if (info == psb_success_) call psb_gefree(w,desc_a,info) -!!$ if (info == psb_success_) call psb_gefree(w1,desc_a,info) -!!$ if (info == psb_success_) call psb_gefree(xt,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$End Subroutine psb_drgmres - - subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,irst,istop) @@ -738,7 +375,7 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,& call dtrsm('l','u','n','n',i,1,done,h,size(h,1),rst,size(rst,1)) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& - & ' Rebuild x-> RS:',rst(1:nl) + & ' Rebuild x-> RS:',rst(1:i) do k=1, i call psb_geaxpby(rst(k),v(k),done,xt,desc_a,info) end do @@ -774,7 +411,7 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,& call dtrsm('l','u','n','n',i,1,done,h,size(h,1),rs,size(rs,1)) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& - & ' Rebuild x-> RS:',rs(1:nl) + & ' Rebuild x-> RS:',rs(1:i) call w1%set(dzero) do k=1, i call psb_geaxpby(rs(k),v(k),done,w1,desc_a,info) diff --git a/krylov/psb_sbicg.f90 b/krylov/psb_sbicg.f90 index f4c95b2f..d5ceb340 100644 --- a/krylov/psb_sbicg.f90 +++ b/krylov/psb_sbicg.f90 @@ -93,243 +93,6 @@ ! estimate of) residual. ! ! -!!$subroutine psb_sbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_s_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ implicit none -!!$ -!!$! !$ parameters -!!$ type(psb_sspmat_type), intent(in) :: a -!!$ class(psb_sprec_type), intent(in) :: prec -!!$ type(psb_desc_type), intent(in) :: desc_a -!!$ real(psb_spk_), intent(in) :: b(:) -!!$ real(psb_spk_), intent(inout) :: x(:) -!!$ real(psb_spk_), intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), optional, intent(in) :: itmax, itrace, istop -!!$ integer(psb_ipk_), optional, intent(out) :: iter -!!$ real(psb_spk_), optional, intent(out) :: err -!!$! !$ local data -!!$ real(psb_spk_), allocatable, target :: aux(:),wwrk(:,:) -!!$ real(psb_spk_), pointer :: ww(:), q(:),& -!!$ & r(:), p(:), zt(:), pt(:), z(:), rt(:),qt(:) -!!$ integer(psb_ipk_) :: int_err(5) -!!$ integer(psb_ipk_) ::itmax_, naux, mglob, it, itrace_,& -!!$ & np,me, n_row, n_col, istop_, err_act -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ logical, parameter :: exchange=.true., noexchange=.false. -!!$ integer(psb_ipk_), parameter :: irmax = 8 -!!$ integer(psb_ipk_) :: itx, ictxt -!!$ real(psb_spk_) :: alpha, beta, rho, rho_old, sigma -!!$ type(psb_itconv_type) :: stopdat -!!$ real(psb_dpk_) :: derr -!!$ character(len=20) :: name,ch_err -!!$ character(len=*), parameter :: methdname='BiCG' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_sbicg' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ ictxt = desc_a%get_context() -!!$ call psb_info(ictxt, me, np) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ -!!$ if (present(istop)) then -!!$ istop_ = istop -!!$ else -!!$ istop_ = 2 -!!$ endif -!!$ ! -!!$ ! istop_ = 1: normwise backward error, infinity norm -!!$ ! istop_ = 2: ||r||/||b|| norm 2 -!!$ ! -!!$ -!!$ if ((istop_ < 1 ).or.(istop_ > 2 ) ) then -!!$ info=psb_err_invalid_istop_ -!!$ int_err=istop_ -!!$ err=info -!!$ call psb_errpush(info,name,i_err=int_err) -!!$ goto 9999 -!!$ endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X') -!!$ goto 9999 -!!$ end if -!!$ call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ naux=4*n_col -!!$ -!!$ allocate(aux(naux),stat=info) -!!$ if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=9) -!!$ if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ ch_err='psb_asb' -!!$ err=info -!!$ call psb_errpush(info,name,a_err=ch_err) -!!$ goto 9999 -!!$ end if -!!$ -!!$ q => wwrk(:,1) -!!$ qt => wwrk(:,2) -!!$ r => wwrk(:,3) -!!$ rt => wwrk(:,4) -!!$ p => wwrk(:,5) -!!$ pt => wwrk(:,6) -!!$ z => wwrk(:,7) -!!$ zt => wwrk(:,8) -!!$ ww => wwrk(:,9) -!!$ -!!$ if (present(itmax)) then -!!$ itmax_ = itmax -!!$ else -!!$ itmax_ = 1000 -!!$ endif -!!$ -!!$ if (present(itrace)) then -!!$ itrace_ = itrace -!!$ else -!!$ itrace_ = 0 -!!$ end if -!!$ -!!$ itx = 0 -!!$ -!!$ -!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ restart: do -!!$! !$ -!!$! !$ r0 = b-ax0 -!!$! !$ -!!$ if (itx >= itmax_) exit restart -!!$ it = 0 -!!$ call psb_geaxpby(sone,b,szero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),' sone spmm',info -!!$ if (info == psb_success_) call psb_geaxpby(sone,r,szero,rt,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ rho = szero -!!$ -!!$ ! Perhaps we already satisfy the convergence criterion... -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ iteration: do -!!$ it = it + 1 -!!$ itx = itx + 1 -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),'iteration: ',itx -!!$ -!!$ call prec%apply(r,z,desc_a,info,work=aux) -!!$ if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='c',work=aux) -!!$ -!!$ rho_old = rho -!!$ rho = psb_gedot(rt,z,desc_a,info) -!!$ if (rho == szero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' iteration breakdown r',rho -!!$ exit iteration -!!$ endif -!!$ -!!$ if (it == 1) then -!!$ call psb_geaxpby(sone,z,szero,p,desc_a,info) -!!$ call psb_geaxpby(sone,zt,szero,pt,desc_a,info) -!!$ else -!!$ beta = (rho/rho_old) -!!$ call psb_geaxpby(sone,z,(beta),p,desc_a,info) -!!$ call psb_geaxpby(sone,zt,(beta),pt,desc_a,info) -!!$ end if -!!$ -!!$ call psb_spmm(sone,a,p,szero,q,desc_a,info,& -!!$ & work=aux) -!!$ call psb_spmm(sone,a,pt,szero,qt,desc_a,info,& -!!$ & work=aux,trans='c') -!!$ -!!$ sigma = psb_gedot(pt,q,desc_a,info) -!!$ if (sigma == szero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' iteration breakdown s1', sigma -!!$ exit iteration -!!$ endif -!!$ -!!$ alpha = rho/sigma -!!$ -!!$ -!!$ call psb_geaxpby((alpha),p,sone,x,desc_a,info) -!!$ call psb_geaxpby(-(alpha),q,sone,r,desc_a,info) -!!$ call psb_geaxpby(-(alpha),qt,sone,rt,desc_a,info) -!!$ -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ end do iteration -!!$ end do restart -!!$ -!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ deallocate(aux, stat=info) -!!$ if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$end subroutine psb_sbicg -!!$ - subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,istop) diff --git a/krylov/psb_scg.f90 b/krylov/psb_scg.f90 index 5336ad6a..7c9e5e6f 100644 --- a/krylov/psb_scg.f90 +++ b/krylov/psb_scg.f90 @@ -95,190 +95,6 @@ ! estimate of) residual. ! ! -!!$subroutine psb_scg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_s_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ implicit none -!!$ -!!$! = Parameters -!!$ Type(psb_sspmat_type), Intent(in) :: a -!!$ class(psb_sprec_type), Intent(in) :: prec -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ real(psb_spk_), Intent(in) :: b(:) -!!$ real(psb_spk_), Intent(inout) :: x(:) -!!$ Real(psb_spk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_spk_), Optional, Intent(out) :: err -!!$! = Local data -!!$ real(psb_spk_), allocatable, target :: aux(:), wwrk(:,:) -!!$ real(psb_spk_), pointer :: q(:), p(:), r(:), z(:), w(:) -!!$ real(psb_spk_) :: alpha, beta, rho, rho_old, sigma -!!$ integer(psb_ipk_) :: itmax_, istop_, naux, mglob, it, itx, itrace_,& -!!$ & np,me, n_col, isvch, ictxt, n_row,err_act, int_err(5) -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ type(psb_itconv_type) :: stopdat -!!$ real(psb_dpk_) :: derr -!!$ character(len=20) :: name -!!$ character(len=*), parameter :: methdname='CG' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_scg' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ ictxt = desc_a%get_context() -!!$ -!!$ call psb_info(ictxt, me, np) -!!$ -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ if (present(istop)) then -!!$ istop_ = istop -!!$ else -!!$ istop_ = 2 -!!$ endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,ione),ione,ione,desc_a,info) -!!$ if (info == psb_success_) call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X/B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ naux=4*n_col -!!$ allocate(aux(naux), stat=info) -!!$ if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=psb_err_invalid_input_) -!!$ if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ p => wwrk(:,1) -!!$ q => wwrk(:,2) -!!$ r => wwrk(:,3) -!!$ z => wwrk(:,4) -!!$ w => wwrk(:,5) -!!$ -!!$ -!!$ if (present(itmax)) then -!!$ itmax_ = itmax -!!$ else -!!$ itmax_ = 1000 -!!$ endif -!!$ -!!$ if (present(itrace)) then -!!$ itrace_ = itrace -!!$ else -!!$ itrace_ = 0 -!!$ end if -!!$ -!!$ itx=0 -!!$ -!!$ restart: do -!!$! = -!!$! = r0 = b-Ax0 -!!$! = -!!$ if (itx>= itmax_) exit restart -!!$ -!!$ it = 0 -!!$ call psb_geaxpby(sone,b,szero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ rho = szero -!!$ -!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ iteration: do -!!$ -!!$ it = it + 1 -!!$ itx = itx + 1 -!!$ -!!$ call prec%apply(r,z,desc_a,info,work=aux) -!!$ rho_old = rho -!!$ rho = psb_gedot(r,z,desc_a,info) -!!$ -!!$ if (it == 1) then -!!$ call psb_geaxpby(sone,z,szero,p,desc_a,info) -!!$ else -!!$ if (rho_old == szero) then -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ': CG Iteration breakdown rho' -!!$ exit iteration -!!$ endif -!!$ beta = rho/rho_old -!!$ call psb_geaxpby(sone,z,beta,p,desc_a,info) -!!$ end if -!!$ -!!$ call psb_spmm(sone,a,p,szero,q,desc_a,info,work=aux) -!!$ sigma = psb_gedot(p,q,desc_a,info) -!!$ if (sigma == szero) then -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ': CG Iteration breakdown sigma' -!!$ exit iteration -!!$ endif -!!$ -!!$ alpha = rho/sigma -!!$ call psb_geaxpby(alpha,p,sone,x,desc_a,info) -!!$ call psb_geaxpby(-alpha,q,sone,r,desc_a,info) -!!$ -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ end do iteration -!!$ end do restart -!!$ -!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ call psb_gefree(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$end subroutine psb_scg -!!$ - subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,istop) use psb_base_mod diff --git a/krylov/psb_scgs.f90 b/krylov/psb_scgs.f90 index b17cca39..149e24f0 100644 --- a/krylov/psb_scgs.f90 +++ b/krylov/psb_scgs.f90 @@ -92,238 +92,6 @@ ! where r is the (preconditioned, recursive ! estimate of) residual. ! -!!$Subroutine psb_scgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_s_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ implicit none -!!$ -!!$! = parameters -!!$ Type(psb_sspmat_type), Intent(in) :: a -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ class(psb_sprec_type), Intent(in) :: prec -!!$ real(psb_spk_), Intent(in) :: b(:) -!!$ real(psb_spk_), Intent(inout) :: x(:) -!!$ Real(psb_spk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_spk_), Optional, Intent(out) :: err -!!$! = local data -!!$ real(psb_spk_), allocatable, target :: aux(:),wwrk(:,:) -!!$ real(psb_spk_), Pointer :: ww(:), q(:),& -!!$ & r(:), p(:), v(:), s(:), z(:), f(:), rt(:),qt(:),uv(:) -!!$ integer(psb_ipk_) :: itmax_, naux, mglob, it, itrace_,int_err(5),& -!!$ & np,me, n_row, n_col,istop_, err_act -!!$ integer(psb_ipk_) :: itx, isvch, ictxt -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ real(psb_spk_) :: alpha, beta, rho, rho_old, sigma -!!$ type(psb_itconv_type) :: stopdat -!!$ real(psb_dpk_) :: derr -!!$ character(len=20) :: name -!!$ character(len=*), parameter :: methdname='CGS' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_scgs' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ ictxt = desc_a%get_context() -!!$ Call psb_info(ictxt, me, np) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ If (Present(istop)) Then -!!$ istop_ = istop -!!$ Else -!!$ istop_ = 2 -!!$ Endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,ione),ione,ione,desc_a,info) -!!$ if (info == psb_success_) call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X/B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ naux=4*n_col -!!$ Allocate(aux(naux),stat=info) -!!$ if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=11) -!!$ if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info) -!!$ if (info /= psb_success_) Then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ q => wwrk(:,1) -!!$ qt => wwrk(:,2) -!!$ r => wwrk(:,3) -!!$ rt => wwrk(:,4) -!!$ p => wwrk(:,5) -!!$ v => wwrk(:,6) -!!$ uv => wwrk(:,7) -!!$ z => wwrk(:,8) -!!$ f => wwrk(:,9) -!!$ s => wwrk(:,10) -!!$ ww => wwrk(:,11) -!!$ -!!$ -!!$ If (Present(itmax)) Then -!!$ itmax_ = itmax -!!$ Else -!!$ itmax_ = 1000 -!!$ Endif -!!$ -!!$ If (Present(itrace)) Then -!!$ itrace_ = itrace -!!$ Else -!!$ itrace_ = 0 -!!$ End If -!!$ -!!$ -!!$ itx = 0 -!!$ -!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ restart: Do -!!$! = -!!$! = r0 = b-ax0 -!!$! = -!!$ if (itx >= itmax_) exit restart -!!$ it = 0 -!!$ call psb_geaxpby(sone,b,szero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux) -!!$ if (info == psb_success_) call psb_geaxpby(sone,r,szero,rt,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ ! Perhaps we already satisfy the convergence criterion... -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ rho = szero -!!$ -!!$ iteration: do -!!$ it = it + 1 -!!$ itx = itx + 1 -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),'iteration: ',itx -!!$ -!!$ rho_old = rho -!!$ rho = psb_gedot(rt,r,desc_a,info) -!!$ -!!$ if (rho == szero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' iteration breakdown r',rho -!!$ exit iteration -!!$ endif -!!$ -!!$ if (it == 1) then -!!$ call psb_geaxpby(sone,r,szero,uv,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(sone,r,szero,p,desc_a,info) -!!$ else -!!$ beta = (rho/rho_old) -!!$ call psb_geaxpby(sone,r,szero,uv,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(beta,q,sone,uv,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(sone,q,beta,p,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(sone,uv,beta,p,desc_a,info) -!!$ end if -!!$ -!!$ if (info == psb_success_) call prec%apply(p,f,desc_a,info,work=aux) -!!$ -!!$ if (info == psb_success_) call psb_spmm(sone,a,f,szero,v,desc_a,info,& -!!$ & work=aux) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='First loop part ') -!!$ goto 9999 -!!$ end if -!!$ -!!$ sigma = psb_gedot(rt,v,desc_a,info) -!!$ if (sigma == szero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' iteration breakdown s1', sigma -!!$ exit iteration -!!$ endif -!!$ -!!$ alpha = rho/sigma -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(sone,uv,szero,q,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(-alpha,v,sone,q,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(sone,uv,szero,s,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(sone,q,sone,s,desc_a,info) -!!$ -!!$ if (info == psb_success_) call prec%apply(s,z,desc_a,info,work=aux) -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(alpha,z,sone,x,desc_a,info) -!!$ -!!$ if (info == psb_success_) call psb_spmm(sone,a,z,szero,qt,desc_a,info,& -!!$ & work=aux) -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(-alpha,qt,sone,r,desc_a,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='X update ') -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ end do iteration -!!$ end do restart -!!$ -!!$ -!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ deallocate(aux,stat=info) -!!$ if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$end subroutine psb_scgs - Subroutine psb_scgs_vect(a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,istop) use psb_base_mod diff --git a/krylov/psb_scgstab.f90 b/krylov/psb_scgstab.f90 index 90058b43..73c2671e 100644 --- a/krylov/psb_scgstab.f90 +++ b/krylov/psb_scgstab.f90 @@ -93,263 +93,6 @@ ! where r is the (preconditioned, recursive ! estimate of) residual. ! -!!$subroutine psb_scgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_s_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ Implicit None -!!$! = parameters -!!$ Type(psb_sspmat_type), Intent(in) :: a -!!$ class(psb_sprec_type), Intent(in) :: prec -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ real(psb_spk_), Intent(in) :: b(:) -!!$ real(psb_spk_), Intent(inout) :: x(:) -!!$ Real(psb_spk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_spk_), Optional, Intent(out) :: err -!!$! = Local data -!!$ real(psb_spk_), allocatable, target :: aux(:),wwrk(:,:) -!!$ real(psb_spk_), Pointer :: q(:),& -!!$ & r(:), p(:), v(:), s(:), t(:), z(:), f(:) -!!$ integer(psb_ipk_) :: itmax_, naux, mglob, it,itrace_,& -!!$ & np,me, n_row, n_col -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ integer(psb_ipk_) :: itx, isvch, ictxt, err_act -!!$ integer(psb_ipk_) :: istop_ -!!$ real(psb_spk_) :: alpha, beta, rho, rho_old, sigma, omega, tau -!!$ type(psb_itconv_type) :: stopdat -!!$ real(psb_dpk_) :: derr -!!$ character(len=20) :: name -!!$ character(len=*), parameter :: methdname='BiCGStab' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_scgstab' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ ictxt = desc_a%get_context() -!!$ call psb_info(ictxt, me, np) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ If (Present(istop)) Then -!!$ istop_ = istop -!!$ Else -!!$ istop_ = 2 -!!$ Endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X') -!!$ goto 9999 -!!$ end if -!!$ call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ naux=6*n_col -!!$ allocate(aux(naux),stat=info) -!!$ if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=8) -!!$ if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ Q => WWRK(:,1) -!!$ R => WWRK(:,2) -!!$ P => WWRK(:,3) -!!$ V => WWRK(:,4) -!!$ F => WWRK(:,5) -!!$ S => WWRK(:,6) -!!$ T => WWRK(:,7) -!!$ Z => WWRK(:,8) -!!$ -!!$ if (present(itmax)) then -!!$ itmax_ = itmax -!!$ else -!!$ itmax_ = 1000 -!!$ endif -!!$ -!!$ if (present(itrace)) then -!!$ itrace_ = itrace -!!$ else -!!$ itrace_ = 0 -!!$ end if -!!$ -!!$ itx = 0 -!!$ -!!$ -!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ -!!$ restart: Do -!!$! = -!!$! = r0 = b-Ax0 -!!$! = -!!$ if (itx >= itmax_) exit restart -!!$ it = 0 -!!$ call psb_geaxpby(sone,b,szero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux) -!!$ if (info == psb_success_) call psb_geaxpby(sone,r,szero,q,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ rho = szero -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' On entry to AMAX: B: ',Size(b) -!!$ -!!$ -!!$ ! Perhaps we already satisfy the convergence criterion... -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ iteration: Do -!!$ it = it + 1 -!!$ itx = itx + 1 -!!$ If (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Iteration: ',itx -!!$ -!!$ rho_old = rho -!!$ rho = psb_gedot(q,r,desc_a,info) -!!$ -!!$ if (rho == szero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Iteration breakdown R',rho -!!$ exit iteration -!!$ endif -!!$ -!!$ if (it == 1) then -!!$ call psb_geaxpby(sone,r,szero,p,desc_a,info) -!!$ else -!!$ beta = (rho/rho_old)*(alpha/omega) -!!$ call psb_geaxpby(-omega,v,sone,p,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(sone,r,beta,p,desc_a,info) -!!$ end if -!!$ -!!$ if (info == psb_success_) call prec%apply(p,f,desc_a,info,work=aux) -!!$ -!!$ if (info == psb_success_) call psb_spmm(sone,a,f,szero,v,desc_a,info,& -!!$ & work=aux) -!!$ -!!$ if (info == psb_success_) sigma = psb_gedot(q,v,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='First step') -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (sigma == szero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Iteration breakdown S1', sigma -!!$ exit iteration -!!$ endif -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' SIGMA:',sigma -!!$ alpha = rho/sigma -!!$ -!!$ call psb_geaxpby(sone,r,szero,s,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(-alpha,v,sone,s,desc_a,info) -!!$ if (info == psb_success_) call prec%apply(s,z,desc_a,info,work=aux) -!!$ if (info == psb_success_) call psb_spmm(sone,a,z,szero,t,desc_a,info,& -!!$ & work=aux) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='Second step ') -!!$ goto 9999 -!!$ end if -!!$ -!!$ sigma = psb_gedot(t,t,desc_a,info) -!!$ if (sigma == szero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Iteration breakdown S2', sigma -!!$ exit iteration -!!$ endif -!!$ -!!$ tau = psb_gedot(t,s,desc_a,info) -!!$ omega = tau/sigma -!!$ -!!$ if (omega == szero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Iteration breakdown O',omega -!!$ exit iteration -!!$ endif -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(alpha,f,sone,x,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(omega,z,sone,x,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(sone,s,szero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(-omega,t,sone,r,desc_a,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='X update ') -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ end do iteration -!!$ end do restart -!!$ -!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ deallocate(aux,stat=info) -!!$ if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error(ictxt) -!!$ return -!!$ end if -!!$ return -!!$ -!!$End Subroutine psb_scgstab - - Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) use psb_base_mod use psb_prec_mod diff --git a/krylov/psb_scgstabl.f90 b/krylov/psb_scgstabl.f90 index 64e5d086..7d3040c0 100644 --- a/krylov/psb_scgstabl.f90 +++ b/krylov/psb_scgstabl.f90 @@ -103,311 +103,6 @@ ! ! ! -!!$Subroutine psb_scgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_s_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ implicit none -!!$ -!!$! = parameters -!!$ Type(psb_sspmat_type), Intent(in) :: a -!!$ class(psb_sprec_type), Intent(in) :: prec -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ real(psb_spk_), Intent(in) :: b(:) -!!$ real(psb_spk_), Intent(inout) :: x(:) -!!$ Real(psb_spk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_spk_), Optional, Intent(out) :: err -!!$! = local data -!!$ real(psb_spk_), allocatable, target :: aux(:),wwrk(:,:),uh(:,:), rh(:,:) -!!$ real(psb_spk_), Pointer :: ww(:), q(:), r(:), rt0(:), p(:), v(:), & -!!$ & s(:), t(:), z(:), f(:), gamma(:), gamma1(:), gamma2(:), taum(:,:), sigma(:) -!!$ -!!$ integer(psb_ipk_) :: itmax_, naux, mglob, it, itrace_,& -!!$ & np,me, n_row, n_col, nl, err_act -!!$ Logical, Parameter :: exchange=.True., noexchange=.False. -!!$ integer(psb_ipk_), Parameter :: irmax = 8 -!!$ integer(psb_ipk_) :: itx, i, isvch, ictxt,istop_,j, int_err(5) -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ real(psb_spk_) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,& -!!$ & omega -!!$ type(psb_itconv_type) :: stopdat -!!$ real(psb_dpk_) :: derr -!!$ character(len=20) :: name -!!$ character(len=*), parameter :: methdname='BiCGStab(L)' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_scgstabl' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ ictxt = desc_a%get_context() -!!$ Call psb_info(ictxt, me, np) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np -!!$ -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ if (present(istop)) then -!!$ istop_ = istop -!!$ else -!!$ istop_ = 2 -!!$ endif -!!$ -!!$ if (present(itmax)) then -!!$ itmax_ = itmax -!!$ else -!!$ itmax_ = 1000 -!!$ endif -!!$ -!!$ if (present(itrace)) then -!!$ itrace_ = itrace -!!$ else -!!$ itrace_ = 0 -!!$ end if -!!$ -!!$ if (present(irst)) then -!!$ nl = irst -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & 'present: irst: ',irst,nl -!!$ else -!!$ nl = 1 -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' not present: irst: ',irst,nl -!!$ endif -!!$ if (nl <=0 ) then -!!$ info=psb_err_invalid_istop_ -!!$ int_err(1)=nl -!!$ err=info -!!$ call psb_errpush(info,name,i_err=int_err) -!!$ goto 9999 -!!$ endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,ione),ione,ione,desc_a,info) -!!$ if (info == psb_success_) call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X/B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ naux=4*n_col -!!$ allocate(aux(naux),gamma(0:nl),gamma1(nl),& -!!$ &gamma2(nl),taum(nl,nl),sigma(nl), stat=info) -!!$ -!!$ if (info /= psb_success_) then -!!$ info=psb_err_alloc_dealloc_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=psb_err_iarg_neg_) -!!$ if (info == psb_success_) Call psb_geall(uh,desc_a,info,n=nl+1,lb=0) -!!$ if (info == psb_success_) Call psb_geall(rh,desc_a,info,n=nl+1,lb=0) -!!$ if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(uh,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(rh,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ q => wwrk(:,1) -!!$ r => wwrk(:,2) -!!$ p => wwrk(:,3) -!!$ v => wwrk(:,4) -!!$ f => wwrk(:,5) -!!$ s => wwrk(:,6) -!!$ t => wwrk(:,7) -!!$ z => wwrk(:,8) -!!$ ww => wwrk(:,9) -!!$ rt0 => wwrk(:,10) -!!$ -!!$ -!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ itx = 0 -!!$ restart: do -!!$! = -!!$! = r0 = b-ax0 -!!$! = -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),' restart: ',itx,it -!!$ if (itx >= itmax_) exit restart -!!$ -!!$ it = 0 -!!$ call psb_geaxpby(sone,b,szero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux) -!!$ -!!$ if (info == psb_success_) call prec%apply(r,desc_a,info) -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(sone,r,szero,rt0,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(sone,r,szero,rh(:,0),desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(szero,r,szero,uh(:,0),desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ rho = sone -!!$ alpha = szero -!!$ omega = sone -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' on entry to amax: b: ',Size(b) -!!$ -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ iteration: do -!!$ it = it + nl -!!$ itx = itx + nl -!!$ rho = -omega*rho -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' iteration: ',itx, rho,rh(1,0) -!!$ -!!$ do j = 0, nl -1 -!!$ If (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),'bicg part: ',j, nl -!!$ -!!$ rho_old = rho -!!$ rho = psb_gedot(rh(:,j),rt0,desc_a,info) -!!$ if (rho == szero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' bi-cgstab iteration breakdown r',rho -!!$ exit iteration -!!$ endif -!!$ -!!$ beta = alpha*rho/rho_old -!!$ rho_old = rho -!!$ call psb_geaxpby(sone,rh(:,0:j),-beta,uh(:,0:j),desc_a,info) -!!$ call psb_spmm(sone,a,uh(:,j),szero,uh(:,j+1),desc_a,info,work=aux) -!!$ -!!$ call prec%apply(uh(:,j+1),desc_a,info) -!!$ -!!$ gamma(j) = psb_gedot(uh(:,j+1),rt0,desc_a,info) -!!$ -!!$ if (gamma(j) == szero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' bi-cgstab iteration breakdown s2',gamma(j) -!!$ exit iteration -!!$ endif -!!$ alpha = rho/gamma(j) -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' bicg part: alpha=r/g ',alpha,rho,gamma(j) -!!$ -!!$ call psb_geaxpby(-alpha,uh(:,1:j+1),sone,rh(:,0:j),desc_a,info) -!!$ call psb_geaxpby(alpha,uh(:,0),sone,x,desc_a,info) -!!$ call psb_spmm(sone,a,rh(:,j),szero,rh(:,j+1),desc_a,info,work=aux) -!!$ -!!$ call prec%apply(rh(:,j+1),desc_a,info) -!!$ -!!$ enddo -!!$ -!!$ do j=1, nl -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' mod g-s part: ',j, nl,rh(1,0) -!!$ -!!$ do i=1, j-1 -!!$ taum(i,j) = psb_gedot(rh(:,i),rh(:,j),desc_a,info) -!!$ taum(i,j) = taum(i,j)/sigma(i) -!!$ call psb_geaxpby(-taum(i,j),rh(:,i),sone,rh(:,j),desc_a,info) -!!$ enddo -!!$ sigma(j) = psb_gedot(rh(:,j),rh(:,j),desc_a,info) -!!$ gamma1(j) = psb_gedot(rh(:,0),rh(:,j),desc_a,info) -!!$ gamma1(j) = gamma1(j)/sigma(j) -!!$ enddo -!!$ -!!$ gamma(nl) = gamma1(nl) -!!$ omega = gamma(nl) -!!$ -!!$ do j=nl-1,1,-1 -!!$ gamma(j) = gamma1(j) -!!$ do i=j+1,nl -!!$ gamma(j) = gamma(j) - taum(j,i) * gamma(i) -!!$ enddo -!!$ enddo -!!$ -!!$ do j=1,nl-1 -!!$ gamma2(j) = gamma(j+1) -!!$ do i=j+1,nl-1 -!!$ gamma2(j) = gamma2(j) + taum(j,i) * gamma(i+1) -!!$ enddo -!!$ enddo -!!$ -!!$ call psb_geaxpby(gamma(1),rh(:,0),sone,x,desc_a,info) -!!$ call psb_geaxpby(-gamma1(nl),rh(:,nl),sone,rh(:,0),desc_a,info) -!!$ call psb_geaxpby(-gamma(nl),uh(:,nl),sone,uh(:,0),desc_a,info) -!!$ -!!$ do j=1, nl-1 -!!$ call psb_geaxpby(-gamma(j),uh(:,j),sone,uh(:,0),desc_a,info) -!!$ call psb_geaxpby(gamma2(j),rh(:,j),sone,x,desc_a,info) -!!$ call psb_geaxpby(-gamma1(j),rh(:,j),sone,rh(:,0),desc_a,info) -!!$ enddo -!!$ -!!$ if (psb_check_conv(methdname,itx,x,rh(:,0),desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ end do iteration -!!$ end do restart -!!$ -!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ deallocate(aux,stat=info) -!!$ if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) -!!$ if (info == psb_success_) call psb_gefree(uh,desc_a,info) -!!$ if (info == psb_success_) call psb_gefree(rh,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$End Subroutine psb_scgstabl -!!$ - - Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,irst,istop) use psb_base_mod diff --git a/krylov/psb_skrylov.f90 b/krylov/psb_skrylov.f90 index 29ed80c2..4afeca56 100644 --- a/krylov/psb_skrylov.f90 +++ b/krylov/psb_skrylov.f90 @@ -33,217 +33,51 @@ ! File: psb_krylov_mod.f90 ! Interfaces for Krylov subspace iterative methods. ! - - ! - ! Subroutine: psb_skrylov - ! - ! Front-end for the Krylov subspace iterations, realversion - ! - ! Arguments: - ! - ! methd - character The specific method; can take the values: - ! CG - ! CGS - ! BICG - ! BICGSTAB - ! BICGSTABL - ! RGMRES - ! - ! a - type(psb_sspmat_type) Input: sparse matrix containing A. - ! prec - class(psb_sprec_type) Input: preconditioner - ! b - real,dimension(:) Input: vector containing the - ! right hand side B - ! x - real,dimension(:) Input/Output: vector containing the - ! initial guess and final solution X. - ! eps - real Input: Stopping tolerance; the iteration is - ! stopped when the error - ! estimate |err| <= eps - ! - ! desc_a - type(psb_desc_type). Input: The communication descriptor. - ! info - integer. Output: Return code - ! - ! itmax - integer(optional) Input: maximum number of iterations to be - ! performed. - ! iter - integer(optional) Output: how many iterations have been - ! performed. - ! err - real (optional) Output: error estimate on exit - ! itrace - integer(optional) Input: print an informational message - ! with the error estimate every itrace - ! iterations - ! irst - integer(optional) Input: restart parameter for RGMRES and - ! BICGSTAB(L) methods - ! istop - integer(optional) Input: stopping criterion, or how - ! to estimate the error. - ! 1: err = |r|/(|a||x|+|b|) - ! 2: err = |r|/|b| - ! where r is the (preconditioned, recursive - ! estimate of) residual - ! -!!$Subroutine psb_skrylov(method,a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod,only : psb_sprec_type, psb_dprec_type, psb_sprec_type, psb_zprec_type -!!$ use psb_krylov_mod, psb_protect_name => psb_skrylov -!!$ character(len=*) :: method -!!$ Type(psb_sspmat_type), Intent(in) :: a -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ class(psb_sprec_type), intent(in) :: prec -!!$ real(psb_spk_), Intent(in) :: b(:) -!!$ real(psb_spk_), Intent(inout) :: x(:) -!!$ Real(psb_spk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_spk_), Optional, Intent(out) :: err -!!$ interface -!!$ subroutine psb_scg(a,prec,b,x,eps,& -!!$ & desc_a,info,itmax,iter,err,itrace,istop) -!!$ import :: psb_ipk_, psb_spk_, psb_desc_type, & -!!$ & psb_sspmat_type, psb_sprec_type -!!$ type(psb_sspmat_type), intent(in) :: a -!!$ type(psb_desc_type), intent(in) :: desc_a -!!$ real(psb_spk_), intent(in) :: b(:) -!!$ real(psb_spk_), intent(inout) :: x(:) -!!$ real(psb_spk_), intent(in) :: eps -!!$ class(psb_sprec_type), intent(in) :: prec -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), optional, intent(in) :: itmax, itrace,istop -!!$ integer(psb_ipk_), optional, intent(out) :: iter -!!$ real(psb_spk_), optional, intent(out) :: err -!!$ end subroutine psb_scg -!!$ subroutine psb_sbicg(a,prec,b,x,eps,& -!!$ & desc_a,info,itmax,iter,err,itrace,istop) -!!$ import :: psb_ipk_, psb_spk_, psb_desc_type, & -!!$ & psb_sspmat_type, psb_sprec_type -!!$ type(psb_sspmat_type), intent(in) :: a -!!$ type(psb_desc_type), intent(in) :: desc_a -!!$ real(psb_spk_), intent(in) :: b(:) -!!$ real(psb_spk_), intent(inout) :: x(:) -!!$ real(psb_spk_), intent(in) :: eps -!!$ class(psb_sprec_type), intent(in) :: prec -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), optional, intent(in) :: itmax, itrace,istop -!!$ integer(psb_ipk_), optional, intent(out) :: iter -!!$ real(psb_spk_), optional, intent(out) :: err -!!$ end subroutine psb_sbicg -!!$ subroutine psb_scgstab(a,prec,b,x,eps,& -!!$ & desc_a,info,itmax,iter,err,itrace,istop) -!!$ import :: psb_ipk_, psb_spk_, psb_desc_type, & -!!$ & psb_sspmat_type, psb_sprec_type -!!$ type(psb_sspmat_type), intent(in) :: a -!!$ type(psb_desc_type), intent(in) :: desc_a -!!$ real(psb_spk_), intent(in) :: b(:) -!!$ real(psb_spk_), intent(inout) :: x(:) -!!$ real(psb_spk_), intent(in) :: eps -!!$ class(psb_sprec_type), intent(in) :: prec -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), optional, intent(in) :: itmax, itrace,istop -!!$ integer(psb_ipk_), optional, intent(out) :: iter -!!$ real(psb_spk_), optional, intent(out) :: err -!!$ end subroutine psb_scgstab -!!$ Subroutine psb_scgstabl(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,irst,istop) -!!$ import :: psb_ipk_, psb_spk_, psb_desc_type, & -!!$ & psb_sspmat_type, psb_sprec_type -!!$ Type(psb_sspmat_type), Intent(in) :: a -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ class(psb_sprec_type), intent(in) :: prec -!!$ real(psb_spk_), Intent(in) :: b(:) -!!$ real(psb_spk_), Intent(inout) :: x(:) -!!$ Real(psb_spk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_spk_), Optional, Intent(out) :: err -!!$ end subroutine psb_scgstabl -!!$ Subroutine psb_srgmres(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,irst,istop) -!!$ import :: psb_ipk_, psb_spk_, psb_desc_type, & -!!$ & psb_sspmat_type, psb_sprec_type -!!$ Type(psb_sspmat_type), Intent(in) :: a -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ class(psb_sprec_type), intent(in) :: prec -!!$ real(psb_spk_), Intent(in) :: b(:) -!!$ real(psb_spk_), Intent(inout) :: x(:) -!!$ Real(psb_spk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_spk_), Optional, Intent(out) :: err -!!$ end subroutine psb_srgmres -!!$ subroutine psb_scgs(a,prec,b,x,eps,& -!!$ & desc_a,info,itmax,iter,err,itrace,istop) -!!$ import :: psb_ipk_, psb_spk_, psb_desc_type, & -!!$ & psb_sspmat_type, psb_sprec_type -!!$ type(psb_sspmat_type), intent(in) :: a -!!$ type(psb_desc_type), intent(in) :: desc_a -!!$ real(psb_spk_), intent(in) :: b(:) -!!$ real(psb_spk_), intent(inout) :: x(:) -!!$ real(psb_spk_), intent(in) :: eps -!!$ class(psb_sprec_type), intent(in) :: prec -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), optional, intent(in) :: itmax, itrace,istop -!!$ integer(psb_ipk_), optional, intent(out) :: iter -!!$ real(psb_spk_), optional, intent(out) :: err -!!$ end subroutine psb_scgs -!!$ end interface -!!$ -!!$ -!!$ integer(psb_ipk_) :: ictxt,me,np,err_act -!!$ character(len=20) :: name -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_krylov' -!!$ call psb_erractionsave(err_act) -!!$ -!!$ -!!$ ictxt=desc_a%get_context() -!!$ -!!$ call psb_info(ictxt, me, np) -!!$ -!!$ -!!$ select case(psb_toupper(method)) -!!$ case('CG') -!!$ call psb_scg(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,istop) -!!$ case('CGS') -!!$ call psb_scgs(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,istop) -!!$ case('BICG') -!!$ call psb_sbicg(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,istop) -!!$ case('BICGSTAB') -!!$ call psb_scgstab(a,prec,b,x,eps,desc_a,info,& -!!$ & itmax,iter,err,itrace,istop) -!!$ case('RGMRES') -!!$ call psb_srgmres(a,prec,b,x,eps,desc_a,info,& -!!$ & itmax,iter,err,itrace,irst,istop) -!!$ case('BICGSTABL') -!!$ call psb_scgstabl(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,irst,istop) -!!$ case default -!!$ if (me == 0) write(psb_err_unit,*) trim(name),': Warning: Unknown method ',method,& -!!$ & ', defaulting to BiCGSTAB' -!!$ call psb_scgstab(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,istop) -!!$ end select -!!$ -!!$ if(info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error(ictxt) -!!$ return -!!$ end if -!!$ -!!$end subroutine psb_skrylov - +! +! Subroutine: psb_skrylov +! +! Front-end for the Krylov subspace iterations, realversion +! +! Arguments: +! +! methd - character The specific method; can take the values: +! CG +! CGS +! BICG +! BICGSTAB +! BICGSTABL +! RGMRES +! +! a - type(psb_sspmat_type) Input: sparse matrix containing A. +! prec - class(psb_sprec_type) Input: preconditioner +! b - real,dimension(:) Input: vector containing the +! right hand side B +! x - real,dimension(:) Input/Output: vector containing the +! initial guess and final solution X. +! eps - real Input: Stopping tolerance; the iteration is +! stopped when the error +! estimate |err| <= eps +! +! desc_a - type(psb_desc_type). Input: The communication descriptor. +! info - integer. Output: Return code +! +! itmax - integer(optional) Input: maximum number of iterations to be +! performed. +! iter - integer(optional) Output: how many iterations have been +! performed. +! err - real (optional) Output: error estimate on exit +! itrace - integer(optional) Input: print an informational message +! with the error estimate every itrace +! iterations +! irst - integer(optional) Input: restart parameter for RGMRES and +! BICGSTAB(L) methods +! istop - integer(optional) Input: stopping criterion, or how +! to estimate the error. +! 1: err = |r|/(|a||x|+|b|) +! 2: err = |r|/|b| +! where r is the (preconditioned, recursive +! estimate of) residual +! Subroutine psb_skrylov_vect(method,a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,irst,istop,cond) diff --git a/krylov/psb_srgmres.f90 b/krylov/psb_srgmres.f90 index 3e671b78..a7062bd0 100644 --- a/krylov/psb_srgmres.f90 +++ b/krylov/psb_srgmres.f90 @@ -105,369 +105,6 @@ ! estimate of) residual. ! irst - integer(optional) Input: restart parameter ! -!!$Subroutine psb_srgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_s_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ implicit none -!!$ -!!$! = Parameters -!!$ Type(psb_sspmat_type), Intent(in) :: a -!!$ class(psb_sprec_type), Intent(in) :: prec -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ real(psb_spk_), Intent(in) :: b(:) -!!$ real(psb_spk_), Intent(inout) :: x(:) -!!$ Real(psb_spk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_spk_), Optional, Intent(out) :: err -!!$! = local data -!!$ real(psb_spk_), allocatable, target :: aux(:),w(:),w1(:), v(:,:) -!!$ real(psb_spk_), allocatable :: c(:),s(:), h(:,:), rs(:),rst(:),xt(:) -!!$ Real(psb_spk_) :: tmp -!!$ real(psb_spk_) :: rti, rti1, scal -!!$ integer(psb_ipk_) ::litmax, naux, mglob, it,k, itrace_,& -!!$ & np,me, n_row, n_col, nl, int_err(5) -!!$ Logical, Parameter :: exchange=.True., noexchange=.False. -!!$ integer(psb_ipk_), Parameter :: irmax = 8 -!!$ integer(psb_ipk_) :: itx, i, isvch, ictxt,istop_, err_act -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ Real(psb_dpk_) :: rni, xni, bni, ani,bn2 -!!$ real(psb_dpk_) :: errnum, errden, deps, derr -!!$ character(len=20) :: name -!!$ character(len=*), parameter :: methdname='RGMRES' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_sgmres' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ ictxt = desc_a%get_context() -!!$ Call psb_info(ictxt, me, np) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ if (present(istop)) then -!!$ istop_ = istop -!!$ else -!!$ istop_ = 2 -!!$ endif -!!$ ! -!!$ ! ISTOP_ = 1: Normwise backward error, infinity norm -!!$ ! ISTOP_ = 2: ||r||/||b||, 2-norm -!!$ ! -!!$ -!!$ if ((istop_ < 1 ).or.(istop_ > 2 ) ) then -!!$ info=psb_err_invalid_istop_ -!!$ int_err(1)=istop_ -!!$ err=info -!!$ call psb_errpush(info,name,i_err=int_err) -!!$ goto 9999 -!!$ endif -!!$ -!!$ if (present(itmax)) then -!!$ litmax = itmax -!!$ else -!!$ litmax = 1000 -!!$ endif -!!$ -!!$ if (present(itrace)) then -!!$ itrace_ = itrace -!!$ else -!!$ itrace_ = 0 -!!$ end if -!!$ -!!$ if (present(irst)) then -!!$ nl = irst -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' present: irst: ',irst,nl -!!$ else -!!$ nl = 10 -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' not present: irst: ',irst,nl -!!$ endif -!!$ if (nl <=0 ) then -!!$ info=psb_err_invalid_istop_ -!!$ int_err(1)=nl -!!$ err=info -!!$ call psb_errpush(info,name,i_err=int_err) -!!$ goto 9999 -!!$ endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,1),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X') -!!$ goto 9999 -!!$ end if -!!$ call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ naux=4*n_col -!!$ allocate(aux(naux),h(nl+1,nl+1),& -!!$ &c(nl+1),s(nl+1),rs(nl+1), rst(nl+1),stat=info) -!!$ -!!$ if (info == psb_success_) Call psb_geall(v,desc_a,info,n=nl+1) -!!$ if (info == psb_success_) Call psb_geall(w,desc_a,info) -!!$ if (info == psb_success_) Call psb_geall(w1,desc_a,info) -!!$ if (info == psb_success_) Call psb_geall(xt,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(v,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(w,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(w1,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(xt,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Size of V,W,W1 ',size(v),size(v,1),& -!!$ & size(w),size(w,1),size(w1),size(w1,1), size(v(:,1)) -!!$ -!!$ -!!$ if (istop_ == 1) then -!!$ ani = psb_spnrmi(a,desc_a,info) -!!$ bni = psb_geamax(b,desc_a,info) -!!$ else if (istop_ == 2) then -!!$ bn2 = psb_genrm2(b,desc_a,info) -!!$ endif -!!$ errnum = dzero -!!$ errden = done -!!$ deps = eps -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ if ((itrace_ > 0).and.(me == 0)) call log_header(methdname) -!!$ -!!$ itx = 0 -!!$ restart: do -!!$ -!!$ ! compute r0 = b-ax0 -!!$ ! check convergence -!!$ ! compute v1 = r0/||r0||_2 -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' restart: ',itx,it -!!$ it = 0 -!!$ call psb_geaxpby(sone,b,szero,v(:,1),desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_spmm(-sone,a,x,sone,v(:,1),desc_a,info,work=aux) -!!$ if (info /= psb_success_) Then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ rs(1) = psb_genrm2(v(:,1),desc_a,info) -!!$ rs(2:) = szero -!!$ if (info /= psb_success_) Then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ scal=done/rs(1) ! rs(1) MIGHT BE VERY SMALL - USE DSCAL TO DEAL WITH IT? -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' on entry to amax: b: ',Size(b),rs(1),scal -!!$ -!!$ ! -!!$ ! check convergence -!!$ ! -!!$ if (istop_ == 1) then -!!$ rni = psb_geamax(v(:,1),desc_a,info) -!!$ xni = psb_geamax(x,desc_a,info) -!!$ errnum = rni -!!$ errden = (ani*xni+bni) -!!$ else if (istop_ == 2) then -!!$ rni = psb_genrm2(v(:,1),desc_a,info) -!!$ errnum = rni -!!$ errden = bn2 -!!$ endif -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (errnum <= deps*errden) exit restart -!!$ -!!$ if (itrace_ > 0) & -!!$ & call log_conv(methdname,me,itx,itrace_,errnum,errden,deps) -!!$ -!!$ v(:,1) = v(:,1) * scal -!!$ -!!$ if (itx >= litmax) exit restart -!!$ -!!$ ! -!!$ ! inner iterations -!!$ ! -!!$ -!!$ inner: Do i=1,nl -!!$ itx = itx + 1 -!!$ -!!$ call prec%apply(v(:,i),w1,desc_a,info) -!!$ Call psb_spmm(sone,a,w1,szero,w,desc_a,info,work=aux) -!!$ ! -!!$ -!!$ do k = 1, i -!!$ h(k,i) = psb_gedot(v(:,k),w,desc_a,info) -!!$ call psb_geaxpby(-h(k,i),v(:,k),sone,w,desc_a,info) -!!$ end do -!!$ h(i+1,i) = psb_genrm2(w,desc_a,info) -!!$ scal=done/h(i+1,i) -!!$ call psb_geaxpby(scal,w,szero,v(:,i+1),desc_a,info) -!!$ do k=2,i -!!$ call srot(1,h(k-1,i),1,h(k,i),1,real(c(k-1)),s(k-1)) -!!$ enddo -!!$ -!!$ rti = h(i,i) -!!$ rti1 = h(i+1,i) -!!$ call srotg(rti,rti1,tmp,s(i)) -!!$ c(i) = cmplx(tmp,szero) -!!$ call srot(1,h(i,i),1,h(i+1,i),1,real(c(i)),s(i)) -!!$ h(i+1,i) = szero -!!$ call srot(1,rs(i),1,rs(i+1),1,real(c(i)),s(i)) -!!$ -!!$ if (istop_ == 1) then -!!$ ! -!!$ ! build x and then compute the residual and its infinity norm -!!$ ! -!!$ rst = rs -!!$ xt = szero -!!$ call strsm('l','u','n','n',i,1,sone,h,size(h,1),rst,size(rst,1)) -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Rebuild x-> RS:',rst(1:nl) -!!$ do k=1, i -!!$ call psb_geaxpby(rst(k),v(:,k),sone,xt,desc_a,info) -!!$ end do -!!$ call prec%apply(xt,desc_a,info) -!!$ call psb_geaxpby(sone,x,sone,xt,desc_a,info) -!!$ call psb_geaxpby(sone,b,szero,w1,desc_a,info) -!!$ call psb_spmm(-sone,a,xt,sone,w1,desc_a,info,work=aux) -!!$ rni = psb_geamax(w1,desc_a,info) -!!$ xni = psb_geamax(xt,desc_a,info) -!!$ errnum = rni -!!$ errden = (ani*xni+bni) -!!$ ! -!!$ -!!$ else if (istop_ == 2) then -!!$ ! -!!$ ! compute the residual 2-norm as byproduct of the solution -!!$ ! procedure of the least-squares problem -!!$ ! -!!$ rni = abs(rs(i+1)) -!!$ errnum = rni -!!$ errden = bn2 -!!$ endif -!!$ -!!$ If (errnum <= deps*errden) Then -!!$ -!!$ if (istop_ == 1) then -!!$ x = xt -!!$ else if (istop_ == 2) then -!!$ ! -!!$ ! build x -!!$ ! -!!$ call strsm('l','u','n','n',i,1,sone,h,size(h,1),rs,size(rs,1)) -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Rebuild x-> RS:',rs(1:nl) -!!$ w1 = szero -!!$ do k=1, i -!!$ call psb_geaxpby(rs(k),v(:,k),sone,w1,desc_a,info) -!!$ end do -!!$ call prec%apply(w1,w,desc_a,info) -!!$ call psb_geaxpby(sone,w,sone,x,desc_a,info) -!!$ end if -!!$ -!!$ exit restart -!!$ -!!$ end if -!!$ -!!$ if (itrace_ > 0) & -!!$ & call log_conv(methdname,me,itx,itrace_,errnum,errden,deps) -!!$ -!!$ end do inner -!!$ -!!$ if (istop_ == 1) then -!!$ x = xt -!!$ else if (istop_ == 2) then -!!$ ! -!!$ ! build x -!!$ ! -!!$ call strsm('l','u','n','n',nl,1,sone,h,size(h,1),rs,size(rs,1)) -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Rebuild x-> RS:',rs(1:nl) -!!$ w1 = szero -!!$ do k=1, nl -!!$ call psb_geaxpby(rs(k),v(:,k),sone,w1,desc_a,info) -!!$ end do -!!$ call prec%apply(w1,w,desc_a,info) -!!$ call psb_geaxpby(sone,w,sone,x,desc_a,info) -!!$ end if -!!$ -!!$ end do restart -!!$ if (itrace_ > 0) & -!!$ & call log_conv(methdname,me,itx,ione,errnum,errden,deps) -!!$ -!!$ call log_end(methdname,me,itx,errnum,errden,deps,err=derr,iter=iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ -!!$ deallocate(aux,h,c,s,rs,rst, stat=info) -!!$ if (info == psb_success_) call psb_gefree(v,desc_a,info) -!!$ if (info == psb_success_) call psb_gefree(w,desc_a,info) -!!$ if (info == psb_success_) call psb_gefree(w1,desc_a,info) -!!$ if (info == psb_success_) call psb_gefree(xt,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$End Subroutine psb_srgmres - - subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,irst,istop) @@ -738,7 +375,7 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,& call strsm('l','u','n','n',i,1,sone,h,size(h,1),rst,size(rst,1)) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& - & ' Rebuild x-> RS:',rst(1:nl) + & ' Rebuild x-> RS:',rst(1:i) do k=1, i call psb_geaxpby(rst(k),v(k),sone,xt,desc_a,info) end do @@ -774,7 +411,7 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,& call strsm('l','u','n','n',i,1,sone,h,size(h,1),rs,size(rs,1)) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& - & ' Rebuild x-> RS:',rs(1:nl) + & ' Rebuild x-> RS:',rs(1:i) call w1%set(szero) do k=1, i call psb_geaxpby(rs(k),v(k),sone,w1,desc_a,info) diff --git a/krylov/psb_zbicg.f90 b/krylov/psb_zbicg.f90 index 3a9b1c74..6f14a9c0 100644 --- a/krylov/psb_zbicg.f90 +++ b/krylov/psb_zbicg.f90 @@ -93,243 +93,6 @@ ! estimate of) residual. ! ! -!!$subroutine psb_zbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_z_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ implicit none -!!$ -!!$! !$ parameters -!!$ type(psb_zspmat_type), intent(in) :: a -!!$ class(psb_zprec_type), intent(in) :: prec -!!$ type(psb_desc_type), intent(in) :: desc_a -!!$ complex(psb_dpk_), intent(in) :: b(:) -!!$ complex(psb_dpk_), intent(inout) :: x(:) -!!$ real(psb_dpk_), intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), optional, intent(in) :: itmax, itrace, istop -!!$ integer(psb_ipk_), optional, intent(out) :: iter -!!$ real(psb_dpk_), optional, intent(out) :: err -!!$! !$ local data -!!$ complex(psb_dpk_), allocatable, target :: aux(:),wwrk(:,:) -!!$ complex(psb_dpk_), pointer :: ww(:), q(:),& -!!$ & r(:), p(:), zt(:), pt(:), z(:), rt(:),qt(:) -!!$ integer(psb_ipk_) :: int_err(5) -!!$ integer(psb_ipk_) ::itmax_, naux, mglob, it, itrace_,& -!!$ & np,me, n_row, n_col, istop_, err_act -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ logical, parameter :: exchange=.true., noexchange=.false. -!!$ integer(psb_ipk_), parameter :: irmax = 8 -!!$ integer(psb_ipk_) :: itx, ictxt -!!$ complex(psb_dpk_) :: alpha, beta, rho, rho_old, sigma -!!$ type(psb_itconv_type) :: stopdat -!!$ real(psb_dpk_) :: derr -!!$ character(len=20) :: name,ch_err -!!$ character(len=*), parameter :: methdname='BiCG' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_zbicg' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ ictxt = desc_a%get_context() -!!$ call psb_info(ictxt, me, np) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ -!!$ if (present(istop)) then -!!$ istop_ = istop -!!$ else -!!$ istop_ = 2 -!!$ endif -!!$ ! -!!$ ! istop_ = 1: normwise backward error, infinity norm -!!$ ! istop_ = 2: ||r||/||b|| norm 2 -!!$ ! -!!$ -!!$ if ((istop_ < 1 ).or.(istop_ > 2 ) ) then -!!$ info=psb_err_invalid_istop_ -!!$ int_err=istop_ -!!$ err=info -!!$ call psb_errpush(info,name,i_err=int_err) -!!$ goto 9999 -!!$ endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X') -!!$ goto 9999 -!!$ end if -!!$ call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ naux=4*n_col -!!$ -!!$ allocate(aux(naux),stat=info) -!!$ if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=9) -!!$ if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ ch_err='psb_asb' -!!$ err=info -!!$ call psb_errpush(info,name,a_err=ch_err) -!!$ goto 9999 -!!$ end if -!!$ -!!$ q => wwrk(:,1) -!!$ qt => wwrk(:,2) -!!$ r => wwrk(:,3) -!!$ rt => wwrk(:,4) -!!$ p => wwrk(:,5) -!!$ pt => wwrk(:,6) -!!$ z => wwrk(:,7) -!!$ zt => wwrk(:,8) -!!$ ww => wwrk(:,9) -!!$ -!!$ if (present(itmax)) then -!!$ itmax_ = itmax -!!$ else -!!$ itmax_ = 1000 -!!$ endif -!!$ -!!$ if (present(itrace)) then -!!$ itrace_ = itrace -!!$ else -!!$ itrace_ = 0 -!!$ end if -!!$ -!!$ itx = 0 -!!$ -!!$ -!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ restart: do -!!$! !$ -!!$! !$ r0 = b-ax0 -!!$! !$ -!!$ if (itx >= itmax_) exit restart -!!$ it = 0 -!!$ call psb_geaxpby(zone,b,zzero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_spmm(-zone,a,x,zone,r,desc_a,info,work=aux) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),' zone spmm',info -!!$ if (info == psb_success_) call psb_geaxpby(zone,r,zzero,rt,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ rho = zzero -!!$ -!!$ ! Perhaps we already satisfy the convergence criterion... -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ iteration: do -!!$ it = it + 1 -!!$ itx = itx + 1 -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),'iteration: ',itx -!!$ -!!$ call prec%apply(r,z,desc_a,info,work=aux) -!!$ if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='c',work=aux) -!!$ -!!$ rho_old = rho -!!$ rho = psb_gedot(rt,z,desc_a,info) -!!$ if (rho == zzero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' iteration breakdown r',rho -!!$ exit iteration -!!$ endif -!!$ -!!$ if (it == 1) then -!!$ call psb_geaxpby(zone,z,zzero,p,desc_a,info) -!!$ call psb_geaxpby(zone,zt,zzero,pt,desc_a,info) -!!$ else -!!$ beta = (rho/rho_old) -!!$ call psb_geaxpby(zone,z,(beta),p,desc_a,info) -!!$ call psb_geaxpby(zone,zt,(beta),pt,desc_a,info) -!!$ end if -!!$ -!!$ call psb_spmm(zone,a,p,zzero,q,desc_a,info,& -!!$ & work=aux) -!!$ call psb_spmm(zone,a,pt,zzero,qt,desc_a,info,& -!!$ & work=aux,trans='c') -!!$ -!!$ sigma = psb_gedot(pt,q,desc_a,info) -!!$ if (sigma == zzero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' iteration breakdown s1', sigma -!!$ exit iteration -!!$ endif -!!$ -!!$ alpha = rho/sigma -!!$ -!!$ -!!$ call psb_geaxpby((alpha),p,zone,x,desc_a,info) -!!$ call psb_geaxpby(-(alpha),q,zone,r,desc_a,info) -!!$ call psb_geaxpby(-(alpha),qt,zone,rt,desc_a,info) -!!$ -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ end do iteration -!!$ end do restart -!!$ -!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ deallocate(aux, stat=info) -!!$ if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$end subroutine psb_zbicg -!!$ - subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,istop) diff --git a/krylov/psb_zcg.f90 b/krylov/psb_zcg.f90 index dd3bc839..9c4292d4 100644 --- a/krylov/psb_zcg.f90 +++ b/krylov/psb_zcg.f90 @@ -95,190 +95,6 @@ ! estimate of) residual. ! ! -!!$subroutine psb_zcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_z_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ implicit none -!!$ -!!$! = Parameters -!!$ Type(psb_zspmat_type), Intent(in) :: a -!!$ class(psb_zprec_type), Intent(in) :: prec -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ complex(psb_dpk_), Intent(in) :: b(:) -!!$ complex(psb_dpk_), Intent(inout) :: x(:) -!!$ Real(psb_dpk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_dpk_), Optional, Intent(out) :: err -!!$! = Local data -!!$ complex(psb_dpk_), allocatable, target :: aux(:), wwrk(:,:) -!!$ complex(psb_dpk_), pointer :: q(:), p(:), r(:), z(:), w(:) -!!$ complex(psb_dpk_) :: alpha, beta, rho, rho_old, sigma -!!$ integer(psb_ipk_) :: itmax_, istop_, naux, mglob, it, itx, itrace_,& -!!$ & np,me, n_col, isvch, ictxt, n_row,err_act, int_err(5) -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ type(psb_itconv_type) :: stopdat -!!$ real(psb_dpk_) :: derr -!!$ character(len=20) :: name -!!$ character(len=*), parameter :: methdname='CG' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_zcg' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ ictxt = desc_a%get_context() -!!$ -!!$ call psb_info(ictxt, me, np) -!!$ -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ if (present(istop)) then -!!$ istop_ = istop -!!$ else -!!$ istop_ = 2 -!!$ endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,ione),ione,ione,desc_a,info) -!!$ if (info == psb_success_) call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X/B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ naux=4*n_col -!!$ allocate(aux(naux), stat=info) -!!$ if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=psb_err_invalid_input_) -!!$ if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ p => wwrk(:,1) -!!$ q => wwrk(:,2) -!!$ r => wwrk(:,3) -!!$ z => wwrk(:,4) -!!$ w => wwrk(:,5) -!!$ -!!$ -!!$ if (present(itmax)) then -!!$ itmax_ = itmax -!!$ else -!!$ itmax_ = 1000 -!!$ endif -!!$ -!!$ if (present(itrace)) then -!!$ itrace_ = itrace -!!$ else -!!$ itrace_ = 0 -!!$ end if -!!$ -!!$ itx=0 -!!$ -!!$ restart: do -!!$! = -!!$! = r0 = b-Ax0 -!!$! = -!!$ if (itx>= itmax_) exit restart -!!$ -!!$ it = 0 -!!$ call psb_geaxpby(zone,b,zzero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_spmm(-zone,a,x,zone,r,desc_a,info,work=aux) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ rho = zzero -!!$ -!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ iteration: do -!!$ -!!$ it = it + 1 -!!$ itx = itx + 1 -!!$ -!!$ call prec%apply(r,z,desc_a,info,work=aux) -!!$ rho_old = rho -!!$ rho = psb_gedot(r,z,desc_a,info) -!!$ -!!$ if (it == 1) then -!!$ call psb_geaxpby(zone,z,zzero,p,desc_a,info) -!!$ else -!!$ if (rho_old == zzero) then -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ': CG Iteration breakdown rho' -!!$ exit iteration -!!$ endif -!!$ beta = rho/rho_old -!!$ call psb_geaxpby(zone,z,beta,p,desc_a,info) -!!$ end if -!!$ -!!$ call psb_spmm(zone,a,p,zzero,q,desc_a,info,work=aux) -!!$ sigma = psb_gedot(p,q,desc_a,info) -!!$ if (sigma == zzero) then -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ': CG Iteration breakdown sigma' -!!$ exit iteration -!!$ endif -!!$ -!!$ alpha = rho/sigma -!!$ call psb_geaxpby(alpha,p,zone,x,desc_a,info) -!!$ call psb_geaxpby(-alpha,q,zone,r,desc_a,info) -!!$ -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ end do iteration -!!$ end do restart -!!$ -!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ call psb_gefree(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$end subroutine psb_zcg -!!$ - subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,istop) use psb_base_mod diff --git a/krylov/psb_zcgs.f90 b/krylov/psb_zcgs.f90 index 757c3835..2c2851a2 100644 --- a/krylov/psb_zcgs.f90 +++ b/krylov/psb_zcgs.f90 @@ -92,238 +92,6 @@ ! where r is the (preconditioned, recursive ! estimate of) residual. ! -!!$Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_z_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ implicit none -!!$ -!!$! = parameters -!!$ Type(psb_zspmat_type), Intent(in) :: a -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ class(psb_zprec_type), Intent(in) :: prec -!!$ complex(psb_dpk_), Intent(in) :: b(:) -!!$ complex(psb_dpk_), Intent(inout) :: x(:) -!!$ Real(psb_dpk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_dpk_), Optional, Intent(out) :: err -!!$! = local data -!!$ complex(psb_dpk_), allocatable, target :: aux(:),wwrk(:,:) -!!$ complex(psb_dpk_), Pointer :: ww(:), q(:),& -!!$ & r(:), p(:), v(:), s(:), z(:), f(:), rt(:),qt(:),uv(:) -!!$ integer(psb_ipk_) :: itmax_, naux, mglob, it, itrace_,int_err(5),& -!!$ & np,me, n_row, n_col,istop_, err_act -!!$ integer(psb_ipk_) :: itx, isvch, ictxt -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ complex(psb_dpk_) :: alpha, beta, rho, rho_old, sigma -!!$ type(psb_itconv_type) :: stopdat -!!$ real(psb_dpk_) :: derr -!!$ character(len=20) :: name -!!$ character(len=*), parameter :: methdname='CGS' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_zcgs' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ ictxt = desc_a%get_context() -!!$ Call psb_info(ictxt, me, np) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ If (Present(istop)) Then -!!$ istop_ = istop -!!$ Else -!!$ istop_ = 2 -!!$ Endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,ione),ione,ione,desc_a,info) -!!$ if (info == psb_success_) call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X/B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ naux=4*n_col -!!$ Allocate(aux(naux),stat=info) -!!$ if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=11) -!!$ if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info) -!!$ if (info /= psb_success_) Then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ q => wwrk(:,1) -!!$ qt => wwrk(:,2) -!!$ r => wwrk(:,3) -!!$ rt => wwrk(:,4) -!!$ p => wwrk(:,5) -!!$ v => wwrk(:,6) -!!$ uv => wwrk(:,7) -!!$ z => wwrk(:,8) -!!$ f => wwrk(:,9) -!!$ s => wwrk(:,10) -!!$ ww => wwrk(:,11) -!!$ -!!$ -!!$ If (Present(itmax)) Then -!!$ itmax_ = itmax -!!$ Else -!!$ itmax_ = 1000 -!!$ Endif -!!$ -!!$ If (Present(itrace)) Then -!!$ itrace_ = itrace -!!$ Else -!!$ itrace_ = 0 -!!$ End If -!!$ -!!$ -!!$ itx = 0 -!!$ -!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ restart: Do -!!$! = -!!$! = r0 = b-ax0 -!!$! = -!!$ if (itx >= itmax_) exit restart -!!$ it = 0 -!!$ call psb_geaxpby(zone,b,zzero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_spmm(-zone,a,x,zone,r,desc_a,info,work=aux) -!!$ if (info == psb_success_) call psb_geaxpby(zone,r,zzero,rt,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ ! Perhaps we already satisfy the convergence criterion... -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ rho = zzero -!!$ -!!$ iteration: do -!!$ it = it + 1 -!!$ itx = itx + 1 -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),'iteration: ',itx -!!$ -!!$ rho_old = rho -!!$ rho = psb_gedot(rt,r,desc_a,info) -!!$ -!!$ if (rho == zzero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' iteration breakdown r',rho -!!$ exit iteration -!!$ endif -!!$ -!!$ if (it == 1) then -!!$ call psb_geaxpby(zone,r,zzero,uv,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(zone,r,zzero,p,desc_a,info) -!!$ else -!!$ beta = (rho/rho_old) -!!$ call psb_geaxpby(zone,r,zzero,uv,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(beta,q,zone,uv,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(zone,q,beta,p,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(zone,uv,beta,p,desc_a,info) -!!$ end if -!!$ -!!$ if (info == psb_success_) call prec%apply(p,f,desc_a,info,work=aux) -!!$ -!!$ if (info == psb_success_) call psb_spmm(zone,a,f,zzero,v,desc_a,info,& -!!$ & work=aux) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='First loop part ') -!!$ goto 9999 -!!$ end if -!!$ -!!$ sigma = psb_gedot(rt,v,desc_a,info) -!!$ if (sigma == zzero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' iteration breakdown s1', sigma -!!$ exit iteration -!!$ endif -!!$ -!!$ alpha = rho/sigma -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(zone,uv,zzero,q,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(-alpha,v,zone,q,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(zone,uv,zzero,s,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(zone,q,zone,s,desc_a,info) -!!$ -!!$ if (info == psb_success_) call prec%apply(s,z,desc_a,info,work=aux) -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(alpha,z,zone,x,desc_a,info) -!!$ -!!$ if (info == psb_success_) call psb_spmm(zone,a,z,zzero,qt,desc_a,info,& -!!$ & work=aux) -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(-alpha,qt,zone,r,desc_a,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='X update ') -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ end do iteration -!!$ end do restart -!!$ -!!$ -!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ deallocate(aux,stat=info) -!!$ if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$end subroutine psb_zcgs - Subroutine psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,istop) use psb_base_mod diff --git a/krylov/psb_zcgstab.f90 b/krylov/psb_zcgstab.f90 index a0e343ad..e11475fe 100644 --- a/krylov/psb_zcgstab.f90 +++ b/krylov/psb_zcgstab.f90 @@ -93,263 +93,6 @@ ! where r is the (preconditioned, recursive ! estimate of) residual. ! -!!$subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_z_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ Implicit None -!!$! = parameters -!!$ Type(psb_zspmat_type), Intent(in) :: a -!!$ class(psb_zprec_type), Intent(in) :: prec -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ complex(psb_dpk_), Intent(in) :: b(:) -!!$ complex(psb_dpk_), Intent(inout) :: x(:) -!!$ Real(psb_dpk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_dpk_), Optional, Intent(out) :: err -!!$! = Local data -!!$ complex(psb_dpk_), allocatable, target :: aux(:),wwrk(:,:) -!!$ complex(psb_dpk_), Pointer :: q(:),& -!!$ & r(:), p(:), v(:), s(:), t(:), z(:), f(:) -!!$ integer(psb_ipk_) :: itmax_, naux, mglob, it,itrace_,& -!!$ & np,me, n_row, n_col -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ integer(psb_ipk_) :: itx, isvch, ictxt, err_act -!!$ integer(psb_ipk_) :: istop_ -!!$ complex(psb_dpk_) :: alpha, beta, rho, rho_old, sigma, omega, tau -!!$ type(psb_itconv_type) :: stopdat -!!$ real(psb_dpk_) :: derr -!!$ character(len=20) :: name -!!$ character(len=*), parameter :: methdname='BiCGStab' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_zcgstab' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ ictxt = desc_a%get_context() -!!$ call psb_info(ictxt, me, np) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ If (Present(istop)) Then -!!$ istop_ = istop -!!$ Else -!!$ istop_ = 2 -!!$ Endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X') -!!$ goto 9999 -!!$ end if -!!$ call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ naux=6*n_col -!!$ allocate(aux(naux),stat=info) -!!$ if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=8) -!!$ if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ Q => WWRK(:,1) -!!$ R => WWRK(:,2) -!!$ P => WWRK(:,3) -!!$ V => WWRK(:,4) -!!$ F => WWRK(:,5) -!!$ S => WWRK(:,6) -!!$ T => WWRK(:,7) -!!$ Z => WWRK(:,8) -!!$ -!!$ if (present(itmax)) then -!!$ itmax_ = itmax -!!$ else -!!$ itmax_ = 1000 -!!$ endif -!!$ -!!$ if (present(itrace)) then -!!$ itrace_ = itrace -!!$ else -!!$ itrace_ = 0 -!!$ end if -!!$ -!!$ itx = 0 -!!$ -!!$ -!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ -!!$ restart: Do -!!$! = -!!$! = r0 = b-Ax0 -!!$! = -!!$ if (itx >= itmax_) exit restart -!!$ it = 0 -!!$ call psb_geaxpby(zone,b,zzero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_spmm(-zone,a,x,zone,r,desc_a,info,work=aux) -!!$ if (info == psb_success_) call psb_geaxpby(zone,r,zzero,q,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ rho = zzero -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' On entry to AMAX: B: ',Size(b) -!!$ -!!$ -!!$ ! Perhaps we already satisfy the convergence criterion... -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ iteration: Do -!!$ it = it + 1 -!!$ itx = itx + 1 -!!$ If (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Iteration: ',itx -!!$ -!!$ rho_old = rho -!!$ rho = psb_gedot(q,r,desc_a,info) -!!$ -!!$ if (rho == zzero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Iteration breakdown R',rho -!!$ exit iteration -!!$ endif -!!$ -!!$ if (it == 1) then -!!$ call psb_geaxpby(zone,r,zzero,p,desc_a,info) -!!$ else -!!$ beta = (rho/rho_old)*(alpha/omega) -!!$ call psb_geaxpby(-omega,v,zone,p,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(zone,r,beta,p,desc_a,info) -!!$ end if -!!$ -!!$ if (info == psb_success_) call prec%apply(p,f,desc_a,info,work=aux) -!!$ -!!$ if (info == psb_success_) call psb_spmm(zone,a,f,zzero,v,desc_a,info,& -!!$ & work=aux) -!!$ -!!$ if (info == psb_success_) sigma = psb_gedot(q,v,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='First step') -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (sigma == zzero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Iteration breakdown S1', sigma -!!$ exit iteration -!!$ endif -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' SIGMA:',sigma -!!$ alpha = rho/sigma -!!$ -!!$ call psb_geaxpby(zone,r,zzero,s,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(-alpha,v,zone,s,desc_a,info) -!!$ if (info == psb_success_) call prec%apply(s,z,desc_a,info,work=aux) -!!$ if (info == psb_success_) call psb_spmm(zone,a,z,zzero,t,desc_a,info,& -!!$ & work=aux) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='Second step ') -!!$ goto 9999 -!!$ end if -!!$ -!!$ sigma = psb_gedot(t,t,desc_a,info) -!!$ if (sigma == zzero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Iteration breakdown S2', sigma -!!$ exit iteration -!!$ endif -!!$ -!!$ tau = psb_gedot(t,s,desc_a,info) -!!$ omega = tau/sigma -!!$ -!!$ if (omega == zzero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Iteration breakdown O',omega -!!$ exit iteration -!!$ endif -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(alpha,f,zone,x,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(omega,z,zone,x,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(zone,s,zzero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(-omega,t,zone,r,desc_a,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='X update ') -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ end do iteration -!!$ end do restart -!!$ -!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ deallocate(aux,stat=info) -!!$ if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error(ictxt) -!!$ return -!!$ end if -!!$ return -!!$ -!!$End Subroutine psb_zcgstab - - Subroutine psb_zcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) use psb_base_mod use psb_prec_mod diff --git a/krylov/psb_zcgstabl.f90 b/krylov/psb_zcgstabl.f90 index 0b55bf3c..bbabdc1f 100644 --- a/krylov/psb_zcgstabl.f90 +++ b/krylov/psb_zcgstabl.f90 @@ -103,311 +103,6 @@ ! ! ! -!!$Subroutine psb_zcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_z_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ implicit none -!!$ -!!$! = parameters -!!$ Type(psb_zspmat_type), Intent(in) :: a -!!$ class(psb_zprec_type), Intent(in) :: prec -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ complex(psb_dpk_), Intent(in) :: b(:) -!!$ complex(psb_dpk_), Intent(inout) :: x(:) -!!$ Real(psb_dpk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_dpk_), Optional, Intent(out) :: err -!!$! = local data -!!$ complex(psb_dpk_), allocatable, target :: aux(:),wwrk(:,:),uh(:,:), rh(:,:) -!!$ complex(psb_dpk_), Pointer :: ww(:), q(:), r(:), rt0(:), p(:), v(:), & -!!$ & s(:), t(:), z(:), f(:), gamma(:), gamma1(:), gamma2(:), taum(:,:), sigma(:) -!!$ -!!$ integer(psb_ipk_) :: itmax_, naux, mglob, it, itrace_,& -!!$ & np,me, n_row, n_col, nl, err_act -!!$ Logical, Parameter :: exchange=.True., noexchange=.False. -!!$ integer(psb_ipk_), Parameter :: irmax = 8 -!!$ integer(psb_ipk_) :: itx, i, isvch, ictxt,istop_,j, int_err(5) -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ complex(psb_dpk_) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,& -!!$ & omega -!!$ type(psb_itconv_type) :: stopdat -!!$ real(psb_dpk_) :: derr -!!$ character(len=20) :: name -!!$ character(len=*), parameter :: methdname='BiCGStab(L)' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_zcgstabl' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ ictxt = desc_a%get_context() -!!$ Call psb_info(ictxt, me, np) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np -!!$ -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ if (present(istop)) then -!!$ istop_ = istop -!!$ else -!!$ istop_ = 2 -!!$ endif -!!$ -!!$ if (present(itmax)) then -!!$ itmax_ = itmax -!!$ else -!!$ itmax_ = 1000 -!!$ endif -!!$ -!!$ if (present(itrace)) then -!!$ itrace_ = itrace -!!$ else -!!$ itrace_ = 0 -!!$ end if -!!$ -!!$ if (present(irst)) then -!!$ nl = irst -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & 'present: irst: ',irst,nl -!!$ else -!!$ nl = 1 -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' not present: irst: ',irst,nl -!!$ endif -!!$ if (nl <=0 ) then -!!$ info=psb_err_invalid_istop_ -!!$ int_err(1)=nl -!!$ err=info -!!$ call psb_errpush(info,name,i_err=int_err) -!!$ goto 9999 -!!$ endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,ione),ione,ione,desc_a,info) -!!$ if (info == psb_success_) call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X/B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ naux=4*n_col -!!$ allocate(aux(naux),gamma(0:nl),gamma1(nl),& -!!$ &gamma2(nl),taum(nl,nl),sigma(nl), stat=info) -!!$ -!!$ if (info /= psb_success_) then -!!$ info=psb_err_alloc_dealloc_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=psb_err_iarg_neg_) -!!$ if (info == psb_success_) Call psb_geall(uh,desc_a,info,n=nl+1,lb=0) -!!$ if (info == psb_success_) Call psb_geall(rh,desc_a,info,n=nl+1,lb=0) -!!$ if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(uh,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(rh,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ q => wwrk(:,1) -!!$ r => wwrk(:,2) -!!$ p => wwrk(:,3) -!!$ v => wwrk(:,4) -!!$ f => wwrk(:,5) -!!$ s => wwrk(:,6) -!!$ t => wwrk(:,7) -!!$ z => wwrk(:,8) -!!$ ww => wwrk(:,9) -!!$ rt0 => wwrk(:,10) -!!$ -!!$ -!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ itx = 0 -!!$ restart: do -!!$! = -!!$! = r0 = b-ax0 -!!$! = -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),' restart: ',itx,it -!!$ if (itx >= itmax_) exit restart -!!$ -!!$ it = 0 -!!$ call psb_geaxpby(zone,b,zzero,r,desc_a,info) -!!$ if (info == psb_success_) call psb_spmm(-zone,a,x,zone,r,desc_a,info,work=aux) -!!$ -!!$ if (info == psb_success_) call prec%apply(r,desc_a,info) -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(zone,r,zzero,rt0,desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(zone,r,zzero,rh(:,0),desc_a,info) -!!$ if (info == psb_success_) call psb_geaxpby(zzero,r,zzero,uh(:,0),desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ rho = zone -!!$ alpha = zzero -!!$ omega = zone -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' on entry to amax: b: ',Size(b) -!!$ -!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ iteration: do -!!$ it = it + nl -!!$ itx = itx + nl -!!$ rho = -omega*rho -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' iteration: ',itx, rho,rh(1,0) -!!$ -!!$ do j = 0, nl -1 -!!$ If (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),'bicg part: ',j, nl -!!$ -!!$ rho_old = rho -!!$ rho = psb_gedot(rh(:,j),rt0,desc_a,info) -!!$ if (rho == zzero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' bi-cgstab iteration breakdown r',rho -!!$ exit iteration -!!$ endif -!!$ -!!$ beta = alpha*rho/rho_old -!!$ rho_old = rho -!!$ call psb_geaxpby(zone,rh(:,0:j),-beta,uh(:,0:j),desc_a,info) -!!$ call psb_spmm(zone,a,uh(:,j),zzero,uh(:,j+1),desc_a,info,work=aux) -!!$ -!!$ call prec%apply(uh(:,j+1),desc_a,info) -!!$ -!!$ gamma(j) = psb_gedot(uh(:,j+1),rt0,desc_a,info) -!!$ -!!$ if (gamma(j) == zzero) then -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' bi-cgstab iteration breakdown s2',gamma(j) -!!$ exit iteration -!!$ endif -!!$ alpha = rho/gamma(j) -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' bicg part: alpha=r/g ',alpha,rho,gamma(j) -!!$ -!!$ call psb_geaxpby(-alpha,uh(:,1:j+1),zone,rh(:,0:j),desc_a,info) -!!$ call psb_geaxpby(alpha,uh(:,0),zone,x,desc_a,info) -!!$ call psb_spmm(zone,a,rh(:,j),zzero,rh(:,j+1),desc_a,info,work=aux) -!!$ -!!$ call prec%apply(rh(:,j+1),desc_a,info) -!!$ -!!$ enddo -!!$ -!!$ do j=1, nl -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' mod g-s part: ',j, nl,rh(1,0) -!!$ -!!$ do i=1, j-1 -!!$ taum(i,j) = psb_gedot(rh(:,i),rh(:,j),desc_a,info) -!!$ taum(i,j) = taum(i,j)/sigma(i) -!!$ call psb_geaxpby(-taum(i,j),rh(:,i),zone,rh(:,j),desc_a,info) -!!$ enddo -!!$ sigma(j) = psb_gedot(rh(:,j),rh(:,j),desc_a,info) -!!$ gamma1(j) = psb_gedot(rh(:,0),rh(:,j),desc_a,info) -!!$ gamma1(j) = gamma1(j)/sigma(j) -!!$ enddo -!!$ -!!$ gamma(nl) = gamma1(nl) -!!$ omega = gamma(nl) -!!$ -!!$ do j=nl-1,1,-1 -!!$ gamma(j) = gamma1(j) -!!$ do i=j+1,nl -!!$ gamma(j) = gamma(j) - taum(j,i) * gamma(i) -!!$ enddo -!!$ enddo -!!$ -!!$ do j=1,nl-1 -!!$ gamma2(j) = gamma(j+1) -!!$ do i=j+1,nl-1 -!!$ gamma2(j) = gamma2(j) + taum(j,i) * gamma(i+1) -!!$ enddo -!!$ enddo -!!$ -!!$ call psb_geaxpby(gamma(1),rh(:,0),zone,x,desc_a,info) -!!$ call psb_geaxpby(-gamma1(nl),rh(:,nl),zone,rh(:,0),desc_a,info) -!!$ call psb_geaxpby(-gamma(nl),uh(:,nl),zone,uh(:,0),desc_a,info) -!!$ -!!$ do j=1, nl-1 -!!$ call psb_geaxpby(-gamma(j),uh(:,j),zone,uh(:,0),desc_a,info) -!!$ call psb_geaxpby(gamma2(j),rh(:,j),zone,x,desc_a,info) -!!$ call psb_geaxpby(-gamma1(j),rh(:,j),zone,rh(:,0),desc_a,info) -!!$ enddo -!!$ -!!$ if (psb_check_conv(methdname,itx,x,rh(:,0),desc_a,stopdat,info)) exit restart -!!$ if (info /= psb_success_) Then -!!$ call psb_errpush(psb_err_from_subroutine_non_,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ end do iteration -!!$ end do restart -!!$ -!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ deallocate(aux,stat=info) -!!$ if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) -!!$ if (info == psb_success_) call psb_gefree(uh,desc_a,info) -!!$ if (info == psb_success_) call psb_gefree(rh,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$End Subroutine psb_zcgstabl -!!$ - - Subroutine psb_zcgstabl_vect(a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,irst,istop) use psb_base_mod diff --git a/krylov/psb_zkrylov.f90 b/krylov/psb_zkrylov.f90 index e1a0456c..3d858e25 100644 --- a/krylov/psb_zkrylov.f90 +++ b/krylov/psb_zkrylov.f90 @@ -33,217 +33,51 @@ ! File: psb_krylov_mod.f90 ! Interfaces for Krylov subspace iterative methods. ! - - ! - ! Subroutine: psb_zkrylov - ! - ! Front-end for the Krylov subspace iterations, complexversion - ! - ! Arguments: - ! - ! methd - character The specific method; can take the values: - ! CG - ! CGS - ! BICG - ! BICGSTAB - ! BICGSTABL - ! RGMRES - ! - ! a - type(psb_zspmat_type) Input: sparse matrix containing A. - ! prec - class(psb_zprec_type) Input: preconditioner - ! b - complex,dimension(:) Input: vector containing the - ! right hand side B - ! x - complex,dimension(:) Input/Output: vector containing the - ! initial guess and final solution X. - ! eps - real Input: Stopping tolerance; the iteration is - ! stopped when the error - ! estimate |err| <= eps - ! - ! desc_a - type(psb_desc_type). Input: The communication descriptor. - ! info - integer. Output: Return code - ! - ! itmax - integer(optional) Input: maximum number of iterations to be - ! performed. - ! iter - integer(optional) Output: how many iterations have been - ! performed. - ! err - real (optional) Output: error estimate on exit - ! itrace - integer(optional) Input: print an informational message - ! with the error estimate every itrace - ! iterations - ! irst - integer(optional) Input: restart parameter for RGMRES and - ! BICGSTAB(L) methods - ! istop - integer(optional) Input: stopping criterion, or how - ! to estimate the error. - ! 1: err = |r|/(|a||x|+|b|) - ! 2: err = |r|/|b| - ! where r is the (preconditioned, recursive - ! estimate of) residual - ! -!!$Subroutine psb_zkrylov(method,a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod,only : psb_sprec_type, psb_dprec_type, psb_zprec_type, psb_zprec_type -!!$ use psb_krylov_mod, psb_protect_name => psb_zkrylov -!!$ character(len=*) :: method -!!$ Type(psb_zspmat_type), Intent(in) :: a -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ class(psb_zprec_type), intent(in) :: prec -!!$ complex(psb_dpk_), Intent(in) :: b(:) -!!$ complex(psb_dpk_), Intent(inout) :: x(:) -!!$ Real(psb_dpk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_dpk_), Optional, Intent(out) :: err -!!$ interface -!!$ subroutine psb_zcg(a,prec,b,x,eps,& -!!$ & desc_a,info,itmax,iter,err,itrace,istop) -!!$ import :: psb_ipk_, psb_dpk_, psb_desc_type, & -!!$ & psb_zspmat_type, psb_zprec_type -!!$ type(psb_zspmat_type), intent(in) :: a -!!$ type(psb_desc_type), intent(in) :: desc_a -!!$ complex(psb_dpk_), intent(in) :: b(:) -!!$ complex(psb_dpk_), intent(inout) :: x(:) -!!$ real(psb_dpk_), intent(in) :: eps -!!$ class(psb_zprec_type), intent(in) :: prec -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), optional, intent(in) :: itmax, itrace,istop -!!$ integer(psb_ipk_), optional, intent(out) :: iter -!!$ real(psb_dpk_), optional, intent(out) :: err -!!$ end subroutine psb_zcg -!!$ subroutine psb_zbicg(a,prec,b,x,eps,& -!!$ & desc_a,info,itmax,iter,err,itrace,istop) -!!$ import :: psb_ipk_, psb_dpk_, psb_desc_type, & -!!$ & psb_zspmat_type, psb_zprec_type -!!$ type(psb_zspmat_type), intent(in) :: a -!!$ type(psb_desc_type), intent(in) :: desc_a -!!$ complex(psb_dpk_), intent(in) :: b(:) -!!$ complex(psb_dpk_), intent(inout) :: x(:) -!!$ real(psb_dpk_), intent(in) :: eps -!!$ class(psb_zprec_type), intent(in) :: prec -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), optional, intent(in) :: itmax, itrace,istop -!!$ integer(psb_ipk_), optional, intent(out) :: iter -!!$ real(psb_dpk_), optional, intent(out) :: err -!!$ end subroutine psb_zbicg -!!$ subroutine psb_zcgstab(a,prec,b,x,eps,& -!!$ & desc_a,info,itmax,iter,err,itrace,istop) -!!$ import :: psb_ipk_, psb_dpk_, psb_desc_type, & -!!$ & psb_zspmat_type, psb_zprec_type -!!$ type(psb_zspmat_type), intent(in) :: a -!!$ type(psb_desc_type), intent(in) :: desc_a -!!$ complex(psb_dpk_), intent(in) :: b(:) -!!$ complex(psb_dpk_), intent(inout) :: x(:) -!!$ real(psb_dpk_), intent(in) :: eps -!!$ class(psb_zprec_type), intent(in) :: prec -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), optional, intent(in) :: itmax, itrace,istop -!!$ integer(psb_ipk_), optional, intent(out) :: iter -!!$ real(psb_dpk_), optional, intent(out) :: err -!!$ end subroutine psb_zcgstab -!!$ Subroutine psb_zcgstabl(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,irst,istop) -!!$ import :: psb_ipk_, psb_dpk_, psb_desc_type, & -!!$ & psb_zspmat_type, psb_zprec_type -!!$ Type(psb_zspmat_type), Intent(in) :: a -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ class(psb_zprec_type), intent(in) :: prec -!!$ complex(psb_dpk_), Intent(in) :: b(:) -!!$ complex(psb_dpk_), Intent(inout) :: x(:) -!!$ Real(psb_dpk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_dpk_), Optional, Intent(out) :: err -!!$ end subroutine psb_zcgstabl -!!$ Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,irst,istop) -!!$ import :: psb_ipk_, psb_dpk_, psb_desc_type, & -!!$ & psb_zspmat_type, psb_zprec_type -!!$ Type(psb_zspmat_type), Intent(in) :: a -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ class(psb_zprec_type), intent(in) :: prec -!!$ complex(psb_dpk_), Intent(in) :: b(:) -!!$ complex(psb_dpk_), Intent(inout) :: x(:) -!!$ Real(psb_dpk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_dpk_), Optional, Intent(out) :: err -!!$ end subroutine psb_zrgmres -!!$ subroutine psb_zcgs(a,prec,b,x,eps,& -!!$ & desc_a,info,itmax,iter,err,itrace,istop) -!!$ import :: psb_ipk_, psb_dpk_, psb_desc_type, & -!!$ & psb_zspmat_type, psb_zprec_type -!!$ type(psb_zspmat_type), intent(in) :: a -!!$ type(psb_desc_type), intent(in) :: desc_a -!!$ complex(psb_dpk_), intent(in) :: b(:) -!!$ complex(psb_dpk_), intent(inout) :: x(:) -!!$ real(psb_dpk_), intent(in) :: eps -!!$ class(psb_zprec_type), intent(in) :: prec -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), optional, intent(in) :: itmax, itrace,istop -!!$ integer(psb_ipk_), optional, intent(out) :: iter -!!$ real(psb_dpk_), optional, intent(out) :: err -!!$ end subroutine psb_zcgs -!!$ end interface -!!$ -!!$ -!!$ integer(psb_ipk_) :: ictxt,me,np,err_act -!!$ character(len=20) :: name -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_krylov' -!!$ call psb_erractionsave(err_act) -!!$ -!!$ -!!$ ictxt=desc_a%get_context() -!!$ -!!$ call psb_info(ictxt, me, np) -!!$ -!!$ -!!$ select case(psb_toupper(method)) -!!$ case('CG') -!!$ call psb_zcg(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,istop) -!!$ case('CGS') -!!$ call psb_zcgs(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,istop) -!!$ case('BICG') -!!$ call psb_zbicg(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,istop) -!!$ case('BICGSTAB') -!!$ call psb_zcgstab(a,prec,b,x,eps,desc_a,info,& -!!$ & itmax,iter,err,itrace,istop) -!!$ case('RGMRES') -!!$ call psb_zrgmres(a,prec,b,x,eps,desc_a,info,& -!!$ & itmax,iter,err,itrace,irst,istop) -!!$ case('BICGSTABL') -!!$ call psb_zcgstabl(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,irst,istop) -!!$ case default -!!$ if (me == 0) write(psb_err_unit,*) trim(name),': Warning: Unknown method ',method,& -!!$ & ', defaulting to BiCGSTAB' -!!$ call psb_zcgstab(a,prec,b,x,eps,desc_a,info,& -!!$ &itmax,iter,err,itrace,istop) -!!$ end select -!!$ -!!$ if(info /= psb_success_) then -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error(ictxt) -!!$ return -!!$ end if -!!$ -!!$end subroutine psb_zkrylov - +! +! Subroutine: psb_zkrylov +! +! Front-end for the Krylov subspace iterations, complexversion +! +! Arguments: +! +! methd - character The specific method; can take the values: +! CG +! CGS +! BICG +! BICGSTAB +! BICGSTABL +! RGMRES +! +! a - type(psb_zspmat_type) Input: sparse matrix containing A. +! prec - class(psb_zprec_type) Input: preconditioner +! b - complex,dimension(:) Input: vector containing the +! right hand side B +! x - complex,dimension(:) Input/Output: vector containing the +! initial guess and final solution X. +! eps - real Input: Stopping tolerance; the iteration is +! stopped when the error +! estimate |err| <= eps +! +! desc_a - type(psb_desc_type). Input: The communication descriptor. +! info - integer. Output: Return code +! +! itmax - integer(optional) Input: maximum number of iterations to be +! performed. +! iter - integer(optional) Output: how many iterations have been +! performed. +! err - real (optional) Output: error estimate on exit +! itrace - integer(optional) Input: print an informational message +! with the error estimate every itrace +! iterations +! irst - integer(optional) Input: restart parameter for RGMRES and +! BICGSTAB(L) methods +! istop - integer(optional) Input: stopping criterion, or how +! to estimate the error. +! 1: err = |r|/(|a||x|+|b|) +! 2: err = |r|/|b| +! where r is the (preconditioned, recursive +! estimate of) residual +! Subroutine psb_zkrylov_vect(method,a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,irst,istop,cond) diff --git a/krylov/psb_zrgmres.f90 b/krylov/psb_zrgmres.f90 index 5852cba9..6cd50562 100644 --- a/krylov/psb_zrgmres.f90 +++ b/krylov/psb_zrgmres.f90 @@ -105,369 +105,6 @@ ! estimate of) residual. ! irst - integer(optional) Input: restart parameter ! -!!$Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop) -!!$ use psb_base_mod -!!$ use psb_prec_mod -!!$ use psb_z_krylov_conv_mod -!!$ use psb_krylov_mod -!!$ implicit none -!!$ -!!$! = Parameters -!!$ Type(psb_zspmat_type), Intent(in) :: a -!!$ class(psb_zprec_type), Intent(in) :: prec -!!$ Type(psb_desc_type), Intent(in) :: desc_a -!!$ complex(psb_dpk_), Intent(in) :: b(:) -!!$ complex(psb_dpk_), Intent(inout) :: x(:) -!!$ Real(psb_dpk_), Intent(in) :: eps -!!$ integer(psb_ipk_), intent(out) :: info -!!$ integer(psb_ipk_), Optional, Intent(in) :: itmax, itrace, irst,istop -!!$ integer(psb_ipk_), Optional, Intent(out) :: iter -!!$ Real(psb_dpk_), Optional, Intent(out) :: err -!!$! = local data -!!$ complex(psb_dpk_), allocatable, target :: aux(:),w(:),w1(:), v(:,:) -!!$ complex(psb_dpk_), allocatable :: c(:),s(:), h(:,:), rs(:),rst(:),xt(:) -!!$ Real(psb_dpk_) :: tmp -!!$ complex(psb_dpk_) :: rti, rti1, scal -!!$ integer(psb_ipk_) ::litmax, naux, mglob, it,k, itrace_,& -!!$ & np,me, n_row, n_col, nl, int_err(5) -!!$ Logical, Parameter :: exchange=.True., noexchange=.False. -!!$ integer(psb_ipk_), Parameter :: irmax = 8 -!!$ integer(psb_ipk_) :: itx, i, isvch, ictxt,istop_, err_act -!!$ integer(psb_ipk_) :: debug_level, debug_unit -!!$ Real(psb_dpk_) :: rni, xni, bni, ani,bn2 -!!$ real(psb_dpk_) :: errnum, errden, deps, derr -!!$ character(len=20) :: name -!!$ character(len=*), parameter :: methdname='RGMRES' -!!$ -!!$ info = psb_success_ -!!$ name = 'psb_zgmres' -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ ictxt = desc_a%get_context() -!!$ Call psb_info(ictxt, me, np) -!!$ if (debug_level >= psb_debug_ext_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np -!!$ -!!$ mglob = desc_a%get_global_rows() -!!$ n_row = desc_a%get_local_rows() -!!$ n_col = desc_a%get_local_cols() -!!$ -!!$ if (present(istop)) then -!!$ istop_ = istop -!!$ else -!!$ istop_ = 2 -!!$ endif -!!$ ! -!!$ ! ISTOP_ = 1: Normwise backward error, infinity norm -!!$ ! ISTOP_ = 2: ||r||/||b||, 2-norm -!!$ ! -!!$ -!!$ if ((istop_ < 1 ).or.(istop_ > 2 ) ) then -!!$ info=psb_err_invalid_istop_ -!!$ int_err(1)=istop_ -!!$ err=info -!!$ call psb_errpush(info,name,i_err=int_err) -!!$ goto 9999 -!!$ endif -!!$ -!!$ if (present(itmax)) then -!!$ litmax = itmax -!!$ else -!!$ litmax = 1000 -!!$ endif -!!$ -!!$ if (present(itrace)) then -!!$ itrace_ = itrace -!!$ else -!!$ itrace_ = 0 -!!$ end if -!!$ -!!$ if (present(irst)) then -!!$ nl = irst -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' present: irst: ',irst,nl -!!$ else -!!$ nl = 10 -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' not present: irst: ',irst,nl -!!$ endif -!!$ if (nl <=0 ) then -!!$ info=psb_err_invalid_istop_ -!!$ int_err(1)=nl -!!$ err=info -!!$ call psb_errpush(info,name,i_err=int_err) -!!$ goto 9999 -!!$ endif -!!$ -!!$ call psb_chkvect(mglob,ione,size(x,1),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on X') -!!$ goto 9999 -!!$ end if -!!$ call psb_chkvect(mglob,ione,size(b,ione),ione,ione,desc_a,info) -!!$ if(info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_chkvect on B') -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ naux=4*n_col -!!$ allocate(aux(naux),h(nl+1,nl+1),& -!!$ &c(nl+1),s(nl+1),rs(nl+1), rst(nl+1),stat=info) -!!$ -!!$ if (info == psb_success_) Call psb_geall(v,desc_a,info,n=nl+1) -!!$ if (info == psb_success_) Call psb_geall(w,desc_a,info) -!!$ if (info == psb_success_) Call psb_geall(w1,desc_a,info) -!!$ if (info == psb_success_) Call psb_geall(xt,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(v,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(w,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(w1,desc_a,info) -!!$ if (info == psb_success_) Call psb_geasb(xt,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Size of V,W,W1 ',size(v),size(v,1),& -!!$ & size(w),size(w,1),size(w1),size(w1,1), size(v(:,1)) -!!$ -!!$ -!!$ if (istop_ == 1) then -!!$ ani = psb_spnrmi(a,desc_a,info) -!!$ bni = psb_geamax(b,desc_a,info) -!!$ else if (istop_ == 2) then -!!$ bn2 = psb_genrm2(b,desc_a,info) -!!$ endif -!!$ errnum = dzero -!!$ errden = done -!!$ deps = eps -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ if ((itrace_ > 0).and.(me == 0)) call log_header(methdname) -!!$ -!!$ itx = 0 -!!$ restart: do -!!$ -!!$ ! compute r0 = b-ax0 -!!$ ! check convergence -!!$ ! compute v1 = r0/||r0||_2 -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' restart: ',itx,it -!!$ it = 0 -!!$ call psb_geaxpby(zone,b,zzero,v(:,1),desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_spmm(-zone,a,x,zone,v(:,1),desc_a,info,work=aux) -!!$ if (info /= psb_success_) Then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ End If -!!$ -!!$ rs(1) = psb_genrm2(v(:,1),desc_a,info) -!!$ rs(2:) = zzero -!!$ if (info /= psb_success_) Then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ scal=done/rs(1) ! rs(1) MIGHT BE VERY SMALL - USE DSCAL TO DEAL WITH IT? -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' on entry to amax: b: ',Size(b),rs(1),scal -!!$ -!!$ ! -!!$ ! check convergence -!!$ ! -!!$ if (istop_ == 1) then -!!$ rni = psb_geamax(v(:,1),desc_a,info) -!!$ xni = psb_geamax(x,desc_a,info) -!!$ errnum = rni -!!$ errden = (ani*xni+bni) -!!$ else if (istop_ == 2) then -!!$ rni = psb_genrm2(v(:,1),desc_a,info) -!!$ errnum = rni -!!$ errden = bn2 -!!$ endif -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (errnum <= deps*errden) exit restart -!!$ -!!$ if (itrace_ > 0) & -!!$ & call log_conv(methdname,me,itx,itrace_,errnum,errden,deps) -!!$ -!!$ v(:,1) = v(:,1) * scal -!!$ -!!$ if (itx >= litmax) exit restart -!!$ -!!$ ! -!!$ ! inner iterations -!!$ ! -!!$ -!!$ inner: Do i=1,nl -!!$ itx = itx + 1 -!!$ -!!$ call prec%apply(v(:,i),w1,desc_a,info) -!!$ Call psb_spmm(zone,a,w1,zzero,w,desc_a,info,work=aux) -!!$ ! -!!$ -!!$ do k = 1, i -!!$ h(k,i) = psb_gedot(v(:,k),w,desc_a,info) -!!$ call psb_geaxpby(-h(k,i),v(:,k),zone,w,desc_a,info) -!!$ end do -!!$ h(i+1,i) = psb_genrm2(w,desc_a,info) -!!$ scal=done/h(i+1,i) -!!$ call psb_geaxpby(scal,w,zzero,v(:,i+1),desc_a,info) -!!$ do k=2,i -!!$ call zrot(1,h(k-1,i),1,h(k,i),1,real(c(k-1)),s(k-1)) -!!$ enddo -!!$ -!!$ rti = h(i,i) -!!$ rti1 = h(i+1,i) -!!$ call zrotg(rti,rti1,tmp,s(i)) -!!$ c(i) = cmplx(tmp,szero) -!!$ call zrot(1,h(i,i),1,h(i+1,i),1,real(c(i)),s(i)) -!!$ h(i+1,i) = zzero -!!$ call zrot(1,rs(i),1,rs(i+1),1,real(c(i)),s(i)) -!!$ -!!$ if (istop_ == 1) then -!!$ ! -!!$ ! build x and then compute the residual and its infinity norm -!!$ ! -!!$ rst = rs -!!$ xt = zzero -!!$ call ztrsm('l','u','n','n',i,1,zone,h,size(h,1),rst,size(rst,1)) -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Rebuild x-> RS:',rst(1:nl) -!!$ do k=1, i -!!$ call psb_geaxpby(rst(k),v(:,k),zone,xt,desc_a,info) -!!$ end do -!!$ call prec%apply(xt,desc_a,info) -!!$ call psb_geaxpby(zone,x,zone,xt,desc_a,info) -!!$ call psb_geaxpby(zone,b,zzero,w1,desc_a,info) -!!$ call psb_spmm(-zone,a,xt,zone,w1,desc_a,info,work=aux) -!!$ rni = psb_geamax(w1,desc_a,info) -!!$ xni = psb_geamax(xt,desc_a,info) -!!$ errnum = rni -!!$ errden = (ani*xni+bni) -!!$ ! -!!$ -!!$ else if (istop_ == 2) then -!!$ ! -!!$ ! compute the residual 2-norm as byproduct of the solution -!!$ ! procedure of the least-squares problem -!!$ ! -!!$ rni = abs(rs(i+1)) -!!$ errnum = rni -!!$ errden = bn2 -!!$ endif -!!$ -!!$ If (errnum <= deps*errden) Then -!!$ -!!$ if (istop_ == 1) then -!!$ x = xt -!!$ else if (istop_ == 2) then -!!$ ! -!!$ ! build x -!!$ ! -!!$ call ztrsm('l','u','n','n',i,1,zone,h,size(h,1),rs,size(rs,1)) -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Rebuild x-> RS:',rs(1:nl) -!!$ w1 = zzero -!!$ do k=1, i -!!$ call psb_geaxpby(rs(k),v(:,k),zone,w1,desc_a,info) -!!$ end do -!!$ call prec%apply(w1,w,desc_a,info) -!!$ call psb_geaxpby(zone,w,zone,x,desc_a,info) -!!$ end if -!!$ -!!$ exit restart -!!$ -!!$ end if -!!$ -!!$ if (itrace_ > 0) & -!!$ & call log_conv(methdname,me,itx,itrace_,errnum,errden,deps) -!!$ -!!$ end do inner -!!$ -!!$ if (istop_ == 1) then -!!$ x = xt -!!$ else if (istop_ == 2) then -!!$ ! -!!$ ! build x -!!$ ! -!!$ call ztrsm('l','u','n','n',nl,1,zone,h,size(h,1),rs,size(rs,1)) -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),& -!!$ & ' Rebuild x-> RS:',rs(1:nl) -!!$ w1 = zzero -!!$ do k=1, nl -!!$ call psb_geaxpby(rs(k),v(:,k),zone,w1,desc_a,info) -!!$ end do -!!$ call prec%apply(w1,w,desc_a,info) -!!$ call psb_geaxpby(zone,w,zone,x,desc_a,info) -!!$ end if -!!$ -!!$ end do restart -!!$ if (itrace_ > 0) & -!!$ & call log_conv(methdname,me,itx,ione,errnum,errden,deps) -!!$ -!!$ call log_end(methdname,me,itx,errnum,errden,deps,err=derr,iter=iter) -!!$ -!!$ if (present(err)) then -!!$ err = derr -!!$ end if -!!$ -!!$ -!!$ deallocate(aux,h,c,s,rs,rst, stat=info) -!!$ if (info == psb_success_) call psb_gefree(v,desc_a,info) -!!$ if (info == psb_success_) call psb_gefree(w,desc_a,info) -!!$ if (info == psb_success_) call psb_gefree(w1,desc_a,info) -!!$ if (info == psb_success_) call psb_gefree(xt,desc_a,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_non_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$End Subroutine psb_zrgmres - - subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,& & itmax,iter,err,itrace,irst,istop) @@ -738,7 +375,7 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,& call ztrsm('l','u','n','n',i,1,zone,h,size(h,1),rst,size(rst,1)) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& - & ' Rebuild x-> RS:',rst(1:nl) + & ' Rebuild x-> RS:',rst(1:i) do k=1, i call psb_geaxpby(rst(k),v(k),zone,xt,desc_a,info) end do @@ -774,7 +411,7 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,& call ztrsm('l','u','n','n',i,1,zone,h,size(h,1),rs,size(rs,1)) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& - & ' Rebuild x-> RS:',rs(1:nl) + & ' Rebuild x-> RS:',rs(1:i) call w1%set(zzero) do k=1, i call psb_geaxpby(rs(k),v(k),zone,w1,desc_a,info)