fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-19 20:32:12 +00:00
Code Issues Packages Projects Releases Wiki Activity

[UPDATE] Removed work/aux buffer from vector routines that use psb_x_vect_type encapsulation for data exchange

Browse Source
This commit is contained in:
Stack-1
2026-03-19 17:36:44 +01:00
parent dc61cbb0a2
commit 461a6a325f
143 changed files with 3051 additions and 3129 deletions
Download Patch File Download Diff File Expand all files Collapse all files
linsolve/impl/psb_cbicg.f90
+8 -15
View File
@@ -112,11 +112,10 @@ subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), optional, intent(out) :: iter
real(psb_spk_), optional, intent(out) :: err
! !$ local data
complex(psb_spk_), allocatable, target :: aux(:)
type(psb_c_vect_type), allocatable, target :: wwrk(:)
type(psb_c_vect_type), pointer :: ww, q, r, p,&
& zt, pt, z, rt, qt
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col, istop_, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@@ -188,14 +187,11 @@ subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,&
end if
naux=4*n_col
allocate(aux(naux),stat=info)
if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=9_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v)
if(info /= psb_success_) then
info=psb_err_from_subroutine_non_
ch_err='psb_asb'
info = psb_err_from_subroutine_non_
ch_err = 'psb_asb'
err=info
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -239,7 +235,7 @@ subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,&
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_spmm(-cone,a,x,cone,r,desc_a,info)
if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),' Done spmm',info
if (info == psb_success_) call psb_geaxpby(cone,r,czero,rt,desc_a,info)
@@ -265,8 +261,8 @@ subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,&
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)
call prec%apply(r,z,desc_a,info)
if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='c')
rho_old = rho
rho = psb_gedot(rt,z,desc_a,info)
@@ -286,10 +282,8 @@ subroutine psb_cbicg_vect(a,prec,b,x,eps,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')
call psb_spmm(cone,a,p,czero,q,desc_a,info)
call psb_spmm(cone,a,pt,czero,qt,desc_a,info,trans='c')
sigma = psb_gedot(pt,q,desc_a,info)
if (sigma == czero) then
@@ -319,7 +313,6 @@ subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
linsolve/impl/psb_ccg.F90
+5 -8
View File
@@ -113,12 +113,12 @@ subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err,cond
! = Local data
complex(psb_spk_), allocatable, target :: aux(:),td(:),tu(:),eig(:),ewrk(:)
complex(psb_spk_), allocatable, target :: td(:),tu(:),eig(:),ewrk(:)
integer(psb_mpk_), allocatable :: ibl(:), ispl(:), iwrk(:)
type(psb_c_vect_type), allocatable, target :: wwrk(:)
type(psb_c_vect_type), pointer :: q, p, r, z, w
complex(psb_spk_) :: alpha, beta, rho, rho_old, sigma,alpha_old,beta_old
integer(psb_ipk_) :: itmax_, istop_, naux, it, itx, itrace_,&
integer(psb_ipk_) :: itmax_, istop_, it, itx, itrace_,&
& n_col, n_row,err_act, ieg,nspl, istebz
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@@ -171,8 +171,6 @@ subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,&
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=5_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v,scratch=.true.)
if (info /= psb_success_) then
@@ -215,7 +213,7 @@ subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,&
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_spmm(-cone,a,x,cone,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@@ -235,7 +233,7 @@ subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,&
it = it + 1
itx = itx + 1
call prec%apply(r,z,desc_a,info,work=aux)
call prec%apply(r,z,desc_a,info)
rho_old = rho
rho = psb_gedot(r,z,desc_a,info)
@@ -252,7 +250,7 @@ subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,&
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)
call psb_spmm(cone,a,p,czero,q,desc_a,info)
sigma = psb_gedot(p,q,desc_a,info)
if (sigma == czero) then
if (debug_level >= psb_debug_ext_)&
@@ -285,7 +283,6 @@ subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
linsolve/impl/psb_ccgs.f90
+6 -12
View File
@@ -110,11 +110,10 @@ Subroutine psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
! = local data
complex(psb_spk_), allocatable, target :: aux(:)
type(psb_c_vect_type), allocatable, target :: wwrk(:)
type(psb_c_vect_type), pointer :: ww, q, r, p, v,&
& s, z, f, rt, qt, uv
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col,istop_, itx, err_act
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
@@ -165,8 +164,6 @@ Subroutine psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,&
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_psb_ipk_)
if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info,mold=x%v)
if (info /= psb_success_) Then
@@ -215,7 +212,7 @@ Subroutine psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,&
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_spmm(-cone,a,x,cone,r,desc_a,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_
@@ -260,10 +257,9 @@ Subroutine psb_ccgs_vect(a,prec,b,x,eps,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 prec%apply(p,f,desc_a,info)
if (info == psb_success_) call psb_spmm(cone,a,f,czero,v,desc_a,info,&
& work=aux)
if (info == psb_success_) call psb_spmm(cone,a,f,czero,v,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='First loop part ')
@@ -285,12 +281,11 @@ Subroutine psb_ccgs_vect(a,prec,b,x,eps,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 prec%apply(s,z,desc_a,info)
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_spmm(cone,a,z,czero,qt,desc_a,info)
if (info == psb_success_) call psb_geaxpby(-alpha,qt,cone,r,desc_a,info)
@@ -312,7 +307,6 @@ Subroutine psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
linsolve/impl/psb_ccgstab.f90
+7 -11
View File
@@ -110,10 +110,10 @@ Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
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_), allocatable, target :: wwrk(:,:)
type(psb_c_vect_type) :: q, r, p, v, s, t, z, f
integer(psb_ipk_) :: itmax_, naux, it,itrace_,&
integer(psb_ipk_) :: itmax_, it,itrace_,&
& n_row, n_col
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@@ -179,8 +179,6 @@ Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_errpush(info,name,a_err='psb_chkvect on B')
goto 9999
end if
naux=6*n_col
if (info == psb_success_) allocate(aux(naux),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
@@ -230,7 +228,7 @@ Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
it = 0
call psb_geaxpby(cone,b,czero,r,desc_a,info)
call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux)
call psb_spmm(-cone,a,x,cone,r,desc_a,info)
call psb_geaxpby(cone,r,czero,q,desc_a,info)
! Perhaps we already satisfy the convergence criterion...
@@ -279,10 +277,9 @@ Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_geaxpby(cone,r,beta,p,desc_a,info)
End If
call prec%apply(p,f,desc_a,info,work=aux)
call prec%apply(p,f,desc_a,info)
call psb_spmm(cone,a,f,czero,v,desc_a,info,&
& work=aux)
call psb_spmm(cone,a,f,czero,v,desc_a,info)
sigma = psb_gedot(q,v,desc_a,info)
@@ -316,8 +313,8 @@ Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
end if
call prec%apply(s,z,desc_a,info,work=aux)
Call psb_spmm(cone,a,z,czero,t,desc_a,info,work=aux)
call prec%apply(s,z,desc_a,info)
Call psb_spmm(cone,a,z,czero,t,desc_a,info)
if(psb_errstatus_fatal()) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='precaply/spmm')
@@ -367,7 +364,6 @@ Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter)
if (present(err)) err = derr
deallocate(aux,stat=info)
call x%sync()
call psb_gefree(q,desc_a,info)
linsolve/impl/psb_ccgstabl.f90
+5 -10
View File
@@ -121,13 +121,13 @@ Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
! = local data
complex(psb_spk_), allocatable, target :: aux(:), gamma(:),&
complex(psb_spk_), allocatable, target :: gamma(:),&
& gamma1(:), gamma2(:), taum(:,:), sigma(:)
type(psb_c_vect_type), allocatable, target :: wwrk(:),uh(:), rh(:)
type(psb_c_vect_type), Pointer :: ww, q, r, rt0, p, v, &
& s, t, z, f
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col, nl, err_act
integer(psb_lpk_) :: mglob
Logical, Parameter :: exchange=.True., noexchange=.False.
@@ -213,10 +213,6 @@ Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,&
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)
@@ -263,7 +259,7 @@ Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,&
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_spmm(-cone,a,x,cone,r,desc_a,info)
if (info == psb_success_) call prec%apply(r,desc_a,info)
@@ -318,7 +314,7 @@ Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,&
! = call psb_geaxpby(cone,rh(:,0:j),-beta,uh(:,0:j),desc_a,info)
call psb_geaxpby(cone,rh(k),-beta,uh(k),desc_a,info)
end do
call psb_spmm(cone,a,uh(j),czero,uh(j+1),desc_a,info,work=aux)
call psb_spmm(cone,a,uh(j),czero,uh(j+1),desc_a,info)
call prec%apply(uh(j+1),desc_a,info)
@@ -340,7 +336,7 @@ Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(-alpha,uh(k+1),cone,rh(k),desc_a,info)
end do
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 psb_spmm(cone,a,rh(j),czero,rh(j+1),desc_a,info)
call prec%apply(rh(j+1),desc_a,info)
@@ -403,7 +399,6 @@ Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,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_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
linsolve/impl/psb_cfcg.F90
+3 -7
View File
@@ -125,12 +125,11 @@ subroutine psb_cfcg_vect(a,prec,b,x,eps,desc_a,info,&
complex(psb_spk_) :: alpha, beta, delta, gamma, theta
real(psb_dpk_) :: derr
integer(psb_ipk_) :: i, idx, nc2l, it, itx, istop_, itmax_, itrace_
integer(psb_ipk_) :: n_col, naux, err_act
integer(psb_ipk_) :: n_col, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
complex(psb_spk_), allocatable, target :: aux(:)
complex(psb_spk_) :: vres(3)
character(len=20) :: name
type(psb_itconv_type) :: stopdat
@@ -177,9 +176,6 @@ subroutine psb_cfcg_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
allocate(aux(naux), stat=info)
if (present(itmax)) then
itmax_ = itmax
@@ -234,7 +230,7 @@ subroutine psb_cfcg_vect(a,prec,b,x,eps,desc_a,info,&
! Apply the preconditioner v=Pr
! Compute w = Av
call prec%apply(r,v,desc_a,info,work=aux)
call prec%apply(r,v,desc_a,info)
if (info == psb_success_) call psb_spmm(cone,a,v,czero,w,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -289,7 +285,7 @@ subroutine psb_cfcg_vect(a,prec,b,x,eps,desc_a,info,&
! Apply the preconditioner v = Pr
! Compute w = Av
call prec%apply(r,v,desc_a,info,work=aux)
call prec%apply(r,v,desc_a,info)
if (info == psb_success_) call psb_spmm(cone,a,v,czero,w,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
linsolve/impl/psb_cgcr.f90
+4 -10
View File
@@ -130,14 +130,13 @@ subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,&
type(psb_c_vect_type) :: r
real(psb_dpk_) :: r_norm, b_norm, a_norm, derr
integer(psb_ipk_) :: n_col, naux, err_act
integer(psb_ipk_) :: n_col, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
integer(psb_ipk_) :: i, j, it, itx, istop_, itmax_, itrace_, nl, m, nrst
complex(psb_spk_) :: hjj
complex(psb_spk_), allocatable, target :: aux(:)
character(len=20) :: name
type(psb_itconv_type) :: stopdat
character(len=*), parameter :: methdname='GCR'
@@ -223,10 +222,6 @@ subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
endif
naux=4*n_col
allocate(aux(naux),h(nl+1,nl+1),&
&c_scale(nl+1),c(nl+1),z(nl+1), alpha(nl+1), stat=info)
h = czero
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
@@ -261,7 +256,7 @@ subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(cone, b, czero, r, desc_a, info)
call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux)
call psb_spmm(-cone,a,x,cone,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@@ -278,9 +273,9 @@ subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,&
it = it + 1
j = it
!Apply preconditioner
call prec%apply(r,z(j),desc_a,info,work=aux)
call prec%apply(r,z(j),desc_a,info)
call psb_spmm(cone,a,z(j),czero,c(1),desc_a,info,work=aux)
call psb_spmm(cone,a,z(j),czero,c(1),desc_a,info)
do i =1, j - 1
h(i,j) = psb_gedot(c_scale(i), c(i), desc_a, info)
@@ -347,7 +342,6 @@ subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_gefree(c(i),desc_a,info)
end do
if (info == psb_success_) deallocate(aux,h,c_scale,z,c,alpha,stat=info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
linsolve/impl/psb_crgmres.f90
+5 -11
View File
@@ -124,13 +124,12 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
! = local data
complex(psb_spk_), allocatable :: aux(:)
complex(psb_spk_), allocatable :: c(:), s(:), h(:,:), rs(:), rst(:)
type(psb_c_vect_type), allocatable :: v(:)
type(psb_c_vect_type) :: w, w1, xt
real(psb_spk_) :: tmp
complex(psb_spk_) :: scal, gm, rti, rti1
integer(psb_ipk_) ::litmax, naux, it, k, itrace_,&
integer(psb_ipk_) ::litmax, it, k, itrace_,&
& n_row, n_col, nl
integer(psb_lpk_) :: mglob
Logical, Parameter :: exchange=.True., noexchange=.False., use_srot=.true.
@@ -230,10 +229,6 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
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)
@@ -266,7 +261,7 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
call psb_spmm(-cone,a,x,cone,v(1),desc_a,info,work=aux)
call psb_spmm(-cone,a,x,cone,v(1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@@ -301,7 +296,7 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
call psb_spmm(-cone,a,x,cone,v(1),desc_a,info,work=aux)
call psb_spmm(-cone,a,x,cone,v(1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@@ -358,7 +353,7 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
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)
call psb_spmm(cone,a,w1,czero,w,desc_a,info)
!
do k = 1, i
@@ -397,7 +392,7 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
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)
call psb_spmm(-cone,a,xt,cone,w1,desc_a,info)
rni = psb_geamax(w1,desc_a,info)
xni = psb_geamax(xt,desc_a,info)
errnum = rni
@@ -490,7 +485,6 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,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_) deallocate(aux,h,c,s,rs,rst, stat=info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
linsolve/impl/psb_crichardson.f90
+6 -10
View File
@@ -91,11 +91,10 @@ Subroutine psb_crichardson_vect(a,prec,b,x,eps,desc_a,info,&
logical :: do_alloc_wrk
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: me,np,err_act
complex(psb_spk_), allocatable, target :: aux(:)
type(psb_c_vect_type), allocatable, target :: wwrk(:)
type(psb_c_vect_type), pointer :: q, p, r, z, w
real(psb_dpk_) :: derr
integer(psb_ipk_) :: itmax_, istop_, naux, it, itx, itrace_,&
integer(psb_ipk_) :: itmax_, istop_, it, itx, itrace_,&
& n_col, n_row,ieg,nspl, istebz
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@@ -155,12 +154,10 @@ Subroutine psb_crichardson_vect(a,prec,b,x,eps,desc_a,info,&
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=5_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v,scratch=.true.)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
info = psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
@@ -171,9 +168,9 @@ Subroutine psb_crichardson_vect(a,prec,b,x,eps,desc_a,info,&
w => wwrk(5)
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_spmm(-cone,a,x,cone,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
info = psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
@@ -186,17 +183,16 @@ Subroutine psb_crichardson_vect(a,prec,b,x,eps,desc_a,info,&
End If
loop: do itx=1,itmax_
call prec%apply(r,z,desc_a,info,work=aux)
call prec%apply(r,z,desc_a,info)
call psb_geaxpby(cone,z,cone,x,desc_a,info)
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_spmm(-cone,a,x,cone,r,desc_a,info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit loop
end do loop
call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter)
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if ((info==psb_success_).and.do_alloc_wrk) call prec%free_wrk(info)
if(info /= psb_success_) then
linsolve/impl/psb_dbicg.f90
+6 -12
View File
@@ -112,11 +112,10 @@ subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), optional, intent(out) :: iter
real(psb_dpk_), optional, intent(out) :: err
! !$ local data
real(psb_dpk_), allocatable, target :: aux(:)
type(psb_d_vect_type), allocatable, target :: wwrk(:)
type(psb_d_vect_type), pointer :: ww, q, r, p,&
& zt, pt, z, rt, qt
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col, istop_, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@@ -188,9 +187,7 @@ subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,&
end if
naux=4*n_col
allocate(aux(naux),stat=info)
if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=9_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v)
if(info /= psb_success_) then
@@ -239,7 +236,7 @@ subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,&
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_spmm(-done,a,x,done,r,desc_a,info)
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)
@@ -265,8 +262,8 @@ subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,&
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)
call prec%apply(r,z,desc_a,info)
if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='c')
rho_old = rho
rho = psb_gedot(rt,z,desc_a,info)
@@ -286,10 +283,8 @@ subroutine psb_dbicg_vect(a,prec,b,x,eps,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')
call psb_spmm(done,a,p,dzero,q,desc_a,info)
call psb_spmm(done,a,pt,dzero,qt,desc_a,info,trans='c')
sigma = psb_gedot(pt,q,desc_a,info)
if (sigma == dzero) then
@@ -319,7 +314,6 @@ subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
linsolve/impl/psb_dcg.F90
+5 -8
View File
@@ -113,12 +113,12 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err,cond
! = Local data
real(psb_dpk_), allocatable, target :: aux(:),td(:),tu(:),eig(:),ewrk(:)
real(psb_dpk_), allocatable, target :: td(:),tu(:),eig(:),ewrk(:)
integer(psb_mpk_), allocatable :: ibl(:), ispl(:), iwrk(:)
type(psb_d_vect_type), allocatable, target :: wwrk(:)
type(psb_d_vect_type), pointer :: q, p, r, z, w
real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma,alpha_old,beta_old
integer(psb_ipk_) :: itmax_, istop_, naux, it, itx, itrace_,&
integer(psb_ipk_) :: itmax_, istop_, it, itx, itrace_,&
& n_col, n_row,err_act, ieg,nspl, istebz
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@@ -171,8 +171,6 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,&
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=5_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v,scratch=.true.)
if (info /= psb_success_) then
@@ -223,7 +221,7 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,&
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_spmm(-done,a,x,done,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@@ -243,7 +241,7 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,&
it = it + 1
itx = itx + 1
call prec%apply(r,z,desc_a,info,work=aux)
call prec%apply(r,z,desc_a,info)
rho_old = rho
rho = psb_gedot(r,z,desc_a,info)
@@ -260,7 +258,7 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,&
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)
call psb_spmm(done,a,p,dzero,q,desc_a,info)
sigma = psb_gedot(p,q,desc_a,info)
if (sigma == dzero) then
if (debug_level >= psb_debug_ext_)&
@@ -318,7 +316,6 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
linsolve/impl/psb_dcgs.f90
+6 -12
View File
@@ -110,11 +110,10 @@ Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
! = local data
real(psb_dpk_), allocatable, target :: aux(:)
type(psb_d_vect_type), allocatable, target :: wwrk(:)
type(psb_d_vect_type), pointer :: ww, q, r, p, v,&
& s, z, f, rt, qt, uv
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col,istop_, itx, err_act
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
@@ -165,8 +164,6 @@ Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,&
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_psb_ipk_)
if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info,mold=x%v)
if (info /= psb_success_) Then
@@ -215,7 +212,7 @@ Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,&
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_spmm(-done,a,x,done,r,desc_a,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_
@@ -260,10 +257,9 @@ Subroutine psb_dcgs_vect(a,prec,b,x,eps,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 prec%apply(p,f,desc_a,info)
if (info == psb_success_) call psb_spmm(done,a,f,dzero,v,desc_a,info,&
& work=aux)
if (info == psb_success_) call psb_spmm(done,a,f,dzero,v,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='First loop part ')
@@ -285,12 +281,11 @@ Subroutine psb_dcgs_vect(a,prec,b,x,eps,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 prec%apply(s,z,desc_a,info)
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_spmm(done,a,z,dzero,qt,desc_a,info)
if (info == psb_success_) call psb_geaxpby(-alpha,qt,done,r,desc_a,info)
@@ -312,7 +307,6 @@ Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
linsolve/impl/psb_dcgstab.f90
+8 -12
View File
@@ -110,11 +110,10 @@ Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
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_), allocatable, target :: wwrk(:,:)
type(psb_d_vect_type) :: q, r, p, v, s, t, z, f
integer(psb_ipk_) :: itmax_, naux, it,itrace_,&
& n_row, n_col
integer(psb_ipk_) :: itmax_, it, itrace_, n_row, n_col
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
Logical, Parameter :: exchange=.True., noexchange=.False., debug1 = .False.
@@ -179,8 +178,7 @@ Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_errpush(info,name,a_err='psb_chkvect on B')
goto 9999
end if
naux=6*n_col
if (info == psb_success_) allocate(aux(naux),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
@@ -230,7 +228,7 @@ Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
it = 0
call psb_geaxpby(done,b,dzero,r,desc_a,info)
call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
call psb_spmm(-done,a,x,done,r,desc_a,info)
call psb_geaxpby(done,r,dzero,q,desc_a,info)
! Perhaps we already satisfy the convergence criterion...
@@ -279,10 +277,9 @@ Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_geaxpby(done,r,beta,p,desc_a,info)
End If
call prec%apply(p,f,desc_a,info,work=aux)
call prec%apply(p,f,desc_a,info)
call psb_spmm(done,a,f,dzero,v,desc_a,info,&
& work=aux)
call psb_spmm(done,a,f,dzero,v,desc_a,info)
sigma = psb_gedot(q,v,desc_a,info)
@@ -316,8 +313,8 @@ Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
end if
call prec%apply(s,z,desc_a,info,work=aux)
Call psb_spmm(done,a,z,dzero,t,desc_a,info,work=aux)
call prec%apply(s,z,desc_a,info)
Call psb_spmm(done,a,z,dzero,t,desc_a,info)
if(psb_errstatus_fatal()) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='precaply/spmm')
@@ -367,7 +364,6 @@ Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter)
if (present(err)) err = derr
deallocate(aux,stat=info)
call x%sync()
call psb_gefree(q,desc_a,info)
linsolve/impl/psb_dcgstabl.f90
+5 -10
View File
@@ -121,13 +121,13 @@ Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
! = local data
real(psb_dpk_), allocatable, target :: aux(:), gamma(:),&
real(psb_dpk_), allocatable, target :: gamma(:),&
& gamma1(:), gamma2(:), taum(:,:), sigma(:)
type(psb_d_vect_type), allocatable, target :: wwrk(:),uh(:), rh(:)
type(psb_d_vect_type), Pointer :: ww, q, r, rt0, p, v, &
& s, t, z, f
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col, nl, err_act
integer(psb_lpk_) :: mglob
Logical, Parameter :: exchange=.True., noexchange=.False.
@@ -213,10 +213,6 @@ Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
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)
@@ -263,7 +259,7 @@ Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
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_spmm(-done,a,x,done,r,desc_a,info)
if (info == psb_success_) call prec%apply(r,desc_a,info)
@@ -318,7 +314,7 @@ Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
! = call psb_geaxpby(done,rh(:,0:j),-beta,uh(:,0:j),desc_a,info)
call psb_geaxpby(done,rh(k),-beta,uh(k),desc_a,info)
end do
call psb_spmm(done,a,uh(j),dzero,uh(j+1),desc_a,info,work=aux)
call psb_spmm(done,a,uh(j),dzero,uh(j+1),desc_a,info)
call prec%apply(uh(j+1),desc_a,info)
@@ -340,7 +336,7 @@ Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(-alpha,uh(k+1),done,rh(k),desc_a,info)
end do
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 psb_spmm(done,a,rh(j),dzero,rh(j+1),desc_a,info)
call prec%apply(rh(j+1),desc_a,info)
@@ -403,7 +399,6 @@ Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,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_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
linsolve/impl/psb_dfcg.F90
+3 -7
View File
@@ -125,12 +125,11 @@ subroutine psb_dfcg_vect(a,prec,b,x,eps,desc_a,info,&
real(psb_dpk_) :: alpha, beta, delta, gamma, theta
real(psb_dpk_) :: derr
integer(psb_ipk_) :: i, idx, nc2l, it, itx, istop_, itmax_, itrace_
integer(psb_ipk_) :: n_col, naux, err_act
integer(psb_ipk_) :: n_col, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
real(psb_dpk_), allocatable, target :: aux(:)
real(psb_dpk_) :: vres(3)
character(len=20) :: name
type(psb_itconv_type) :: stopdat
@@ -177,9 +176,6 @@ subroutine psb_dfcg_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
allocate(aux(naux), stat=info)
if (present(itmax)) then
itmax_ = itmax
@@ -234,7 +230,7 @@ subroutine psb_dfcg_vect(a,prec,b,x,eps,desc_a,info,&
! Apply the preconditioner v=Pr
! Compute w = Av
call prec%apply(r,v,desc_a,info,work=aux)
call prec%apply(r,v,desc_a,info)
if (info == psb_success_) call psb_spmm(done,a,v,dzero,w,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -289,7 +285,7 @@ subroutine psb_dfcg_vect(a,prec,b,x,eps,desc_a,info,&
! Apply the preconditioner v = Pr
! Compute w = Av
call prec%apply(r,v,desc_a,info,work=aux)
call prec%apply(r,v,desc_a,info)
if (info == psb_success_) call psb_spmm(done,a,v,dzero,w,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
linsolve/impl/psb_dgcr.f90
+5 -10
View File
@@ -130,14 +130,13 @@ subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,&
type(psb_d_vect_type) :: r
real(psb_dpk_) :: r_norm, b_norm, a_norm, derr
integer(psb_ipk_) :: n_col, naux, err_act
integer(psb_ipk_) :: n_col, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
integer(psb_ipk_) :: i, j, it, itx, istop_, itmax_, itrace_, nl, m, nrst
real(psb_dpk_) :: hjj
real(psb_dpk_), allocatable, target :: aux(:)
character(len=20) :: name
type(psb_itconv_type) :: stopdat
character(len=*), parameter :: methdname='GCR'
@@ -223,10 +222,6 @@ subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
endif
naux=4*n_col
allocate(aux(naux),h(nl+1,nl+1),&
&c_scale(nl+1),c(nl+1),z(nl+1), alpha(nl+1), stat=info)
h = dzero
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
@@ -261,7 +256,7 @@ subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(done, b, dzero, r, desc_a, info)
call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
call psb_spmm(-done,a,x,done,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@@ -278,9 +273,9 @@ subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,&
it = it + 1
j = it
!Apply preconditioner
call prec%apply(r,z(j),desc_a,info,work=aux)
call prec%apply(r,z(j),desc_a,info)
call psb_spmm(done,a,z(j),dzero,c(1),desc_a,info,work=aux)
call psb_spmm(done,a,z(j),dzero,c(1),desc_a,info)
do i =1, j - 1
h(i,j) = psb_gedot(c_scale(i), c(i), desc_a, info)
@@ -347,7 +342,7 @@ subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_gefree(c(i),desc_a,info)
end do
if (info == psb_success_) deallocate(aux,h,c_scale,z,c,alpha,stat=info)
if (info == psb_success_) deallocate(h,c_scale,z,c,alpha,stat=info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
linsolve/impl/psb_drgmres.f90
+6 -12
View File
@@ -124,13 +124,12 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
! = local data
real(psb_dpk_), allocatable :: aux(:)
real(psb_dpk_), allocatable :: c(:), s(:), h(:,:), rs(:), rst(:)
type(psb_d_vect_type), allocatable :: v(:)
type(psb_d_vect_type) :: w, w1, xt
real(psb_dpk_) :: tmp
real(psb_dpk_) :: scal, gm, rti, rti1
integer(psb_ipk_) ::litmax, naux, it, k, itrace_,&
integer(psb_ipk_) ::litmax, it, k, itrace_,&
& n_row, n_col, nl
integer(psb_lpk_) :: mglob
Logical, Parameter :: exchange=.True., noexchange=.False., use_srot=.true.
@@ -229,11 +228,6 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
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)
@@ -266,7 +260,7 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
call psb_spmm(-done,a,x,done,v(1),desc_a,info,work=aux)
call psb_spmm(-done,a,x,done,v(1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@@ -301,7 +295,7 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
call psb_spmm(-done,a,x,done,v(1),desc_a,info,work=aux)
call psb_spmm(-done,a,x,done,v(1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@@ -358,7 +352,7 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
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)
call psb_spmm(done,a,w1,dzero,w,desc_a,info)
!
do k = 1, i
@@ -397,7 +391,7 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
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)
call psb_spmm(-done,a,xt,done,w1,desc_a,info)
rni = psb_geamax(w1,desc_a,info)
xni = psb_geamax(xt,desc_a,info)
errnum = rni
@@ -490,7 +484,7 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,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_) deallocate(aux,h,c,s,rs,rst, stat=info)
if (info == psb_success_) deallocate(h,c,s,rs,rst, stat=info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
linsolve/impl/psb_drichardson.f90
+5 -9
View File
@@ -91,12 +91,11 @@ Subroutine psb_drichardson_vect(a,prec,b,x,eps,desc_a,info,&
logical :: do_alloc_wrk
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: me,np,err_act
real(psb_dpk_), allocatable, target :: aux(:)
type(psb_d_vect_type), allocatable, target :: wwrk(:)
type(psb_d_vect_type), pointer :: q, p, r, z, w
real(psb_dpk_) :: derr
integer(psb_ipk_) :: itmax_, istop_, naux, it, itx, itrace_,&
& n_col, n_row,ieg,nspl, istebz
integer(psb_ipk_) :: itmax_, istop_, it, itx, itrace_,&
& n_col, n_row,ieg,nspl, istebz
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
type(psb_itconv_type) :: stopdat
@@ -155,8 +154,6 @@ Subroutine psb_drichardson_vect(a,prec,b,x,eps,desc_a,info,&
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=5_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v,scratch=.true.)
if (info /= psb_success_) then
@@ -171,7 +168,7 @@ Subroutine psb_drichardson_vect(a,prec,b,x,eps,desc_a,info,&
w => wwrk(5)
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_spmm(-done,a,x,done,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@@ -186,17 +183,16 @@ Subroutine psb_drichardson_vect(a,prec,b,x,eps,desc_a,info,&
End If
loop: do itx=1,itmax_
call prec%apply(r,z,desc_a,info,work=aux)
call prec%apply(r,z,desc_a,info)
call psb_geaxpby(done,z,done,x,desc_a,info)
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_spmm(-done,a,x,done,r,desc_a,info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit loop
end do loop
call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter)
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if ((info==psb_success_).and.do_alloc_wrk) call prec%free_wrk(info)
if(info /= psb_success_) then
linsolve/impl/psb_sbicg.f90
+6 -14
View File
@@ -112,11 +112,10 @@ subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), optional, intent(out) :: iter
real(psb_spk_), optional, intent(out) :: err
! !$ local data
real(psb_spk_), allocatable, target :: aux(:)
type(psb_s_vect_type), allocatable, target :: wwrk(:)
type(psb_s_vect_type), pointer :: ww, q, r, p,&
& zt, pt, z, rt, qt
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col, istop_, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@@ -187,10 +186,6 @@ subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,&
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_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v)
if(info /= psb_success_) then
@@ -239,7 +234,7 @@ subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,&
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_spmm(-sone,a,x,sone,r,desc_a,info)
if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),' Done spmm',info
if (info == psb_success_) call psb_geaxpby(sone,r,szero,rt,desc_a,info)
@@ -265,8 +260,8 @@ subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,&
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)
call prec%apply(r,z,desc_a,info)
if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='c')
rho_old = rho
rho = psb_gedot(rt,z,desc_a,info)
@@ -286,10 +281,8 @@ subroutine psb_sbicg_vect(a,prec,b,x,eps,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')
call psb_spmm(sone,a,p,szero,q,desc_a,info)
call psb_spmm(sone,a,pt,szero,qt,desc_a,info,trans='c')
sigma = psb_gedot(pt,q,desc_a,info)
if (sigma == szero) then
@@ -319,7 +312,6 @@ subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
linsolve/impl/psb_scg.F90
+5 -8
View File
@@ -113,12 +113,12 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err,cond
! = Local data
real(psb_spk_), allocatable, target :: aux(:),td(:),tu(:),eig(:),ewrk(:)
real(psb_spk_), allocatable, target :: td(:),tu(:),eig(:),ewrk(:)
integer(psb_mpk_), allocatable :: ibl(:), ispl(:), iwrk(:)
type(psb_s_vect_type), allocatable, target :: wwrk(:)
type(psb_s_vect_type), pointer :: q, p, r, z, w
real(psb_spk_) :: alpha, beta, rho, rho_old, sigma,alpha_old,beta_old
integer(psb_ipk_) :: itmax_, istop_, naux, it, itx, itrace_,&
integer(psb_ipk_) :: itmax_, istop_, it, itx, itrace_,&
& n_col, n_row,err_act, ieg,nspl, istebz
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@@ -171,8 +171,6 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,&
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=5_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v,scratch=.true.)
if (info /= psb_success_) then
@@ -223,7 +221,7 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,&
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_spmm(-sone,a,x,sone,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@@ -243,7 +241,7 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,&
it = it + 1
itx = itx + 1
call prec%apply(r,z,desc_a,info,work=aux)
call prec%apply(r,z,desc_a,info)
rho_old = rho
rho = psb_gedot(r,z,desc_a,info)
@@ -260,7 +258,7 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,&
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)
call psb_spmm(sone,a,p,szero,q,desc_a,info)
sigma = psb_gedot(p,q,desc_a,info)
if (sigma == szero) then
if (debug_level >= psb_debug_ext_)&
@@ -318,7 +316,6 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
linsolve/impl/psb_scgs.f90
+6 -12
View File
@@ -110,11 +110,10 @@ Subroutine psb_scgs_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
! = local data
real(psb_spk_), allocatable, target :: aux(:)
type(psb_s_vect_type), allocatable, target :: wwrk(:)
type(psb_s_vect_type), pointer :: ww, q, r, p, v,&
& s, z, f, rt, qt, uv
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col,istop_, itx, err_act
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
@@ -165,8 +164,6 @@ Subroutine psb_scgs_vect(a,prec,b,x,eps,desc_a,info,&
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_psb_ipk_)
if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info,mold=x%v)
if (info /= psb_success_) Then
@@ -215,7 +212,7 @@ Subroutine psb_scgs_vect(a,prec,b,x,eps,desc_a,info,&
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_spmm(-sone,a,x,sone,r,desc_a,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_
@@ -260,10 +257,9 @@ Subroutine psb_scgs_vect(a,prec,b,x,eps,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 prec%apply(p,f,desc_a,info)
if (info == psb_success_) call psb_spmm(sone,a,f,szero,v,desc_a,info,&
& work=aux)
if (info == psb_success_) call psb_spmm(sone,a,f,szero,v,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='First loop part ')
@@ -285,12 +281,11 @@ Subroutine psb_scgs_vect(a,prec,b,x,eps,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 prec%apply(s,z,desc_a,info)
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_spmm(sone,a,z,szero,qt,desc_a,info)
if (info == psb_success_) call psb_geaxpby(-alpha,qt,sone,r,desc_a,info)
@@ -312,7 +307,6 @@ Subroutine psb_scgs_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
linsolve/impl/psb_scgstab.f90
+7 -18
View File
@@ -110,10 +110,10 @@ Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
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_), allocatable, target :: wwrk(:,:)
type(psb_s_vect_type) :: q, r, p, v, s, t, z, f
integer(psb_ipk_) :: itmax_, naux, it,itrace_,&
integer(psb_ipk_) :: itmax_, it,itrace_,&
& n_row, n_col
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@@ -179,14 +179,6 @@ Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_errpush(info,name,a_err='psb_chkvect on B')
goto 9999
end if
naux=6*n_col
if (info == psb_success_) allocate(aux(naux),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
End If
call psb_geasb(q,desc_a,info,mold=x%v,scratch=.true.)
call psb_geasb(r,desc_a,info,mold=x%v,scratch=.true.)
@@ -230,7 +222,7 @@ Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
it = 0
call psb_geaxpby(sone,b,szero,r,desc_a,info)
call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux)
call psb_spmm(-sone,a,x,sone,r,desc_a,info)
call psb_geaxpby(sone,r,szero,q,desc_a,info)
! Perhaps we already satisfy the convergence criterion...
@@ -279,10 +271,9 @@ Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_geaxpby(sone,r,beta,p,desc_a,info)
End If
call prec%apply(p,f,desc_a,info,work=aux)
call prec%apply(p,f,desc_a,info)
call psb_spmm(sone,a,f,szero,v,desc_a,info,&
& work=aux)
call psb_spmm(sone,a,f,szero,v,desc_a,info)
sigma = psb_gedot(q,v,desc_a,info)
@@ -316,8 +307,8 @@ Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
end if
call prec%apply(s,z,desc_a,info,work=aux)
Call psb_spmm(sone,a,z,szero,t,desc_a,info,work=aux)
call prec%apply(s,z,desc_a,info)
Call psb_spmm(sone,a,z,szero,t,desc_a,info)
if(psb_errstatus_fatal()) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='precaply/spmm')
@@ -367,8 +358,6 @@ Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter)
if (present(err)) err = derr
deallocate(aux,stat=info)
call x%sync()
call psb_gefree(q,desc_a,info)
call psb_gefree(r,desc_a,info)
linsolve/impl/psb_scgstabl.f90
+5 -10
View File
@@ -121,13 +121,13 @@ Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
! = local data
real(psb_spk_), allocatable, target :: aux(:), gamma(:),&
real(psb_spk_), allocatable, target :: gamma(:),&
& gamma1(:), gamma2(:), taum(:,:), sigma(:)
type(psb_s_vect_type), allocatable, target :: wwrk(:),uh(:), rh(:)
type(psb_s_vect_type), Pointer :: ww, q, r, rt0, p, v, &
& s, t, z, f
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col, nl, err_act
integer(psb_lpk_) :: mglob
Logical, Parameter :: exchange=.True., noexchange=.False.
@@ -213,10 +213,6 @@ Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,&
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)
@@ -263,7 +259,7 @@ Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,&
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_spmm(-sone,a,x,sone,r,desc_a,info)
if (info == psb_success_) call prec%apply(r,desc_a,info)
@@ -318,7 +314,7 @@ Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,&
! = call psb_geaxpby(sone,rh(:,0:j),-beta,uh(:,0:j),desc_a,info)
call psb_geaxpby(sone,rh(k),-beta,uh(k),desc_a,info)
end do
call psb_spmm(sone,a,uh(j),szero,uh(j+1),desc_a,info,work=aux)
call psb_spmm(sone,a,uh(j),szero,uh(j+1),desc_a,info)
call prec%apply(uh(j+1),desc_a,info)
@@ -340,7 +336,7 @@ Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(-alpha,uh(k+1),sone,rh(k),desc_a,info)
end do
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 psb_spmm(sone,a,rh(j),szero,rh(j+1),desc_a,info)
call prec%apply(rh(j+1),desc_a,info)
@@ -403,7 +399,6 @@ Subroutine psb_scgstabl_vect(a,prec,b,x,eps,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_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
linsolve/impl/psb_sfcg.F90
+3 -7
View File
@@ -125,12 +125,11 @@ subroutine psb_sfcg_vect(a,prec,b,x,eps,desc_a,info,&
real(psb_spk_) :: alpha, beta, delta, gamma, theta
real(psb_dpk_) :: derr
integer(psb_ipk_) :: i, idx, nc2l, it, itx, istop_, itmax_, itrace_
integer(psb_ipk_) :: n_col, naux, err_act
integer(psb_ipk_) :: n_col, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
real(psb_spk_), allocatable, target :: aux(:)
real(psb_spk_) :: vres(3)
character(len=20) :: name
type(psb_itconv_type) :: stopdat
@@ -177,9 +176,6 @@ subroutine psb_sfcg_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
allocate(aux(naux), stat=info)
if (present(itmax)) then
itmax_ = itmax
@@ -234,7 +230,7 @@ subroutine psb_sfcg_vect(a,prec,b,x,eps,desc_a,info,&
! Apply the preconditioner v=Pr
! Compute w = Av
call prec%apply(r,v,desc_a,info,work=aux)
call prec%apply(r,v,desc_a,info)
if (info == psb_success_) call psb_spmm(sone,a,v,szero,w,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -289,7 +285,7 @@ subroutine psb_sfcg_vect(a,prec,b,x,eps,desc_a,info,&
! Apply the preconditioner v = Pr
! Compute w = Av
call prec%apply(r,v,desc_a,info,work=aux)
call prec%apply(r,v,desc_a,info)
if (info == psb_success_) call psb_spmm(sone,a,v,szero,w,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
linsolve/impl/psb_sgcr.f90
+6 -15
View File
@@ -130,14 +130,13 @@ subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,&
type(psb_s_vect_type) :: r
real(psb_dpk_) :: r_norm, b_norm, a_norm, derr
integer(psb_ipk_) :: n_col, naux, err_act
integer(psb_ipk_) :: n_col, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
integer(psb_ipk_) :: i, j, it, itx, istop_, itmax_, itrace_, nl, m, nrst
real(psb_spk_) :: hjj
real(psb_spk_), allocatable, target :: aux(:)
character(len=20) :: name
type(psb_itconv_type) :: stopdat
character(len=*), parameter :: methdname='GCR'
@@ -223,17 +222,9 @@ subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
endif
naux=4*n_col
allocate(aux(naux),h(nl+1,nl+1),&
&c_scale(nl+1),c(nl+1),z(nl+1), alpha(nl+1), stat=info)
h = szero
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
call psb_geasb(r, desc_a,info, scratch=.true.,mold=x%v)
do i =1,nl+1
@@ -261,7 +252,7 @@ subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(sone, b, szero, r, desc_a, info)
call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux)
call psb_spmm(-sone,a,x,sone,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@@ -278,9 +269,9 @@ subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,&
it = it + 1
j = it
!Apply preconditioner
call prec%apply(r,z(j),desc_a,info,work=aux)
call prec%apply(r,z(j),desc_a,info)
call psb_spmm(sone,a,z(j),szero,c(1),desc_a,info,work=aux)
call psb_spmm(sone,a,z(j),szero,c(1),desc_a,info)
do i =1, j - 1
h(i,j) = psb_gedot(c_scale(i), c(i), desc_a, info)
@@ -347,7 +338,7 @@ subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_gefree(c(i),desc_a,info)
end do
if (info == psb_success_) deallocate(aux,h,c_scale,z,c,alpha,stat=info)
if (info == psb_success_) deallocate(h,c_scale,z,c,alpha,stat=info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
linsolve/impl/psb_srgmres.f90
+6 -12
View File
@@ -124,13 +124,12 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
! = local data
real(psb_spk_), allocatable :: aux(:)
real(psb_spk_), allocatable :: c(:), s(:), h(:,:), rs(:), rst(:)
type(psb_s_vect_type), allocatable :: v(:)
type(psb_s_vect_type) :: w, w1, xt
real(psb_spk_) :: tmp
real(psb_spk_) :: scal, gm, rti, rti1
integer(psb_ipk_) ::litmax, naux, it, k, itrace_,&
integer(psb_ipk_) ::litmax, it, k, itrace_,&
& n_row, n_col, nl
integer(psb_lpk_) :: mglob
Logical, Parameter :: exchange=.True., noexchange=.False., use_srot=.true.
@@ -229,11 +228,6 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
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)
@@ -266,7 +260,7 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
call psb_spmm(-sone,a,x,sone,v(1),desc_a,info,work=aux)
call psb_spmm(-sone,a,x,sone,v(1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@@ -301,7 +295,7 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
call psb_spmm(-sone,a,x,sone,v(1),desc_a,info,work=aux)
call psb_spmm(-sone,a,x,sone,v(1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@@ -358,7 +352,7 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
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)
call psb_spmm(sone,a,w1,szero,w,desc_a,info)
!
do k = 1, i
@@ -397,7 +391,7 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
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)
call psb_spmm(-sone,a,xt,sone,w1,desc_a,info)
rni = psb_geamax(w1,desc_a,info)
xni = psb_geamax(xt,desc_a,info)
errnum = rni
@@ -490,7 +484,7 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,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_) deallocate(aux,h,c,s,rs,rst, stat=info)
if (info == psb_success_) deallocate(h,c,s,rs,rst, stat=info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
linsolve/impl/psb_srichardson.f90
+4 -8
View File
@@ -91,11 +91,10 @@ Subroutine psb_srichardson_vect(a,prec,b,x,eps,desc_a,info,&
logical :: do_alloc_wrk
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: me,np,err_act
real(psb_spk_), allocatable, target :: aux(:)
type(psb_s_vect_type), allocatable, target :: wwrk(:)
type(psb_s_vect_type), pointer :: q, p, r, z, w
real(psb_dpk_) :: derr
integer(psb_ipk_) :: itmax_, istop_, naux, it, itx, itrace_,&
integer(psb_ipk_) :: itmax_, istop_, it, itx, itrace_,&
& n_col, n_row,ieg,nspl, istebz
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@@ -155,8 +154,6 @@ Subroutine psb_srichardson_vect(a,prec,b,x,eps,desc_a,info,&
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=5_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v,scratch=.true.)
if (info /= psb_success_) then
@@ -171,7 +168,7 @@ Subroutine psb_srichardson_vect(a,prec,b,x,eps,desc_a,info,&
w => wwrk(5)
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_spmm(-sone,a,x,sone,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@@ -186,17 +183,16 @@ Subroutine psb_srichardson_vect(a,prec,b,x,eps,desc_a,info,&
End If
loop: do itx=1,itmax_
call prec%apply(r,z,desc_a,info,work=aux)
call prec%apply(r,z,desc_a,info)
call psb_geaxpby(sone,z,sone,x,desc_a,info)
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_spmm(-sone,a,x,sone,r,desc_a,info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit loop
end do loop
call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter)
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if ((info==psb_success_).and.do_alloc_wrk) call prec%free_wrk(info)
if(info /= psb_success_) then
linsolve/impl/psb_zbicg.f90
+6 -13
View File
@@ -112,11 +112,10 @@ subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), optional, intent(out) :: iter
real(psb_dpk_), optional, intent(out) :: err
! !$ local data
complex(psb_dpk_), allocatable, target :: aux(:)
type(psb_z_vect_type), allocatable, target :: wwrk(:)
type(psb_z_vect_type), pointer :: ww, q, r, p,&
& zt, pt, z, rt, qt
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col, istop_, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@@ -188,9 +187,6 @@ subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,&
end if
naux=4*n_col
allocate(aux(naux),stat=info)
if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=9_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v)
if(info /= psb_success_) then
@@ -239,7 +235,7 @@ subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,&
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_spmm(-zone,a,x,zone,r,desc_a,info)
if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),' Done spmm',info
if (info == psb_success_) call psb_geaxpby(zone,r,zzero,rt,desc_a,info)
@@ -265,8 +261,8 @@ subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,&
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)
call prec%apply(r,z,desc_a,info)
if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='c')
rho_old = rho
rho = psb_gedot(rt,z,desc_a,info)
@@ -286,10 +282,8 @@ subroutine psb_zbicg_vect(a,prec,b,x,eps,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')
call psb_spmm(zone,a,p,zzero,q,desc_a,info)
call psb_spmm(zone,a,pt,zzero,qt,desc_a,info,trans='c')
sigma = psb_gedot(pt,q,desc_a,info)
if (sigma == zzero) then
@@ -319,7 +313,6 @@ subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
linsolve/impl/psb_zcg.F90
+5 -8
View File
@@ -113,12 +113,12 @@ subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err,cond
! = Local data
complex(psb_dpk_), allocatable, target :: aux(:),td(:),tu(:),eig(:),ewrk(:)
complex(psb_dpk_), allocatable, target :: td(:),tu(:),eig(:),ewrk(:)
integer(psb_mpk_), allocatable :: ibl(:), ispl(:), iwrk(:)
type(psb_z_vect_type), allocatable, target :: wwrk(:)
type(psb_z_vect_type), pointer :: q, p, r, z, w
complex(psb_dpk_) :: alpha, beta, rho, rho_old, sigma,alpha_old,beta_old
integer(psb_ipk_) :: itmax_, istop_, naux, it, itx, itrace_,&
integer(psb_ipk_) :: itmax_, istop_, it, itx, itrace_,&
& n_col, n_row,err_act, ieg,nspl, istebz
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@@ -171,8 +171,6 @@ subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,&
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=5_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v,scratch=.true.)
if (info /= psb_success_) then
@@ -215,7 +213,7 @@ subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,&
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_spmm(-zone,a,x,zone,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@@ -235,7 +233,7 @@ subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,&
it = it + 1
itx = itx + 1
call prec%apply(r,z,desc_a,info,work=aux)
call prec%apply(r,z,desc_a,info)
rho_old = rho
rho = psb_gedot(r,z,desc_a,info)
@@ -252,7 +250,7 @@ subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,&
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)
call psb_spmm(zone,a,p,zzero,q,desc_a,info)
sigma = psb_gedot(p,q,desc_a,info)
if (sigma == zzero) then
if (debug_level >= psb_debug_ext_)&
@@ -285,7 +283,6 @@ subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
linsolve/impl/psb_zcgs.f90
+6 -12
View File
@@ -110,11 +110,10 @@ Subroutine psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
! = local data
complex(psb_dpk_), allocatable, target :: aux(:)
type(psb_z_vect_type), allocatable, target :: wwrk(:)
type(psb_z_vect_type), pointer :: ww, q, r, p, v,&
& s, z, f, rt, qt, uv
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col,istop_, itx, err_act
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
@@ -165,8 +164,6 @@ Subroutine psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,&
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_psb_ipk_)
if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info,mold=x%v)
if (info /= psb_success_) Then
@@ -215,7 +212,7 @@ Subroutine psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,&
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_spmm(-zone,a,x,zone,r,desc_a,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_
@@ -260,10 +257,9 @@ Subroutine psb_zcgs_vect(a,prec,b,x,eps,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 prec%apply(p,f,desc_a,info)
if (info == psb_success_) call psb_spmm(zone,a,f,zzero,v,desc_a,info,&
& work=aux)
if (info == psb_success_) call psb_spmm(zone,a,f,zzero,v,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='First loop part ')
@@ -285,12 +281,11 @@ Subroutine psb_zcgs_vect(a,prec,b,x,eps,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 prec%apply(s,z,desc_a,info)
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_spmm(zone,a,z,zzero,qt,desc_a,info)
if (info == psb_success_) call psb_geaxpby(-alpha,qt,zone,r,desc_a,info)
@@ -312,7 +307,6 @@ Subroutine psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
linsolve/impl/psb_zcgstab.f90
+7 -17
View File
@@ -110,10 +110,10 @@ Subroutine psb_zcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
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_), allocatable, target :: wwrk(:,:)
type(psb_z_vect_type) :: q, r, p, v, s, t, z, f
integer(psb_ipk_) :: itmax_, naux, it,itrace_,&
integer(psb_ipk_) :: itmax_, it,itrace_,&
& n_row, n_col
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@@ -179,13 +179,6 @@ Subroutine psb_zcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_errpush(info,name,a_err='psb_chkvect on B')
goto 9999
end if
naux=6*n_col
if (info == psb_success_) allocate(aux(naux),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
End If
call psb_geasb(q,desc_a,info,mold=x%v,scratch=.true.)
@@ -230,7 +223,7 @@ Subroutine psb_zcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
it = 0
call psb_geaxpby(zone,b,zzero,r,desc_a,info)
call psb_spmm(-zone,a,x,zone,r,desc_a,info,work=aux)
call psb_spmm(-zone,a,x,zone,r,desc_a,info)
call psb_geaxpby(zone,r,zzero,q,desc_a,info)
! Perhaps we already satisfy the convergence criterion...
@@ -279,10 +272,9 @@ Subroutine psb_zcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_geaxpby(zone,r,beta,p,desc_a,info)
End If
call prec%apply(p,f,desc_a,info,work=aux)
call prec%apply(p,f,desc_a,info)
call psb_spmm(zone,a,f,zzero,v,desc_a,info,&
& work=aux)
call psb_spmm(zone,a,f,zzero,v,desc_a,info)
sigma = psb_gedot(q,v,desc_a,info)
@@ -316,8 +308,8 @@ Subroutine psb_zcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
end if
call prec%apply(s,z,desc_a,info,work=aux)
Call psb_spmm(zone,a,z,zzero,t,desc_a,info,work=aux)
call prec%apply(s,z,desc_a,info)
Call psb_spmm(zone,a,z,zzero,t,desc_a,info)
if(psb_errstatus_fatal()) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='precaply/spmm')
@@ -367,8 +359,6 @@ Subroutine psb_zcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter)
if (present(err)) err = derr
deallocate(aux,stat=info)
call x%sync()
call psb_gefree(q,desc_a,info)
call psb_gefree(r,desc_a,info)
linsolve/impl/psb_zcgstabl.f90
+5 -10
View File
@@ -121,13 +121,13 @@ Subroutine psb_zcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
! = local data
complex(psb_dpk_), allocatable, target :: aux(:), gamma(:),&
complex(psb_dpk_), allocatable, target :: gamma(:),&
& gamma1(:), gamma2(:), taum(:,:), sigma(:)
type(psb_z_vect_type), allocatable, target :: wwrk(:),uh(:), rh(:)
type(psb_z_vect_type), Pointer :: ww, q, r, rt0, p, v, &
& s, t, z, f
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col, nl, err_act
integer(psb_lpk_) :: mglob
Logical, Parameter :: exchange=.True., noexchange=.False.
@@ -213,10 +213,6 @@ Subroutine psb_zcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
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)
@@ -263,7 +259,7 @@ Subroutine psb_zcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
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_spmm(-zone,a,x,zone,r,desc_a,info)
if (info == psb_success_) call prec%apply(r,desc_a,info)
@@ -318,7 +314,7 @@ Subroutine psb_zcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
! = call psb_geaxpby(zone,rh(:,0:j),-beta,uh(:,0:j),desc_a,info)
call psb_geaxpby(zone,rh(k),-beta,uh(k),desc_a,info)
end do
call psb_spmm(zone,a,uh(j),zzero,uh(j+1),desc_a,info,work=aux)
call psb_spmm(zone,a,uh(j),zzero,uh(j+1),desc_a,info)
call prec%apply(uh(j+1),desc_a,info)
@@ -340,7 +336,7 @@ Subroutine psb_zcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(-alpha,uh(k+1),zone,rh(k),desc_a,info)
end do
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 psb_spmm(zone,a,rh(j),zzero,rh(j+1),desc_a,info)
call prec%apply(rh(j+1),desc_a,info)
@@ -403,7 +399,6 @@ Subroutine psb_zcgstabl_vect(a,prec,b,x,eps,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_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
linsolve/impl/psb_zfcg.F90
+3 -8
View File
@@ -125,12 +125,11 @@ subroutine psb_zfcg_vect(a,prec,b,x,eps,desc_a,info,&
complex(psb_dpk_) :: alpha, beta, delta, gamma, theta
real(psb_dpk_) :: derr
integer(psb_ipk_) :: i, idx, nc2l, it, itx, istop_, itmax_, itrace_
integer(psb_ipk_) :: n_col, naux, err_act
integer(psb_ipk_) :: n_col, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
complex(psb_dpk_), allocatable, target :: aux(:)
complex(psb_dpk_) :: vres(3)
character(len=20) :: name
type(psb_itconv_type) :: stopdat
@@ -177,10 +176,6 @@ subroutine psb_zfcg_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
allocate(aux(naux), stat=info)
if (present(itmax)) then
itmax_ = itmax
else
@@ -234,7 +229,7 @@ subroutine psb_zfcg_vect(a,prec,b,x,eps,desc_a,info,&
! Apply the preconditioner v=Pr
! Compute w = Av
call prec%apply(r,v,desc_a,info,work=aux)
call prec%apply(r,v,desc_a,info)
if (info == psb_success_) call psb_spmm(zone,a,v,zzero,w,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -289,7 +284,7 @@ subroutine psb_zfcg_vect(a,prec,b,x,eps,desc_a,info,&
! Apply the preconditioner v = Pr
! Compute w = Av
call prec%apply(r,v,desc_a,info,work=aux)
call prec%apply(r,v,desc_a,info)
if (info == psb_success_) call psb_spmm(zone,a,v,zzero,w,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
linsolve/impl/psb_zgcr.f90
+5 -15
View File
@@ -130,14 +130,13 @@ subroutine psb_zgcr_vect(a,prec,b,x,eps,desc_a,info,&
type(psb_z_vect_type) :: r
real(psb_dpk_) :: r_norm, b_norm, a_norm, derr
integer(psb_ipk_) :: n_col, naux, err_act
integer(psb_ipk_) :: n_col, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
integer(psb_ipk_) :: i, j, it, itx, istop_, itmax_, itrace_, nl, m, nrst
complex(psb_dpk_) :: hjj
complex(psb_dpk_), allocatable, target :: aux(:)
character(len=20) :: name
type(psb_itconv_type) :: stopdat
character(len=*), parameter :: methdname='GCR'
@@ -223,16 +222,7 @@ subroutine psb_zgcr_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
endif
naux=4*n_col
allocate(aux(naux),h(nl+1,nl+1),&
&c_scale(nl+1),c(nl+1),z(nl+1), alpha(nl+1), stat=info)
h = zzero
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
call psb_geasb(r, desc_a,info, scratch=.true.,mold=x%v)
@@ -261,7 +251,7 @@ subroutine psb_zgcr_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(zone, b, zzero, r, desc_a, info)
call psb_spmm(-zone,a,x,zone,r,desc_a,info,work=aux)
call psb_spmm(-zone,a,x,zone,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@@ -278,9 +268,9 @@ subroutine psb_zgcr_vect(a,prec,b,x,eps,desc_a,info,&
it = it + 1
j = it
!Apply preconditioner
call prec%apply(r,z(j),desc_a,info,work=aux)
call prec%apply(r,z(j),desc_a,info)
call psb_spmm(zone,a,z(j),zzero,c(1),desc_a,info,work=aux)
call psb_spmm(zone,a,z(j),zzero,c(1),desc_a,info)
do i =1, j - 1
h(i,j) = psb_gedot(c_scale(i), c(i), desc_a, info)
@@ -347,7 +337,7 @@ subroutine psb_zgcr_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_gefree(c(i),desc_a,info)
end do
if (info == psb_success_) deallocate(aux,h,c_scale,z,c,alpha,stat=info)
if (info == psb_success_) deallocate(h,c_scale,z,c,alpha,stat=info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
linsolve/impl/psb_zrgmres.f90
+6 -12
View File
@@ -124,13 +124,12 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
! = local data
complex(psb_dpk_), allocatable :: aux(:)
complex(psb_dpk_), allocatable :: c(:), s(:), h(:,:), rs(:), rst(:)
type(psb_z_vect_type), allocatable :: v(:)
type(psb_z_vect_type) :: w, w1, xt
real(psb_dpk_) :: tmp
complex(psb_dpk_) :: scal, gm, rti, rti1
integer(psb_ipk_) ::litmax, naux, it, k, itrace_,&
integer(psb_ipk_) ::litmax, it, k, itrace_,&
& n_row, n_col, nl
integer(psb_lpk_) :: mglob
Logical, Parameter :: exchange=.True., noexchange=.False., use_srot=.true.
@@ -229,11 +228,6 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,&
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)
@@ -266,7 +260,7 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
call psb_spmm(-zone,a,x,zone,v(1),desc_a,info,work=aux)
call psb_spmm(-zone,a,x,zone,v(1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@@ -301,7 +295,7 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
call psb_spmm(-zone,a,x,zone,v(1),desc_a,info,work=aux)
call psb_spmm(-zone,a,x,zone,v(1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@@ -358,7 +352,7 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,&
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)
call psb_spmm(zone,a,w1,zzero,w,desc_a,info)
!
do k = 1, i
@@ -397,7 +391,7 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,&
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)
call psb_spmm(-zone,a,xt,zone,w1,desc_a,info)
rni = psb_geamax(w1,desc_a,info)
xni = psb_geamax(xt,desc_a,info)
errnum = rni
@@ -490,7 +484,7 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,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_) deallocate(aux,h,c,s,rs,rst, stat=info)
if (info == psb_success_) deallocate(h,c,s,rs,rst, stat=info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
linsolve/impl/psb_zrichardson.f90
+4 -8
View File
@@ -91,11 +91,10 @@ Subroutine psb_zrichardson_vect(a,prec,b,x,eps,desc_a,info,&
logical :: do_alloc_wrk
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: me,np,err_act
complex(psb_dpk_), allocatable, target :: aux(:)
type(psb_z_vect_type), allocatable, target :: wwrk(:)
type(psb_z_vect_type), pointer :: q, p, r, z, w
real(psb_dpk_) :: derr
integer(psb_ipk_) :: itmax_, istop_, naux, it, itx, itrace_,&
integer(psb_ipk_) :: itmax_, istop_, it, itx, itrace_,&
& n_col, n_row,ieg,nspl, istebz
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@@ -155,8 +154,6 @@ Subroutine psb_zrichardson_vect(a,prec,b,x,eps,desc_a,info,&
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=5_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v,scratch=.true.)
if (info /= psb_success_) then
@@ -171,7 +168,7 @@ Subroutine psb_zrichardson_vect(a,prec,b,x,eps,desc_a,info,&
w => wwrk(5)
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_spmm(-zone,a,x,zone,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@@ -186,17 +183,16 @@ Subroutine psb_zrichardson_vect(a,prec,b,x,eps,desc_a,info,&
End If
loop: do itx=1,itmax_
call prec%apply(r,z,desc_a,info,work=aux)
call prec%apply(r,z,desc_a,info)
call psb_geaxpby(zone,z,zone,x,desc_a,info)
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_spmm(-zone,a,x,zone,r,desc_a,info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit loop
end do loop
call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter)
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if ((info==psb_success_).and.do_alloc_wrk) call prec%free_wrk(info)
if(info /= psb_success_) then