fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Cleaned source code.

Browse Source
psblas3-type-indexed
Salvatore Filippone 17 years ago
parent bc980ed5d6
commit 7f758de51c
10 changed files with 613 additions and 714 deletions
Show Stats Download Patch File Download Diff File

64
krylov/psb_dbicg.f90
Unescape Escape View File

@ -96,6 +96,7 @@
subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
use psb_base_mod use psb_base_mod
use psb_prec_mod use psb_prec_mod
use psb_krylov_mod, psb_protect_name => psb_dbicg
implicit none implicit none
!!$ parameters !!$ parameters
@ -124,6 +125,7 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
& sigma,bn2 & sigma,bn2
real(kind(1.d0)) :: errnum, errden real(kind(1.d0)) :: errnum, errden
character(len=20) :: name,ch_err character(len=20) :: name,ch_err
character(len=*), parameter :: methdname='BiCG'
info = 0 info = 0
name = 'psb_dbicg' name = 'psb_dbicg'
@ -181,7 +183,7 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
allocate(aux(naux),stat=info) allocate(aux(naux),stat=info)
if (info == 0) call psb_geall(wwrk,desc_a,info,n=9) if (info == 0) call psb_geall(wwrk,desc_a,info,n=9)
if (info == 0) call psb_geasb(wwrk,desc_a,info) if (info == 0) call psb_geasb(wwrk,desc_a,info)
if(info.ne.0) then if(info /= 0) then
info=4011 info=4011
ch_err='psb_asb' ch_err='psb_asb'
err=info err=info
@ -222,7 +224,7 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
errnum = dzero errnum = dzero
errden = done errden = done
if(info.ne.0) then if(info /= 0) then
info=4011 info=4011
err=info err=info
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -233,14 +235,14 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
!!$ !!$
!!$ r0 = b-ax0 !!$ r0 = b-ax0
!!$ !!$
if (itx.ge.litmax) exit restart if (itx >= litmax) exit restart
it = 0 it = 0
call psb_geaxpby(done,b,dzero,r,desc_a,info) call psb_geaxpby(done,b,dzero,r,desc_a,info)
if (info == 0) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux) if (info == 0) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
if (debug_level >= psb_debug_ext_)& if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),' Done spmm',info & write(debug_unit,*) me,' ',trim(name),' Done spmm',info
if (info == 0) call psb_geaxpby(done,r,dzero,rt,desc_a,info) if (info == 0) call psb_geaxpby(done,r,dzero,rt,desc_a,info)
if(info.ne.0) then if(info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -255,7 +257,7 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
else if (istop_ == 2) then else if (istop_ == 2) then
rni = psb_genrm2(r,desc_a,info) rni = psb_genrm2(r,desc_a,info)
endif endif
if(info.ne.0) then if(info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -270,20 +272,16 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
errden = bn2 errden = bn2
endif endif
if(info.ne.0) then if(info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if (errnum <= eps*errden) Then if (errnum <= eps*errden) exit restart
exit restart
end if
If (itrace_ > 0) then
if ((mod(itx,itrace_)==0).and.(me == 0))&
& write(*,'(a,i4,3(2x,es10.4))') 'bicg: ',itx,errnum,eps*errden
end If
if (itrace_ > 0) &
& call log_conv(methdname,me,itx,itrace_,errnum,errden,eps)
iteration: do iteration: do
it = it + 1 it = it + 1
@ -343,21 +341,19 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
errnum = rni errnum = rni
errden = bn2 errden = bn2
endif endif
If (errnum <= eps*errden) Then
exit restart
end if
if (itx.ge.litmax) exit restart if (errnum <= eps*errden) exit restart
if (itx >= litmax) exit restart
if (itrace_ > 0) &
& call log_conv(methdname,me,itx,itrace_,errnum,errden,eps)
If (itrace_ > 0) then
if ((mod(itx,itrace_)==0).and.(me == 0))&
& write(*,'(a,i4,3(2x,es10.4))') 'bicg: ',itx,errnum,eps*errden
end If
end do iteration end do iteration
end do restart end do restart
If (itrace_ > 0) then
if (me == 0) write(*,'(a,i4,3(2x,es10.4))') 'bicg: ',itx,errnum,eps*errden if (itrace_ > 0) &
end If & call log_conv(methdname,me,itx,1,errnum,errden,eps)
if (present(err)) then if (present(err)) then
if (errden /= dzero) then if (errden /= dzero) then
@ -368,29 +364,25 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
end if end if
if (present(iter)) iter = itx if (present(iter)) iter = itx
If ((errnum > eps*errden).and.(me==0)) Then
write(debug_unit,*) 'bicg failed to converge to ',eps*errden,&
& ' in ',itx,' iterations '
end if
deallocate(aux) if (errnum > eps*errden) &
call psb_gefree(wwrk,desc_a,info) & call end_log(methdname,me,itx,errnum,errden,eps)
! restore external global coherence behaviour deallocate(aux, stat=info)
call psb_restore_coher(ictxt,isvch) if (info == 0) call psb_gefree(wwrk,desc_a,info)
if (info/=0) then
if(info/=0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
! restore external global coherence behaviour
call psb_restore_coher(ictxt,isvch)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then if (err_act == psb_act_abort_) then
call psb_error() call psb_error()
return return
end if end if

55
krylov/psb_dcg.f90
Unescape Escape View File

@ -94,9 +94,10 @@
! estimate of) residual. ! estimate of) residual.
! !
! !
Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
use psb_base_mod use psb_base_mod
use psb_prec_mod use psb_prec_mod
use psb_krylov_mod, psb_protect_name => psb_dcg
implicit none implicit none
!!$ Parameters !!$ Parameters
@ -119,7 +120,8 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
& np,me, n_col, isvch, ictxt, n_row,err_act, int_err(5) & np,me, n_col, isvch, ictxt, n_row,err_act, int_err(5)
logical, parameter :: exchange=.true., noexchange=.false. logical, parameter :: exchange=.true., noexchange=.false.
real(kind(1.d0)) :: errnum, errden real(kind(1.d0)) :: errnum, errden
character(len=20) :: name character(len=20) :: name
character(len=*), parameter :: methdname='CG'
info = 0 info = 0
name = 'psb_dcg' name = 'psb_dcg'
@ -170,7 +172,7 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
allocate(aux(naux), stat=info) allocate(aux(naux), stat=info)
if (info == 0) call psb_geall(wwrk,desc_a,info,n=5) if (info == 0) call psb_geall(wwrk,desc_a,info,n=5)
if (info == 0) call psb_geasb(wwrk,desc_a,info) if (info == 0) call psb_geasb(wwrk,desc_a,info)
if (info.ne.0) then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -208,7 +210,7 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
it = 0 it = 0
call psb_geaxpby(done,b,dzero,r,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,work=aux)
if (info.ne.0) then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -223,7 +225,7 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
endif endif
errnum = dzero errnum = dzero
errden = done errden = done
if (info.ne.0) then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -234,7 +236,7 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
it = it + 1 it = it + 1
itx = itx + 1 itx = itx + 1
Call psb_precaply(prec,r,z,desc_a,info,work=aux) call psb_precaply(prec,r,z,desc_a,info,work=aux)
rho_old = rho rho_old = rho
rho = psb_gedot(r,z,desc_a,info) rho = psb_gedot(r,z,desc_a,info)
@ -271,54 +273,47 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
errnum = rni errnum = rni
errden = bn2 errden = bn2
endif endif
if (errnum <= eps*errden) then
exit restart
end if
if (errnum <= eps*errden) exit restart
if (itx>= litmax) exit restart if (itx>= litmax) exit restart
If (itrace_ > 0) then if (itrace_ > 0) &
if ((mod(itx,itrace_)==0).and.(me == 0))& & call log_conv(methdname,me,itx,itrace_,errnum,errden,eps)
& write(*,'(a,i4,3(2x,es10.4))') 'cg: ',itx,errnum,eps*errden
end If
end do iteration end do iteration
end do restart end do restart
If (itrace_ > 0) then
if (me == 0) write(*,'(a,i4,3(2x,es10.4))') 'cg: ',itx,errnum,eps*errden
end If
If (Present(err)) then if (itrace_ > 0) &
& call log_conv(methdname,me,itx,1,errnum,errden,eps)
if (present(err)) then
if (errden /= dzero) then if (errden /= dzero) then
err = errnum/errden err = errnum/errden
else else
err = errnum err = errnum
end if end if
end If end if
if (present(iter)) iter = itx if (present(iter)) iter = itx
If ((errnum > eps*errden).and.(me==0)) Then
write(0,*) 'CG Failed to converge to ',eps*errden,&
& ' in ',litmax,' iterations '
info=itx
end if
deallocate(aux) if (errnum > eps*errden) &
call psb_gefree(wwrk,desc_a,info) & call end_log(methdname,me,itx,errnum,errden,eps)
! restore external global coherence behaviour call psb_gefree(wwrk,desc_a,info)
call psb_restore_coher(ictxt,isvch) if (info /= 0) then
if (info.ne.0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
! restore external global coherence behaviour
call psb_restore_coher(ictxt,isvch)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then if (err_act == psb_act_abort_) then
call psb_error() call psb_error()
return return
end if end if

137
krylov/psb_dcgs.f90
Unescape Escape View File

@ -96,6 +96,7 @@
Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
use psb_base_mod use psb_base_mod
use psb_prec_mod use psb_prec_mod
use psb_krylov_mod, psb_protect_name => psb_dcgs
implicit none implicit none
!!$ parameters !!$ parameters
@ -119,10 +120,11 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
Integer, Parameter :: irmax = 8 Integer, Parameter :: irmax = 8
Integer :: itx, isvch, ictxt Integer :: itx, isvch, ictxt
integer :: debug_level, debug_unit integer :: debug_level, debug_unit
Real(Kind(1.d0)) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,& Real(Kind(1.d0)) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,&
& sigma & sigma
real(kind(1.d0)) :: errnum, errden real(kind(1.d0)) :: errnum, errden
character(len=20) :: name character(len=20) :: name
character(len=*), parameter :: methdname='CGS'
info = 0 info = 0
name = 'psb_dcgs' name = 'psb_dcgs'
@ -174,7 +176,7 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
Allocate(aux(naux),stat=info) Allocate(aux(naux),stat=info)
if (info == 0) Call psb_geall(wwrk,desc_a,info,n=11) if (info == 0) Call psb_geall(wwrk,desc_a,info,n=11)
if (info == 0) Call psb_geasb(wwrk,desc_a,info) if (info == 0) Call psb_geasb(wwrk,desc_a,info)
if (info.ne.0) Then if (info /= 0) Then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -228,11 +230,11 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
!!$ !!$
!!$ r0 = b-ax0 !!$ r0 = b-ax0
!!$ !!$
If (itx.Ge.litmax) Exit restart if (itx >= litmax) exit restart
it = 0 it = 0
Call psb_geaxpby(done,b,dzero,r,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,work=aux)
Call psb_geaxpby(done,r,dzero,rt,desc_a,info) call psb_geaxpby(done,r,dzero,rt,desc_a,info)
if(info/=0)then if(info/=0)then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
@ -259,68 +261,66 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
If (errnum <= eps*errden) Then if (errnum <= eps*errden) then
Exit restart exit restart
End If end if
If (itrace_ > 0) then if (itrace_ > 0) &
if ((mod(itx,itrace_)==0).and.(me == 0))& & call log_conv(methdname,me,itx,itrace_,errnum,errden,eps)
& write(*,'(a,i4,3(2x,es10.4))') 'cgs: ',itx,errnum,eps*errden
end If iteration: do
iteration: Do
it = it + 1 it = it + 1
itx = itx + 1 itx = itx + 1
If (debug_level >= psb_debug_ext_) & If (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),'iteration: ',itx & write(debug_unit,*) me,' ',trim(name),'iteration: ',itx
rho_old = rho rho_old = rho
rho = psb_gedot(rt,r,desc_a,info) rho = psb_gedot(rt,r,desc_a,info)
If (rho==dzero) Then if (rho==dzero) then
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' iteration breakdown r',rho & ' iteration breakdown r',rho
Exit iteration exit iteration
Endif endif
If (it==1) Then if (it==1) then
Call psb_geaxpby(done,r,dzero,uv,desc_a,info) call psb_geaxpby(done,r,dzero,uv,desc_a,info)
Call psb_geaxpby(done,r,dzero,p,desc_a,info) call psb_geaxpby(done,r,dzero,p,desc_a,info)
Else else
beta = (rho/rho_old) beta = (rho/rho_old)
Call psb_geaxpby(done,r,dzero,uv,desc_a,info) call psb_geaxpby(done,r,dzero,uv,desc_a,info)
Call psb_geaxpby(beta,q,done,uv,desc_a,info) call psb_geaxpby(beta,q,done,uv,desc_a,info)
Call psb_geaxpby(done,q,beta,p,desc_a,info) call psb_geaxpby(done,q,beta,p,desc_a,info)
Call psb_geaxpby(done,uv,beta,p,desc_a,info) call psb_geaxpby(done,uv,beta,p,desc_a,info)
end if
End If call psb_precaply(prec,p,f,desc_a,info,work=aux)
Call psb_precaply(prec,p,f,desc_a,info,work=aux) call psb_spmm(done,a,f,dzero,v,desc_a,info,&
Call psb_spmm(done,a,f,dzero,v,desc_a,info,&
& work=aux) & work=aux)
sigma = psb_gedot(rt,v,desc_a,info) sigma = psb_gedot(rt,v,desc_a,info)
If (sigma==dzero) Then if (sigma==dzero) then
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' iteration breakdown s1', sigma & ' iteration breakdown s1', sigma
Exit iteration exit iteration
Endif endif
alpha = rho/sigma alpha = rho/sigma
Call psb_geaxpby(done,uv,dzero,q,desc_a,info) call psb_geaxpby(done,uv,dzero,q,desc_a,info)
Call psb_geaxpby(-alpha,v,done,q,desc_a,info) call psb_geaxpby(-alpha,v,done,q,desc_a,info)
Call psb_geaxpby(done,uv,dzero,s,desc_a,info) call psb_geaxpby(done,uv,dzero,s,desc_a,info)
Call psb_geaxpby(done,q,done,s,desc_a,info) call psb_geaxpby(done,q,done,s,desc_a,info)
Call psb_precaply(prec,s,z,desc_a,info,work=aux) call psb_precaply(prec,s,z,desc_a,info,work=aux)
Call psb_geaxpby(alpha,z,done,x,desc_a,info) call psb_geaxpby(alpha,z,done,x,desc_a,info)
Call psb_spmm(done,a,z,dzero,qt,desc_a,info,& call psb_spmm(done,a,z,dzero,qt,desc_a,info,&
& work=aux) & work=aux)
Call psb_geaxpby(-alpha,qt,done,r,desc_a,info) call psb_geaxpby(-alpha,qt,done,r,desc_a,info)
if (istop_ == 1) then if (istop_ == 1) then
@ -334,56 +334,45 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
errden = bn2 errden = bn2
endif endif
If (errnum <= eps*errden) Then if (errnum <= eps*errden) exit restart
Exit restart if (itx >= litmax) exit restart
End If
If (itx.Ge.litmax) Exit restart
If (itrace_ > 0) then if (itrace_ > 0) &
if ((mod(itx,itrace_)==0).and.(me == 0))& & call log_conv(methdname,me,itx,itrace_,errnum,errden,eps)
& write(*,'(a,i4,3(2x,es10.4))') 'cgs: ',itx,errnum,eps*errden
end If
End Do iteration end do iteration
End Do restart end do restart
If (itrace_ > 0) then if (itrace_ > 0) &
if ((mod(itx,itrace_)==0).and.(me == 0))& & call log_conv(methdname,me,itx,1,errnum,errden,eps)
& write(*,'(a,i4,3(2x,es10.4))') 'cgs: ',itx,errnum,eps*errden
end If
If (Present(iter)) iter = itx if (present(iter)) iter = itx
If (Present(err)) then if (present(err)) then
if (errden /= dzero) then if (errden /= dzero) then
err = errnum/errden err = errnum/errden
else else
err = errnum err = errnum
end if end if
end If end if
If ((errnum > eps*errden).and.(me==0)) Then if (errnum > eps*errden) &
write(debug_unit,*) 'cgs failed to converge to ',eps*errden,& & call end_log(methdname,me,itx,errnum,errden,eps)
& ' in ',itx,' iterations '
End If
Deallocate(aux)
Call psb_gefree(wwrk,desc_a,info)
! restore external global coherence behaviour
call psb_restore_coher(ictxt,isvch)
deallocate(aux,stat=info)
if (info == 0) call psb_gefree(wwrk,desc_a,info)
if(info/=0) then if(info/=0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
! restore external global coherence behaviour
call psb_restore_coher(ictxt,isvch)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then if (err_act == psb_act_abort_) then
call psb_error() call psb_error()
return return
end if end if

200
krylov/psb_dcgstab.F90
Unescape Escape View File

@ -96,6 +96,7 @@
Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
use psb_base_mod use psb_base_mod
use psb_prec_mod use psb_prec_mod
use psb_krylov_mod, psb_protect_name => psb_dcgstab
Implicit None Implicit None
!!$ parameters !!$ parameters
Type(psb_dspmat_type), Intent(in) :: a Type(psb_dspmat_type), Intent(in) :: a
@ -126,7 +127,8 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
Integer istpb, istpe, ifctb, ifcte, imerr, irank, icomm,immb,imme Integer istpb, istpe, ifctb, ifcte, imerr, irank, icomm,immb,imme
Integer mpe_log_get_event_number,mpe_Describe_state,mpe_log_event Integer mpe_log_get_event_number,mpe_Describe_state,mpe_log_event
#endif #endif
character(len=20) :: name character(len=20) :: name
character(len=*), parameter :: methdname='BiCGStab'
info = 0 info = 0
name = 'psb_dcgstab' name = 'psb_dcgstab'
@ -247,25 +249,25 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
!!$ !!$
!!$ r0 = b-Ax0 !!$ r0 = b-Ax0
!!$ !!$
If (itx >= litmax) Exit restart if (itx >= litmax) exit restart
it = 0 it = 0
Call psb_geaxpby(done,b,dzero,r,desc_a,info) call psb_geaxpby(done,b,dzero,r,desc_a,info)
#ifdef MPE_KRYLOV #ifdef MPE_KRYLOV
imerr = MPE_Log_event( immb, 0, "st SPMM" ) imerr = MPE_Log_event( immb, 0, "st SPMM" )
#endif #endif
Call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
#ifdef MPE_KRYLOV #ifdef MPE_KRYLOV
imerr = MPE_Log_event( imme, 0, "ed SPMM" ) imerr = MPE_Log_event( imme, 0, "ed SPMM" )
#endif #endif
Call psb_geaxpby(done,r,dzero,q,desc_a,info) call psb_geaxpby(done,r,dzero,q,desc_a,info)
if (info /= 0) Then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If end if
rho = dzero rho = dzero
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' On entry to AMAX: B: ',Size(b) & ' On entry to AMAX: B: ',Size(b)
@ -273,113 +275,99 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
! Must always provide norm of R into RNI below for first check on ! Must always provide norm of R into RNI below for first check on
! residual ! residual
! !
If (istop_ == 1) Then if (istop_ == 1) then
rni = psb_geamax(r,desc_a,info) rni = psb_geamax(r,desc_a,info)
xni = psb_geamax(x,desc_a,info) xni = psb_geamax(x,desc_a,info)
Else If (istop_ == 2) Then else if (istop_ == 2) then
rni = psb_genrm2(r,desc_a,info) rni = psb_genrm2(r,desc_a,info)
Endif endif
if (info /= 0) Then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If end if
If (itx == 0) Then if (itx == 0) then
rn0 = rni rn0 = rni
End If end if
If (rn0 == dzero ) Then if (rn0 == dzero ) then
If (itrace_ > 0 ) Then
If (me == 0) Write(*,*) 'BiCGSTAB: ',itx,rn0
Endif
errnum = dzero errnum = dzero
errden = done errden = done
Exit restart exit restart
End If end if
If (istop_ == 1) Then if (istop_ == 1) then
xni = psb_geamax(x,desc_a,info) xni = psb_geamax(x,desc_a,info)
errnum = rni errnum = rni
errden = (ani*xni+bni) errden = (ani*xni+bni)
Else If (istop_ == 2) Then else if (istop_ == 2) then
errnum = rni errnum = rni
errden = bn2 errden = bn2
Endif endif
if (info /= 0) Then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If end if
If (errnum <= eps*errden) Then if (errnum <= eps*errden) exit restart
Exit restart if (itrace_ > 0) &
End If & call log_conv(methdname,me,itx,1,errnum,errden,eps)
If (itrace_ > 0) then
if (((itx==0).or.(mod(itx,itrace_)==0)).and.(me == 0)) &
& write(*,'(a,i4,3(2x,es10.4))') 'bicgstab: ',&
& itx,errnum,eps*errden
Endif
iteration: Do iteration: Do
it = it + 1 it = it + 1
itx = itx + 1 itx = itx + 1
If (debug_level >= psb_debug_ext_)& if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' Iteration: ',itx & ' Iteration: ',itx
rho_old = rho rho_old = rho
rho = psb_gedot(q,r,desc_a,info) rho = psb_gedot(q,r,desc_a,info)
If (debug_level >= psb_debug_ext_) & if (rho==dzero) then
& write(debug_unit,*) me,' ',trim(name),& if (debug_level >= psb_debug_ext_) &
& ' RHO:',rho
If (rho==dzero) Then
If (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' Iteration breakdown R',rho & ' Iteration breakdown R',rho
Exit iteration exit iteration
Endif endif
If (it==1) Then if (it==1) then
Call psb_geaxpby(done,r,dzero,p,desc_a,info) call psb_geaxpby(done,r,dzero,p,desc_a,info)
Else else
beta = (rho/rho_old)*(alpha/omega) beta = (rho/rho_old)*(alpha/omega)
Call psb_geaxpby(-omega,v,done,p,desc_a,info) call psb_geaxpby(-omega,v,done,p,desc_a,info)
Call psb_geaxpby(done,r,beta,p,desc_a,info) call psb_geaxpby(done,r,beta,p,desc_a,info)
End If End If
#ifdef MPE_KRYLOV #ifdef MPE_KRYLOV
imerr = MPE_Log_event( ifctb, 0, "st PREC" ) imerr = MPE_Log_event( ifctb, 0, "st PREC" )
#endif #endif
Call psb_precaply(prec,p,f,desc_a,info,work=aux) call psb_precaply(prec,p,f,desc_a,info,work=aux)
#ifdef MPE_KRYLOV #ifdef MPE_KRYLOV
imerr = MPE_Log_event( ifcte, 0, "ed PREC" ) imerr = MPE_Log_event( ifcte, 0, "ed PREC" )
imerr = MPE_Log_event( immb, 0, "st SPMM" ) imerr = MPE_Log_event( immb, 0, "st SPMM" )
#endif #endif
call psb_spmm(done,a,f,dzero,v,desc_a,info,&
Call psb_spmm(done,a,f,dzero,v,desc_a,info,&
& work=aux) & work=aux)
#ifdef MPE_KRYLOV #ifdef MPE_KRYLOV
imerr = MPE_Log_event( imme, 0, "ed SPMM" ) imerr = MPE_Log_event( imme, 0, "ed SPMM" )
#endif #endif
sigma = psb_gedot(q,v,desc_a,info) sigma = psb_gedot(q,v,desc_a,info)
If (sigma==dzero) Then if (sigma==dzero) then
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' Iteration breakdown S1', sigma & ' Iteration breakdown S1', sigma
Exit iteration exit iteration
Endif endif
If (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' SIGMA:',sigma
alpha = rho/sigma alpha = rho/sigma
Call psb_geaxpby(done,r,dzero,s,desc_a,info) call psb_geaxpby(done,r,dzero,s,desc_a,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_geaxpby') call psb_errpush(4010,name,a_err='psb_geaxpby')
goto 9999 goto 9999
end if end if
Call psb_geaxpby(-alpha,v,done,s,desc_a,info) call psb_geaxpby(-alpha,v,done,s,desc_a,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_geaxpby') call psb_errpush(4010,name,a_err='psb_geaxpby')
goto 9999 goto 9999
@ -388,7 +376,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
#ifdef MPE_KRYLOV #ifdef MPE_KRYLOV
imerr = MPE_Log_event( ifctb, 0, "st PREC" ) imerr = MPE_Log_event( ifctb, 0, "st PREC" )
#endif #endif
Call psb_precaply(prec,s,z,desc_a,info,work=aux) call psb_precaply(prec,s,z,desc_a,info,work=aux)
#ifdef MPE_KRYLOV #ifdef MPE_KRYLOV
imerr = MPE_Log_event( ifcte, 0, "ed PREC" ) imerr = MPE_Log_event( ifcte, 0, "ed PREC" )
#endif #endif
@ -412,91 +400,79 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
end if end if
sigma = psb_gedot(t,t,desc_a,info) sigma = psb_gedot(t,t,desc_a,info)
If (sigma==dzero) Then if (sigma==dzero) then
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' Iteration breakdown S2', sigma & ' Iteration breakdown S2', sigma
Exit iteration exit iteration
Endif endif
tau = psb_gedot(t,s,desc_a,info) tau = psb_gedot(t,s,desc_a,info)
omega = tau/sigma omega = tau/sigma
If (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& if (omega==dzero) then
& ' Omega:',omega if (debug_level >= psb_debug_ext_) &
If (omega==dzero) Then
If (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' Iteration breakdown O',omega & ' Iteration breakdown O',omega
Exit iteration exit iteration
Endif endif
Call psb_geaxpby(alpha,f,done,x,desc_a,info) call psb_geaxpby(alpha,f,done,x,desc_a,info)
Call psb_geaxpby(omega,z,done,x,desc_a,info) call psb_geaxpby(omega,z,done,x,desc_a,info)
Call psb_geaxpby(done,s,dzero,r,desc_a,info) call psb_geaxpby(done,s,dzero,r,desc_a,info)
Call psb_geaxpby(-omega,t,done,r,desc_a,info) call psb_geaxpby(-omega,t,done,r,desc_a,info)
If (istop_ == 1) Then if (istop_ == 1) then
rni = psb_geamax(r,desc_a,info) rni = psb_geamax(r,desc_a,info)
xni = psb_geamax(x,desc_a,info) xni = psb_geamax(x,desc_a,info)
errnum = rni errnum = rni
errden = (ani*xni+bni) errden = (ani*xni+bni)
Else If (istop_ == 2) Then else if (istop_ == 2) then
rni = psb_genrm2(r,desc_a,info) rni = psb_genrm2(r,desc_a,info)
errnum = rni errnum = rni
errden = bn2 errden = bn2
Endif endif
If (errnum <= eps*errden) Then
Exit restart
End If
If (itx.Ge.litmax) Exit restart
If (itrace_ > 0) then if (errnum <= eps*errden) exit restart
if ((mod(itx,itrace_)==0).and.(me == 0)) & if (itx >= litmax) exit restart
& write(*,'(a,i4,3(2x,es10.4))') & if (itrace_ > 0) &
& 'bicgstab: ',itx,errnum,eps*errden & call log_conv(methdname,me,itx,itrace_,errnum,errden,eps)
Endif
End Do iteration end do iteration
End Do restart end do restart
If (itrace_ > 0) then if (itrace_ > 0) &
if (me == 0) write(*,'(a,i4,3(2x,es10.4))') 'bicgstab: ',& & call log_conv(methdname,me,itx,1,errnum,errden,eps)
& itx,errnum,eps*errden
Endif
If (Present(err)) then if (present(err)) then
if (errden /= dzero) then if (errden /= dzero) then
err = errnum/errden err = errnum/errden
else else
err = errnum err = errnum
end if end if
end If end if
If (Present(iter)) iter = itx if (present(iter)) iter = itx
If ((errnum > eps*errden).and.(me==0)) Then if (errnum > eps*errden) &
write(debug_unit,*) 'BI-CGSTAB failed to converge to ',eps*errden,& & call end_log(methdname,me,itx,errnum,errden,eps)
& ' in ',ITX,' iterations. '
End If
Deallocate(aux) deallocate(aux,stat=info)
Call psb_gefree(wwrk,desc_a,info) if (info == 0) call psb_gefree(wwrk,desc_a,info)
! restore external global coherence behaviour
call psb_restore_coher(ictxt,isvch)
#ifdef MPE_KRYLOV
imerr = MPE_Log_event( istpe, 0, "ed CGSTAB" )
#endif
if(info/=0) then if(info/=0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
#ifdef MPE_KRYLOV
imerr = MPE_Log_event( istpe, 0, "ed CGSTAB" )
#endif
! restore external global coherence behaviour
call psb_restore_coher(ictxt,isvch)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then if (err_act == psb_act_abort_) then
call psb_error(ictxt) call psb_error(ictxt)
return return
end if end if

231
krylov/psb_dcgstabl.f90
Unescape Escape View File

@ -105,6 +105,7 @@
Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop) Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop)
use psb_base_mod use psb_base_mod
use psb_prec_mod use psb_prec_mod
use psb_krylov_mod, psb_protect_name => psb_dcgstabl
implicit none implicit none
!!$ parameters !!$ parameters
@ -133,6 +134,7 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is
& omega & omega
real(kind(1.d0)) :: errnum, errden real(kind(1.d0)) :: errnum, errden
character(len=20) :: name character(len=20) :: name
character(len=*), parameter :: methdname='BiCGStab(L)'
info = 0 info = 0
name = 'psb_dcgstabl' name = 'psb_dcgstabl'
@ -168,29 +170,29 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is
goto 9999 goto 9999
endif endif
If (Present(itmax)) Then if (present(itmax)) then
litmax = itmax litmax = itmax
Else else
litmax = 1000 litmax = 1000
Endif endif
If (Present(itrace)) Then if (present(itrace)) then
itrace_ = itrace itrace_ = itrace
Else else
itrace_ = 0 itrace_ = 0
End If end if
If (Present(irst)) Then if (present(irst)) then
nl = irst nl = irst
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'present: irst: ',irst,nl & 'present: irst: ',irst,nl
Else else
nl = 1 nl = 1
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' not present: irst: ',irst,nl & ' not present: irst: ',irst,nl
Endif endif
if (nl <=0 ) then if (nl <=0 ) then
info=5001 info=5001
int_err(1)=nl int_err(1)=nl
@ -213,25 +215,25 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is
end if end if
naux=4*n_col naux=4*n_col
Allocate(aux(naux),gamma(0:nl),gamma1(nl),& allocate(aux(naux),gamma(0:nl),gamma1(nl),&
&gamma2(nl),taum(nl,nl),sigma(nl), stat=info) &gamma2(nl),taum(nl,nl),sigma(nl), stat=info)
If (info.Ne.0) Then if (info /= 0) then
info=4000 info=4000
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If end if
if (info == 0) Call psb_geall(wwrk,desc_a,info,n=10) if (info == 0) Call psb_geall(wwrk,desc_a,info,n=10)
if (info == 0) Call psb_geall(uh,desc_a,info,n=nl+1) if (info == 0) Call psb_geall(uh,desc_a,info,n=nl+1)
if (info == 0) Call psb_geall(rh,desc_a,info,n=nl+1) if (info == 0) Call psb_geall(rh,desc_a,info,n=nl+1)
if (info == 0) Call psb_geasb(wwrk,desc_a,info) if (info == 0) Call psb_geasb(wwrk,desc_a,info)
if (info == 0) Call psb_geasb(uh,desc_a,info) if (info == 0) Call psb_geasb(uh,desc_a,info)
if (info == 0) Call psb_geasb(rh,desc_a,info) if (info == 0) Call psb_geasb(rh,desc_a,info)
if (info.ne.0) Then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If end if
q => wwrk(:,1) q => wwrk(:,1)
r => wwrk(:,2) r => wwrk(:,2)
@ -255,40 +257,40 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is
endif endif
errnum = dzero errnum = dzero
errden = done errden = done
if (info.ne.0) Then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If end if
itx = 0 itx = 0
restart: Do restart: do
!!$ !!$
!!$ r0 = b-ax0 !!$ r0 = b-ax0
!!$ !!$
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),' restart: ',itx,it & write(debug_unit,*) me,' ',trim(name),' restart: ',itx,it
If (itx.Ge.litmax) Exit restart if (itx >= litmax) exit restart
it = 0 it = 0
Call psb_geaxpby(done,b,dzero,r,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,work=aux)
call psb_precaply(prec,r,desc_a,info) call psb_precaply(prec,r,desc_a,info)
Call psb_geaxpby(done,r,dzero,rt0,desc_a,info) call psb_geaxpby(done,r,dzero,rt0,desc_a,info)
Call psb_geaxpby(done,r,dzero,rh(:,0),desc_a,info) call psb_geaxpby(done,r,dzero,rh(:,0),desc_a,info)
Call psb_geaxpby(dzero,r,dzero,uh(:,0),desc_a,info) call psb_geaxpby(dzero,r,dzero,uh(:,0),desc_a,info)
if (info.ne.0) Then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If end if
rho = done rho = done
alpha = dzero alpha = dzero
omega = done omega = done
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' on entry to amax: b: ',Size(b) & ' on entry to amax: b: ',Size(b)
@ -302,122 +304,107 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is
errnum = rni errnum = rni
errden = bn2 errden = bn2
endif endif
if (info.ne.0) Then if (info /= 0) Then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If end if
If (errnum <= eps*errden) Then if (errnum <= eps*errden) exit restart
Exit restart if (itrace_ > 0) &
End If & call log_conv(methdname,me,itx,itrace_,errnum,errden,eps)
If (itrace_ > 0) then
if ((mod(itx,itrace_)==0).and.(me == 0))&
& write(*,'(a,i4,3(2x,es10.4))') 'bicgstab(l): ',itx,errnum,eps*errden
end If
iteration: Do iteration: do
it = it + nl it = it + nl
itx = itx + nl itx = itx + nl
rho = -omega*rho rho = -omega*rho
If (debug_level >= psb_debug_ext_) &
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' iteration: ',itx, rho,rh(1,0) & ' iteration: ',itx, rho,rh(1,0)
Do j = 0, nl -1 do j = 0, nl -1
If (debug_level >= psb_debug_ext_) & If (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),'bicg part: ',j, nl & write(debug_unit,*) me,' ',trim(name),'bicg part: ',j, nl
rho_old = rho rho_old = rho
rho = psb_gedot(rh(:,j),rt0,desc_a,info) rho = psb_gedot(rh(:,j),rt0,desc_a,info)
If (rho==dzero) Then if (rho==dzero) then
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' bi-cgstab iteration breakdown r',rho & ' bi-cgstab iteration breakdown r',rho
Exit iteration exit iteration
Endif endif
beta = alpha*rho/rho_old beta = alpha*rho/rho_old
If (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' bicg part: ',alpha,beta,rho,rho_old
rho_old = rho rho_old = rho
Call psb_geaxpby(done,rh(:,0:j),-beta,uh(:,0:j),desc_a,info) call psb_geaxpby(done,rh(:,0:j),-beta,uh(:,0:j),desc_a,info)
If (debug_level >= psb_debug_ext_) & call psb_spmm(done,a,uh(:,j),dzero,uh(:,j+1),desc_a,info,work=aux)
& write(debug_unit,*) me,' ',trim(name),&
& ' bicg part: ',rh(1,0),beta
Call psb_spmm(done,a,uh(:,j),dzero,uh(:,j+1),desc_a,info,work=aux)
call psb_precaply(prec,uh(:,j+1),desc_a,info) call psb_precaply(prec,uh(:,j+1),desc_a,info)
gamma(j) = psb_gedot(uh(:,j+1),rt0,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_) & if (gamma(j)==dzero) then
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' bi-cgstab iteration breakdown s2',gamma(j) & ' bi-cgstab iteration breakdown s2',gamma(j)
Exit iteration exit iteration
Endif endif
alpha = rho/gamma(j) alpha = rho/gamma(j)
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' bicg part: alpha=r/g ',alpha,rho,gamma(j) & ' 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(:,1:j+1),done,rh(:,0:j),desc_a,info)
Call psb_geaxpby(alpha,uh(:,0),done,x,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 psb_spmm(done,a,rh(:,j),dzero,rh(:,j+1),desc_a,info,work=aux)
call psb_precaply(prec,rh(:,j+1),desc_a,info) call psb_precaply(prec,rh(:,j+1),desc_a,info)
Enddo enddo
Do j=1, nl do j=1, nl
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' mod g-s part: ',j, nl,rh(1,0) & ' mod g-s part: ',j, nl,rh(1,0)
Do i=1, j-1
do i=1, j-1
taum(i,j) = psb_gedot(rh(:,i),rh(:,j),desc_a,info) taum(i,j) = psb_gedot(rh(:,i),rh(:,j),desc_a,info)
taum(i,j) = taum(i,j)/sigma(i) taum(i,j) = taum(i,j)/sigma(i)
Call psb_geaxpby(-taum(i,j),rh(:,i),done,rh(:,j),desc_a,info) call psb_geaxpby(-taum(i,j),rh(:,i),done,rh(:,j),desc_a,info)
Enddo enddo
sigma(j) = psb_gedot(rh(:,j),rh(:,j),desc_a,info) sigma(j) = psb_gedot(rh(:,j),rh(:,j),desc_a,info)
gamma1(j) = psb_gedot(rh(:,0),rh(:,j),desc_a,info) gamma1(j) = psb_gedot(rh(:,0),rh(:,j),desc_a,info)
If (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' mod g-s part: gamma1 ',gamma1(j), sigma(j)
gamma1(j) = gamma1(j)/sigma(j) gamma1(j) = gamma1(j)/sigma(j)
Enddo enddo
gamma(nl) = gamma1(nl) gamma(nl) = gamma1(nl)
omega = gamma(nl) omega = gamma(nl)
Do j=nl-1,1,-1 do j=nl-1,1,-1
gamma(j) = gamma1(j) gamma(j) = gamma1(j)
Do i=j+1,nl do i=j+1,nl
gamma(j) = gamma(j) - taum(j,i) * gamma(i) gamma(j) = gamma(j) - taum(j,i) * gamma(i)
Enddo enddo
Enddo enddo
If (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& do j=1,nl-1
& ' first solve: ', gamma(:)
Do j=1,nl-1
gamma2(j) = gamma(j+1) gamma2(j) = gamma(j+1)
Do i=j+1,nl-1 do i=j+1,nl-1
gamma2(j) = gamma2(j) + taum(j,i) * gamma(i+1) gamma2(j) = gamma2(j) + taum(j,i) * gamma(i+1)
Enddo enddo
Enddo enddo
If (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' second solve: ', gamma(:)
Call psb_geaxpby(gamma(1),rh(:,0),done,x,desc_a,info) 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(-gamma1(nl),rh(:,nl),done,rh(:,0),desc_a,info)
Call psb_geaxpby(-gamma(nl),uh(:,nl),done,uh(:,0),desc_a,info) call psb_geaxpby(-gamma(nl),uh(:,nl),done,uh(:,0),desc_a,info)
Do j=1, nl-1 do j=1, nl-1
Call psb_geaxpby(-gamma(j),uh(:,j),done,uh(:,0),desc_a,info) 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(gamma2(j),rh(:,j),done,x,desc_a,info)
Call psb_geaxpby(-gamma1(j),rh(:,j),done,rh(:,0),desc_a,info) call psb_geaxpby(-gamma1(j),rh(:,j),done,rh(:,0),desc_a,info)
Enddo enddo
if (istop_ == 1) then if (istop_ == 1) then
rni = psb_geamax(rh(:,0),desc_a,info) rni = psb_geamax(rh(:,0),desc_a,info)
@ -430,54 +417,46 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is
errden = bn2 errden = bn2
endif endif
If (errnum <= eps*errden) Then if (errnum <= eps*errden) exit restart
Exit restart if (itx >= litmax) exit restart
End If if (itrace_ > 0) &
If (itx.Ge.litmax) Exit restart & call log_conv(methdname,me,itx,itrace_,errnum,errden,eps)
If (itrace_ > 0) then
if ((mod(itx,itrace_)==0).and.(me == 0))&
& write(*,'(a,i4,3(2x,es10.4))') 'bicgstab(l): ',itx,errnum,eps*errden
end If
End Do iteration end do iteration
End Do restart end do restart
If (itrace_ > 0) then if (itrace_ > 0) &
if (me == 0) write(*,'(a,i4,3(2x,es10.4))') 'bicgstab(l): ',itx,errnum,eps*errden & call log_conv(methdname,me,itx,1,errnum,errden,eps)
end If
If (Present(err)) then if (present(err)) then
if (errden /= dzero) then if (errden /= dzero) then
err = errnum/errden err = errnum/errden
else else
err = errnum err = errnum
end if end if
end If end if
If (Present(iter)) iter = itx
If ((errnum > eps*errden).and.(me==0)) Then
write(debug_unit,*) 'bi-cgstabl failed to converge to ',eps*errden,&
& ' in ',itx,' iterations '
End If
Deallocate(aux)
Call psb_gefree(wwrk,desc_a,info)
Call psb_gefree(uh,desc_a,info)
Call psb_gefree(rh,desc_a,info)
! restore external global coherence behaviour if (present(iter)) iter = itx
call psb_restore_coher(ictxt,isvch) if (errnum > eps*errden) &
& call end_log(methdname,me,itx,errnum,errden,eps)
deallocate(aux,stat=info)
if (info == 0) call psb_gefree(wwrk,desc_a,info)
if (info == 0) call psb_gefree(uh,desc_a,info)
if (info == 0) call psb_gefree(rh,desc_a,info)
if(info/=0) then if(info/=0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
! restore external global coherence behaviour
call psb_restore_coher(ictxt,isvch)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then if (err_act == psb_act_abort_) then
call psb_error() call psb_error()
return return
end if end if

149
krylov/psb_drgmres.f90
Unescape Escape View File

@ -105,9 +105,10 @@
! irst - integer(optional) Input: restart parameter ! irst - integer(optional) Input: restart parameter
! !
! !
Subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop) subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop)
use psb_base_mod use psb_base_mod
use psb_prec_mod use psb_prec_mod
use psb_krylov_mod, psb_protect_name => psb_drgmres
implicit none implicit none
!!$ Parameters !!$ Parameters
@ -134,7 +135,8 @@ Subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist
Real(Kind(1.d0)) :: rni, xni, bni, ani,bn2, dt Real(Kind(1.d0)) :: rni, xni, bni, ani,bn2, dt
real(kind(1.d0)), external :: dnrm2 real(kind(1.d0)), external :: dnrm2
real(kind(1.d0)) :: errnum, errden real(kind(1.d0)) :: errnum, errden
character(len=20) :: name character(len=20) :: name
character(len=*), parameter :: methdname='RGMRES'
info = 0 info = 0
name = 'psb_dgmres' name = 'psb_dgmres'
@ -169,29 +171,29 @@ Subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist
goto 9999 goto 9999
endif endif
If (Present(itmax)) Then if (present(itmax)) then
litmax = itmax litmax = itmax
Else else
litmax = 1000 litmax = 1000
Endif endif
If (Present(itrace)) Then if (present(itrace)) then
itrace_ = itrace itrace_ = itrace
Else else
itrace_ = 0 itrace_ = 0
End If end if
If (Present(irst)) Then if (present(irst)) then
nl = irst nl = irst
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' present: irst: ',irst,nl & ' present: irst: ',irst,nl
Else else
nl = 10 nl = 10
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' not present: irst: ',irst,nl & ' not present: irst: ',irst,nl
Endif endif
if (nl <=0 ) then if (nl <=0 ) then
info=5001 info=5001
int_err(1)=nl int_err(1)=nl
@ -215,22 +217,22 @@ Subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist
naux=4*n_col naux=4*n_col
Allocate(aux(naux),h(nl+1,nl+1),& allocate(aux(naux),h(nl+1,nl+1),&
&c(nl+1),s(nl+1),rs(nl+1), rst(nl+1),stat=info) &c(nl+1),s(nl+1),rs(nl+1), rst(nl+1),stat=info)
if (info == 0) Call psb_geall(v,desc_a,info,n=nl+1) if (info == 0) call psb_geall(v,desc_a,info,n=nl+1)
if (info == 0) Call psb_geall(w,desc_a,info) if (info == 0) call psb_geall(w,desc_a,info)
if (info == 0) Call psb_geall(w1,desc_a,info) if (info == 0) call psb_geall(w1,desc_a,info)
if (info == 0) Call psb_geall(xt,desc_a,info) if (info == 0) call psb_geall(xt,desc_a,info)
if (info == 0) Call psb_geasb(v,desc_a,info) if (info == 0) call psb_geasb(v,desc_a,info)
if (info == 0) Call psb_geasb(w,desc_a,info) if (info == 0) call psb_geasb(w,desc_a,info)
if (info == 0) Call psb_geasb(w1,desc_a,info) if (info == 0) call psb_geasb(w1,desc_a,info)
if (info == 0) Call psb_geasb(xt,desc_a,info) if (info == 0) call psb_geasb(xt,desc_a,info)
if (info.ne.0) Then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If end if
if (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' Size of V,W,W1 ',size(v),size(v,1),& & ' Size of V,W,W1 ',size(v),size(v,1),&
@ -247,47 +249,47 @@ Subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist
endif endif
errnum = dzero errnum = dzero
errden = done errden = done
if (info.ne.0) Then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If end if
itx = 0 itx = 0
restart: Do restart: do
! compute r0 = b-ax0 ! compute r0 = b-ax0
! check convergence ! check convergence
! compute v1 = r0/||r0||_2 ! compute v1 = r0/||r0||_2
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' restart: ',itx,it & ' restart: ',itx,it
it = 0 it = 0
Call psb_geaxpby(done,b,dzero,v(:,1),desc_a,info) call psb_geaxpby(done,b,dzero,v(:,1),desc_a,info)
if (info.ne.0) Then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If 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,work=aux)
if (info.ne.0) Then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If end if
rs(1) = psb_genrm2(v(:,1),desc_a,info) rs(1) = psb_genrm2(v(:,1),desc_a,info)
rs(2:) = dzero rs(2:) = dzero
if (info.ne.0) Then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If end if
scal=done/rs(1) ! rs(1) MIGHT BE VERY SMALL - USE DSCAL TO DEAL WITH IT? scal=done/rs(1) ! rs(1) MIGHT BE VERY SMALL - USE DSCAL TO DEAL WITH IT?
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' on entry to amax: b: ',Size(b),rs(1),scal & ' on entry to amax: b: ',Size(b),rs(1),scal
@ -304,24 +306,20 @@ Subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist
errnum = rni errnum = rni
errden = bn2 errden = bn2
endif endif
if (info.ne.0) Then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If end if
If (errnum <= eps*errden) Then if (errnum <= eps*errden) exit restart
Exit restart
End If if (itrace_ > 0) &
& call log_conv(methdname,me,itx,itrace_,errnum,errden,eps)
If (itrace_ > 0) then
if ((mod(itx,itrace_)==0).and.(me == 0))&
& write(*,'(a,i4,3(2x,es10.4))') 'gmres(l): ',itx,errnum,eps*errden
end If
v(:,1) = v(:,1) * scal v(:,1) = v(:,1) * scal
If (itx.Ge.litmax) Exit restart if (itx >= litmax) exit restart
! !
! inner iterations ! inner iterations
@ -331,7 +329,7 @@ Subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist
itx = itx + 1 itx = itx + 1
call psb_precaply(prec,v(:,i),w1,desc_a,info) call psb_precaply(prec,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,work=aux)
! !
do k = 1, i do k = 1, i
@ -403,7 +401,7 @@ Subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist
errden = bn2 errden = bn2
endif endif
If (errnum <= eps*errden) Then if (errnum <= eps*errden) then
if (istop_ == 1) then if (istop_ == 1) then
x = xt x = xt
@ -427,12 +425,10 @@ Subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist
end if end if
If (itrace_ > 0) then if (itrace_ > 0) &
if ((mod(itx,itrace_)==0).and.(me == 0))& & call log_conv(methdname,me,itx,itrace_,errnum,errden,eps)
& write(*,'(a,i4,3(2x,es10.4))') 'gmres(l): ',itx,errnum,eps*errden
end If
end Do inner end do inner
if (istop_ == 1) then if (istop_ == 1) then
x = xt x = xt
@ -452,53 +448,47 @@ Subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist
call psb_geaxpby(done,w,done,x,desc_a,info) call psb_geaxpby(done,w,done,x,desc_a,info)
end if end if
End Do restart end do restart
If (itrace_ > 0) then if (itrace_ > 0) &
if (me == 0) write(*,'(a,i4,3(2x,es10.4))') 'gmres(l): ',itx,errnum,eps*errden & call log_conv(methdname,me,itx,1,errnum,errden,eps)
end If
If (Present(err)) then if (present(err)) then
if (errden /= dzero) then if (errden /= dzero) then
err = errnum/errden err = errnum/errden
else else
err = errnum err = errnum
end if end if
end If end if
If (Present(iter)) iter = itx
If ((errnum > eps*errden).and.(me==0)) Then
write(debug_unit,*) 'gmresr(l) failed to converge to ',eps*errden,&
& ' in ',itx,' iterations '
End If
Deallocate(aux,h,c,s,rs,rst, stat=info)
Call psb_gefree(v,desc_a,info)
Call psb_gefree(w,desc_a,info)
Call psb_gefree(w1,desc_a,info)
Call psb_gefree(xt,desc_a,info)
! restore external global coherence behaviour if (present(iter)) iter = itx
call psb_restore_coher(ictxt,isvch) if (errnum > eps*errden) &
& call end_log(methdname,me,itx,errnum,errden,eps)
deallocate(aux,h,c,s,rs,rst, stat=info)
if (info == 0) call psb_gefree(v,desc_a,info)
if (info == 0) call psb_gefree(w,desc_a,info)
if (info == 0) call psb_gefree(w1,desc_a,info)
if (info == 0) call psb_gefree(xt,desc_a,info)
if (info /= 0) then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
! restore external global coherence behaviour
call psb_restore_coher(ictxt,isvch)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then if (err_act == psb_act_abort_) then
call psb_error() call psb_error()
return return
end if end if
return return
contains contains
function safe_dn2(a,b) function safe_dn2(a,b)
real(kind(1.d0)), intent(in) :: a, b real(kind(1.d0)), intent(in) :: a, b
@ -513,8 +503,7 @@ contains
endif endif
return return
end function safe_dn2 end function safe_dn2
End Subroutine psb_drgmres end subroutine psb_drgmres

26
krylov/psb_krylov_mod.f90
Unescape Escape View File

@ -423,6 +423,32 @@ contains
end subroutine psb_zkrylov end subroutine psb_zkrylov
subroutine log_conv(methdname,me,itx,itrace,errnum,errden,eps)
character(len=*), intent(in) :: methdname
integer, intent(in) :: me, itx, itrace
real(kind(1.d0)), intent(in) :: errnum, errden, eps
character(len=*), parameter :: fmt='(a,i4,3(2x,es10.4))'
if ((mod(itx,itrace)==0).and.(me == 0)) then
write(*,fmt) methdname//': ',itx,errnum,eps*errden
Endif
end subroutine log_conv
subroutine end_log(methdname,me,itx,errnum,errden,eps)
character(len=*), intent(in) :: methdname
integer, intent(in) :: me, itx
real(kind(1.d0)), intent(in) :: errnum, errden, eps
character(len=*), parameter :: fmt='(a,2x,es10.4,1x,a,1x,i4,1x,a)'
character(len=*), parameter :: fmt1='(a,3(2x,es10.4))'
if (me==0) then
write(*,fmt) methdname//' failed to converge to ',eps,&
& ' in ',ITX,' iterations. '
write(*,fmt1) 'Last iteration convergence indicators: ',&
& errnum,eps*errden,errnum/errden
end if
end subroutine end_log
end module psb_krylov_mod end module psb_krylov_mod

137
krylov/psb_zcgs.f90
Unescape Escape View File

@ -94,6 +94,7 @@
Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
use psb_base_mod use psb_base_mod
use psb_prec_mod use psb_prec_mod
use psb_krylov_mod, psb_protect_name => psb_zcgs
implicit none implicit none
!!$ parameters !!$ parameters
@ -121,6 +122,7 @@ Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
complex(Kind(1.d0)) :: alpha, beta, rho, rho_old, sigma complex(Kind(1.d0)) :: alpha, beta, rho, rho_old, sigma
real(kind(1.d0)) :: errnum, errden real(kind(1.d0)) :: errnum, errden
character(len=20) :: name character(len=20) :: name
character(len=*), parameter :: methdname='CGS'
info = 0 info = 0
name = 'psb_zcgs' name = 'psb_zcgs'
@ -197,11 +199,11 @@ Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
litmax = 1000 litmax = 1000
Endif Endif
If (Present(itrace)) Then if (present(itrace)) then
itrace_ = itrace itrace_ = itrace
Else else
itrace_ = 0 itrace_ = 0
End If end if
! Ensure global coherence for convergence checks. ! Ensure global coherence for convergence checks.
call psb_set_coher(ictxt,isvch) call psb_set_coher(ictxt,isvch)
@ -226,7 +228,7 @@ Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
!!$ !!$
!!$ r0 = b-ax0 !!$ r0 = b-ax0
!!$ !!$
If (itx.Ge.litmax) Exit restart If (itx >= litmax) Exit restart
it = 0 it = 0
Call psb_geaxpby(zone,b,zzero,r,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,work=aux)
@ -258,68 +260,63 @@ Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
goto 9999 goto 9999
end if end if
If (errnum <= eps*errden) Then if (errnum <= eps*errden) exit restart
Exit restart if (itrace_ > 0) &
End If & call log_conv(methdname,me,itx,itrace_,errnum,errden,eps)
If (itrace_ > 0) then
if ((mod(itx,itrace_)==0).and.(me == 0))&
& write(*,'(a,i4,3(2x,es10.4))') 'cgs: ',itx,errnum,eps*errden
end If
iteration: Do iteration: Do
it = it + 1 it = it + 1
itx = itx + 1 itx = itx + 1
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),'iteration: ',itx & write(debug_unit,*) me,' ',trim(name),'iteration: ',itx
rho_old = rho rho_old = rho
rho = psb_gedot(rt,r,desc_a,info) rho = psb_gedot(rt,r,desc_a,info)
If (rho==zzero) Then if (rho==zzero) then
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' iteration breakdown r',rho & ' iteration breakdown r',rho
Exit iteration exit iteration
Endif endif
If (it==1) Then if (it==1) then
Call psb_geaxpby(zone,r,zzero,uv,desc_a,info) call psb_geaxpby(zone,r,zzero,uv,desc_a,info)
Call psb_geaxpby(zone,r,zzero,p,desc_a,info) call psb_geaxpby(zone,r,zzero,p,desc_a,info)
Else else
beta = (rho/rho_old) beta = (rho/rho_old)
Call psb_geaxpby(zone,r,zzero,uv,desc_a,info) call psb_geaxpby(zone,r,zzero,uv,desc_a,info)
Call psb_geaxpby(beta,q,zone,uv,desc_a,info) call psb_geaxpby(beta,q,zone,uv,desc_a,info)
Call psb_geaxpby(zone,q,beta,p,desc_a,info) call psb_geaxpby(zone,q,beta,p,desc_a,info)
Call psb_geaxpby(zone,uv,beta,p,desc_a,info) call psb_geaxpby(zone,uv,beta,p,desc_a,info)
end if
End If
Call psb_precaply(prec,p,f,desc_a,info,work=aux) call psb_precaply(prec,p,f,desc_a,info,work=aux)
Call psb_spmm(zone,a,f,zzero,v,desc_a,info,& call psb_spmm(zone,a,f,zzero,v,desc_a,info,&
& work=aux) & work=aux)
sigma = psb_gedot(rt,v,desc_a,info) sigma = psb_gedot(rt,v,desc_a,info)
If (sigma==zzero) Then if (sigma==zzero) then
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' iteration breakdown s1', sigma & ' iteration breakdown s1', sigma
Exit iteration exit iteration
Endif endif
alpha = rho/sigma alpha = rho/sigma
Call psb_geaxpby(zone,uv,zzero,q,desc_a,info) call psb_geaxpby(zone,uv,zzero,q,desc_a,info)
Call psb_geaxpby(-alpha,v,zone,q,desc_a,info) call psb_geaxpby(-alpha,v,zone,q,desc_a,info)
Call psb_geaxpby(zone,uv,zzero,s,desc_a,info) call psb_geaxpby(zone,uv,zzero,s,desc_a,info)
Call psb_geaxpby(zone,q,zone,s,desc_a,info) call psb_geaxpby(zone,q,zone,s,desc_a,info)
Call psb_precaply(prec,s,z,desc_a,info,work=aux) call psb_precaply(prec,s,z,desc_a,info,work=aux)
Call psb_geaxpby(alpha,z,zone,x,desc_a,info) call psb_geaxpby(alpha,z,zone,x,desc_a,info)
Call psb_spmm(zone,a,z,zzero,qt,desc_a,info,& call psb_spmm(zone,a,z,zzero,qt,desc_a,info,&
& work=aux) & work=aux)
Call psb_geaxpby(-alpha,qt,zone,r,desc_a,info) call psb_geaxpby(-alpha,qt,zone,r,desc_a,info)
if (istop_ == 1) then if (istop_ == 1) then
@ -333,59 +330,47 @@ Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
errden = bn2 errden = bn2
endif endif
If (errnum <= eps*errden) Then if (errnum <= eps*errden) exit restart
Exit restart if (itx >= litmax) exit restart
End If if (itrace_ > 0) &
& call log_conv(methdname,me,itx,itrace_,errnum,errden,eps)
If (itx.Ge.litmax) Exit restart
end do iteration
If (itrace_ > 0) then end do restart
if ((mod(itx,itrace_)==0).and.(me == 0))&
& write(*,'(a,i4,3(2x,es10.4))') 'cgs: ',itx,errnum,eps*errden if (itrace_ > 0) &
end If & call log_conv(methdname,me,itx,1,errnum,errden,eps)
End Do iteration if (present(err)) then
End Do restart
If (itrace_ > 0) then
if ((mod(itx,itrace_)==0).and.(me == 0))&
& write(*,'(a,i4,3(2x,es10.4))') 'cgs: ',itx,errnum,eps*errden
end If
If (Present(err)) then
if (errden /= dzero) then if (errden /= dzero) then
err = errnum/errden err = errnum/errden
else else
err = errnum err = errnum
end if end if
end If end if
If (Present(iter)) iter = itx if (present(iter)) iter = itx
If ((errnum > eps*errden).and.(me==0)) Then if (errnum > eps*errden) &
write(debug_unit,*) 'cgs failed to converge to ',eps*errden,& & call end_log(methdname,me,itx,errnum,errden,eps)
& ' in ',itx,' iterations '
End If
Deallocate(aux)
Call psb_gefree(wwrk,desc_a,info)
! restore external global coherence behaviour
call psb_restore_coher(ictxt,isvch)
if(info/=0) then deallocate(aux,stat=info)
if (info == 0) call psb_gefree(wwrk,desc_a,info)
if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
! restore external global coherence behaviour
call psb_restore_coher(ictxt,isvch)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then if (err_act == psb_act_abort_) then
call psb_error() call psb_error()
return return
end if end if
return return
End Subroutine psb_zcgs end subroutine psb_zcgs

207
krylov/psb_zcgstab.f90
Unescape Escape View File

@ -92,9 +92,10 @@
! where r is the (preconditioned, recursive ! where r is the (preconditioned, recursive
! estimate of) residual. ! estimate of) residual.
! !
Subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
use psb_base_mod use psb_base_mod
use psb_prec_mod use psb_prec_mod
use psb_krylov_mod, psb_protect_name => psb_zcgstab
Implicit None Implicit None
!!$ parameters !!$ parameters
Type(psb_zspmat_type), Intent(in) :: a Type(psb_zspmat_type), Intent(in) :: a
@ -123,7 +124,8 @@ Subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
real(kind(1.d0)) :: errnum, errden real(kind(1.d0)) :: errnum, errden
!!$ Integer istpb, istpe, ifctb, ifcte, imerr, irank, icomm,immb,imme !!$ Integer istpb, istpe, ifctb, ifcte, imerr, irank, icomm,immb,imme
!!$ Integer mpe_log_get_event_number,mpe_Describe_state,mpe_log_event !!$ Integer mpe_log_get_event_number,mpe_Describe_state,mpe_log_event
character(len=20) :: name character(len=20) :: name
character(len=*), parameter :: methdname='BiCGStab'
info = 0 info = 0
name = 'psb_zcgstab' name = 'psb_zcgstab'
@ -189,17 +191,17 @@ Subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
T => WWRK(:,7) T => WWRK(:,7)
Z => WWRK(:,8) Z => WWRK(:,8)
If (Present(itmax)) Then if (present(itmax)) then
litmax = itmax litmax = itmax
Else else
litmax = 1000 litmax = 1000
Endif endif
If (Present(itrace)) Then if (present(itrace)) then
itrace_ = itrace itrace_ = itrace
Else else
itrace_ = 0 itrace_ = 0
End If end if
! Ensure global coherence for convergence checks. ! Ensure global coherence for convergence checks.
call psb_set_coher(ictxt,isvch) call psb_set_coher(ictxt,isvch)
@ -222,19 +224,19 @@ Subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
!!$ !!$
!!$ r0 = b-Ax0 !!$ r0 = b-Ax0
!!$ !!$
If (itx >= litmax) Exit restart if (itx >= litmax) exit restart
it = 0 it = 0
Call psb_geaxpby(zone,b,zzero,r,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,work=aux)
Call psb_geaxpby(zone,r,zzero,q,desc_a,info) call psb_geaxpby(zone,r,zzero,q,desc_a,info)
if (info /= 0) Then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If end if
rho = zzero rho = zzero
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' On entry to AMAX: B: ',Size(b) & ' On entry to AMAX: B: ',Size(b)
@ -242,52 +244,42 @@ Subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
! Must always provide norm of R into RNI below for first check on ! Must always provide norm of R into RNI below for first check on
! residual ! residual
! !
If (istop_ == 1) Then if (istop_ == 1) then
rni = psb_geamax(r,desc_a,info) rni = psb_geamax(r,desc_a,info)
xni = psb_geamax(x,desc_a,info) xni = psb_geamax(x,desc_a,info)
Else If (istop_ == 2) Then else if (istop_ == 2) then
rni = psb_genrm2(r,desc_a,info) rni = psb_genrm2(r,desc_a,info)
Endif endif
errnum = dzero errnum = dzero
errden = done errden = done
if (info /= 0) Then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If end if
If (itx == 0) Then if (itx == 0) then
rn0 = rni rn0 = rni
End If end if
If (rn0 == 0.d0 ) Then if (rn0 == 0.d0 ) exit restart
If (itrace_ > 0 ) Then
If (me == 0) Write(*,*) 'BiCGSTAB: ',itx,rn0
Endif
Exit restart
End If
If (istop_ == 1) Then if (istop_ == 1) then
xni = psb_geamax(x,desc_a,info) xni = psb_geamax(x,desc_a,info)
errnum = rni errnum = rni
errden = (ani*xni+bni) errden = (ani*xni+bni)
Else If (istop_ == 2) Then else if (istop_ == 2) then
errnum = rni errnum = rni
errden = bn2 errden = bn2
Endif endif
if (info /= 0) Then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If end if
If (errnum <= eps*errden) Then
Exit restart
End If
If (itrace_ > 0) then if (errnum <= eps*errden) exit restart
if (((itx==0).or.(mod(itx,itrace_)==0)).and.(me == 0)) & if (itrace_ > 0) &
& write(*,'(a,i4,3(2x,es10.4))') 'bicgstab: ',itx,errnum,eps*errden & call log_conv(methdname,me,itx,itrace_,errnum,errden,eps)
end If
iteration: Do iteration: Do
it = it + 1 it = it + 1
@ -298,148 +290,133 @@ Subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
rho_old = rho rho_old = rho
rho = psb_gedot(q,r,desc_a,info) rho = psb_gedot(q,r,desc_a,info)
If (debug_level >= psb_debug_ext_) & if (rho==zzero) then
& write(debug_unit,*) me,' ',trim(name),& if (debug_level >= psb_debug_ext_) &
& ' RHO:',rho
If (rho==zzero) Then
If (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' Iteration breakdown R',rho & ' Iteration breakdown R',rho
Exit iteration exit iteration
Endif endif
If (it==1) Then if (it==1) then
Call psb_geaxpby(zone,r,zzero,p,desc_a,info) call psb_geaxpby(zone,r,zzero,p,desc_a,info)
Else else
beta = (rho/rho_old)*(alpha/omega) beta = (rho/rho_old)*(alpha/omega)
Call psb_geaxpby(-omega,v,zone,p,desc_a,info) call psb_geaxpby(-omega,v,zone,p,desc_a,info)
Call psb_geaxpby(zone,r,beta,p,desc_a,info) call psb_geaxpby(zone,r,beta,p,desc_a,info)
End If end if
Call psb_precaply(prec,p,f,desc_a,info,work=aux) call psb_precaply(prec,p,f,desc_a,info,work=aux)
Call psb_spmm(zone,a,f,zzero,v,desc_a,info,& call psb_spmm(zone,a,f,zzero,v,desc_a,info,&
& work=aux) & work=aux)
sigma = psb_gedot(q,v,desc_a,info) sigma = psb_gedot(q,v,desc_a,info)
If (sigma==zzero) Then if (sigma==zzero) then
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' Iteration breakdown S1', sigma & ' Iteration breakdown S1', sigma
Exit iteration exit iteration
Endif endif
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' SIGMA:',sigma & ' SIGMA:',sigma
alpha = rho/sigma alpha = rho/sigma
Call psb_geaxpby(zone,r,zzero,s,desc_a,info) call psb_geaxpby(zone,r,zzero,s,desc_a,info)
if(info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_geaxpby') call psb_errpush(4010,name,a_err='psb_geaxpby')
goto 9999 goto 9999
end if end if
Call psb_geaxpby(-alpha,v,zone,s,desc_a,info) call psb_geaxpby(-alpha,v,zone,s,desc_a,info)
if(info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_geaxpby') call psb_errpush(4010,name,a_err='psb_geaxpby')
goto 9999 goto 9999
end if end if
Call psb_precaply(prec,s,z,desc_a,info,work=aux) call psb_precaply(prec,s,z,desc_a,info,work=aux)
if(info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_precaply') call psb_errpush(4010,name,a_err='psb_precaply')
goto 9999 goto 9999
end if end if
Call psb_spmm(zone,a,z,zzero,t,desc_a,info,& call psb_spmm(zone,a,z,zzero,t,desc_a,info,&
& work=aux) & work=aux)
if(info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_spmm') call psb_errpush(4010,name,a_err='psb_spmm')
goto 9999 goto 9999
end if end if
sigma = psb_gedot(t,t,desc_a,info) sigma = psb_gedot(t,t,desc_a,info)
If (sigma==zzero) Then if (sigma==zzero) then
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' Iteration breakdown S2', sigma & ' Iteration breakdown S2', sigma
Exit iteration exit iteration
Endif endif
tau = psb_gedot(t,s,desc_a,info) tau = psb_gedot(t,s,desc_a,info)
omega = tau/sigma omega = tau/sigma
If (omega==zzero) Then if (omega==zzero) then
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' Iteration breakdown O',omega & ' Iteration breakdown O',omega
Exit iteration exit iteration
Endif endif
Call psb_geaxpby(alpha,f,zone,x,desc_a,info) call psb_geaxpby(alpha,f,zone,x,desc_a,info)
Call psb_geaxpby(omega,z,zone,x,desc_a,info) call psb_geaxpby(omega,z,zone,x,desc_a,info)
Call psb_geaxpby(zone,s,zzero,r,desc_a,info) call psb_geaxpby(zone,s,zzero,r,desc_a,info)
Call psb_geaxpby(-omega,t,zone,r,desc_a,info) call psb_geaxpby(-omega,t,zone,r,desc_a,info)
If (istop_ == 1) Then if (istop_ == 1) then
rni = psb_geamax(r,desc_a,info) rni = psb_geamax(r,desc_a,info)
xni = psb_geamax(x,desc_a,info) xni = psb_geamax(x,desc_a,info)
errnum = rni errnum = rni
errden = (ani*xni+bni) errden = (ani*xni+bni)
Else If (istop_ == 2) Then else if (istop_ == 2) then
rni = psb_genrm2(r,desc_a,info) rni = psb_genrm2(r,desc_a,info)
errnum = rni errnum = rni
errden = bn2 errden = bn2
Endif endif
If (errnum <= eps*errden) Then if (errnum <= eps*errden) exit restart
Exit restart if (itx >= litmax) exit restart
End If if (itrace_ > 0) &
& call log_conv(methdname,me,itx,itrace_,errnum,errden,eps)
If (itx.Ge.litmax) Exit restart end do iteration
end do restart
If (itrace_ > 0) then if (itrace_ > 0) &
if ((mod(itx,itrace_)==0).and.(me == 0)) & & call log_conv(methdname,me,itx,1,errnum,errden,eps)
& write(*,'(a,i4,3(2x,es10.4))') &
& 'bicgstab: ',itx,errnum,eps*errden
Endif
End Do iteration
End Do restart
If (itrace_ > 0) then
if (me == 0) write(*,'(a,i4,3(2x,es10.4))') 'bicgstab: ',itx,errnum,eps*errden
Endif
If (Present(err)) then if (present(err)) then
if (errden /= dzero) then if (errden /= dzero) then
err = errnum/errden err = errnum/errden
else else
err = errnum err = errnum
end if end if
end If end if
If (Present(iter)) iter = itx if (present(iter)) iter = itx
If ((errnum > eps*errden).and.(me==0)) Then if (errnum > eps*errden) &
write(debug_unit,*) 'BI-CGSTAB failed to converge to ',eps*errden,& & call end_log(methdname,me,itx,errnum,errden,eps)
& ' in ',ITX,' iterations. '
End If
Deallocate(aux)
Call psb_gefree(wwrk,desc_a,info)
! restore external global coherence behaviour
call psb_restore_coher(ictxt,isvch)
!!$ imerr = MPE_Log_event( istpe, 0, "ed CGSTAB" ) deallocate(aux,stat=info)
if(info/=0) then if (info == 0) call psb_gefree(wwrk,desc_a,info)
if (info/=0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
! restore external global coherence behaviour
call psb_restore_coher(ictxt,isvch)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then if (err_act == psb_act_abort_) then
call psb_error(ictxt) call psb_error(ictxt)
return return
end if end if

121
krylov/psb_zrgmres.f90
Unescape Escape View File

@ -107,6 +107,7 @@
Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop) Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop)
use psb_base_mod use psb_base_mod
use psb_prec_mod use psb_prec_mod
use psb_krylov_mod, psb_protect_name => psb_zrgmres
implicit none implicit none
!!$ Parameters !!$ Parameters
@ -134,7 +135,8 @@ Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist
Real(Kind(1.d0)) :: rni, xni, bni, ani,bn2 Real(Kind(1.d0)) :: rni, xni, bni, ani,bn2
real(kind(1.d0)), external :: dznrm2 real(kind(1.d0)), external :: dznrm2
real(kind(1.d0)) :: errnum, errden real(kind(1.d0)) :: errnum, errden
character(len=20) :: name character(len=20) :: name
character(len=*), parameter :: methdname='RGMRES'
info = 0 info = 0
name = 'psb_zgmres' name = 'psb_zgmres'
@ -169,29 +171,29 @@ Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist
goto 9999 goto 9999
endif endif
If (Present(itmax)) Then if (present(itmax)) then
litmax = itmax litmax = itmax
Else else
litmax = 1000 litmax = 1000
Endif endif
If (Present(itrace)) Then if (present(itrace)) then
itrace_ = itrace itrace_ = itrace
Else else
itrace_ = 0 itrace_ = 0
End If end if
If (Present(irst)) Then if (present(irst)) then
nl = irst nl = irst
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' present: irst: ',irst,nl & ' present: irst: ',irst,nl
Else else
nl = 10 nl = 10
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' not present: irst: ',irst,nl & ' not present: irst: ',irst,nl
Endif endif
if (nl <=0 ) then if (nl <=0 ) then
info=5001 info=5001
int_err(1)=nl int_err(1)=nl
@ -215,7 +217,7 @@ Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist
naux=4*n_col naux=4*n_col
Allocate(aux(naux),h(nl+1,nl+1),& allocate(aux(naux),h(nl+1,nl+1),&
&c(nl+1),s(nl+1),rs(nl+1), rst(nl+1),stat=info) &c(nl+1),s(nl+1),rs(nl+1), rst(nl+1),stat=info)
if (info == 0) Call psb_geall(v,desc_a,info,n=nl+1) if (info == 0) Call psb_geall(v,desc_a,info,n=nl+1)
@ -226,11 +228,11 @@ Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist
if (info == 0) Call psb_geasb(w,desc_a,info) if (info == 0) Call psb_geasb(w,desc_a,info)
if (info == 0) Call psb_geasb(w1,desc_a,info) if (info == 0) Call psb_geasb(w1,desc_a,info)
if (info == 0) Call psb_geasb(xt,desc_a,info) if (info == 0) Call psb_geasb(xt,desc_a,info)
if (info.ne.0) Then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If end if
if (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' Size of V,W,W1 ',size(v),size(v,1),& & ' Size of V,W,W1 ',size(v),size(v,1),&
@ -247,11 +249,11 @@ Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist
endif endif
errnum = dzero errnum = dzero
errden = done errden = done
if (info.ne.0) Then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If end if
itx = 0 itx = 0
restart: Do restart: Do
@ -260,19 +262,19 @@ Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist
! check convergence ! check convergence
! compute v1 = r0/||r0||_2 ! compute v1 = r0/||r0||_2
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' restart: ',itx,it & ' restart: ',itx,it
it = 0 it = 0
Call psb_geaxpby(zone,b,zzero,v(:,1),desc_a,info) call psb_geaxpby(zone,b,zzero,v(:,1),desc_a,info)
if (info.ne.0) Then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If 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,work=aux)
if (info.ne.0) Then if (info /= 0) Then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -280,14 +282,14 @@ Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist
rs(1) = psb_genrm2(v(:,1),desc_a,info) rs(1) = psb_genrm2(v(:,1),desc_a,info)
rs(2:) = zzero rs(2:) = zzero
if (info.ne.0) Then if (info /= 0) Then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If end if
scal=done/rs(1) ! rs(1) MIGHT BE VERY SMALL - USE DSCAL TO DEAL WITH IT? scal=done/rs(1) ! rs(1) MIGHT BE VERY SMALL - USE DSCAL TO DEAL WITH IT?
If (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' on entry to amax: b: ',Size(b),rs(1),scal & ' on entry to amax: b: ',Size(b),rs(1),scal
@ -304,24 +306,20 @@ Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist
errnum = rni errnum = rni
errden = bn2 errden = bn2
endif endif
if (info.ne.0) Then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
End If end if
If (errnum <= eps*errden) Then if (errnum <= eps*errden) exit restart
Exit restart
End If
If (itrace_ > 0) then if (itrace_ > 0) &
if ((mod(itx,itrace_)==0).and.(me == 0))& & call log_conv(methdname,me,itx,itrace_,errnum,errden,eps)
& write(*,'(a,i4,3(2x,es10.4))') 'gmres(l): ',itx,errnum,eps*errden
end If
v(:,1) = v(:,1) * scal v(:,1) = v(:,1) * scal
If (itx.Ge.litmax) Exit restart if (itx >= litmax) exit restart
! !
! inner iterations ! inner iterations
@ -410,12 +408,10 @@ Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist
end if end if
If (itrace_ > 0) then if (itrace_ > 0) &
if ((mod(itx,itrace_)==0).and.(me == 0))& & call log_conv(methdname,me,itx,itrace_,errnum,errden,eps)
& write(*,'(a,i4,3(2x,es10.4))') 'gmres(l): ',itx,errnum,eps*errden
end If
end Do inner end do inner
if (istop_ == 1) then if (istop_ == 1) then
x = xt x = xt
@ -435,46 +431,41 @@ Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist
call psb_geaxpby(zone,w,zone,x,desc_a,info) call psb_geaxpby(zone,w,zone,x,desc_a,info)
end if end if
End Do restart end do restart
If (itrace_ > 0) then if (itrace_ > 0) &
if (me == 0) write(*,'(a,i4,3(2x,es10.4))') 'gmres(l): ',itx,errnum,eps*errden & call log_conv(methdname,me,itx,1,errnum,errden,eps)
end If
If (Present(err)) then if (present(err)) then
if (errden /= dzero) then if (errden /= dzero) then
err = errnum/errden err = errnum/errden
else else
err = errnum err = errnum
end if end if
end If end if
If (Present(iter)) iter = itx if (present(iter)) iter = itx
If ((errnum > eps*errden).and.(me==0)) Then if (errnum > eps*errden) &
write(debug_unit,*) 'rgmres(l) failed to converge to ',eps*errden,& & call end_log(methdname,me,itx,errnum,errden,eps)
& ' in ',itx,' iterations '
End If deallocate(aux,h,c,s,rs,rst, stat=info)
if (info == 0) call psb_gefree(v,desc_a,info)
if (info == 0) call psb_gefree(w,desc_a,info)
Deallocate(aux,h,c,s,rs,rst, stat=info) if (info == 0) call psb_gefree(w1,desc_a,info)
Call psb_gefree(v,desc_a,info) if (info == 0) call psb_gefree(xt,desc_a,info)
Call psb_gefree(w,desc_a,info)
Call psb_gefree(w1,desc_a,info)
Call psb_gefree(xt,desc_a,info)
! restore external global coherence behaviour
call psb_restore_coher(ictxt,isvch)
if (info /= 0) then if (info /= 0) then
info=4011 info=4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
! restore external global coherence behaviour
call psb_restore_coher(ictxt,isvch)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then if (err_act == psb_act_abort_) then
call psb_error() call psb_error()
return return
end if end if
@ -544,7 +535,7 @@ contains
! .. executable statements .. ! .. executable statements ..
! !
if( n.le.0 ) return if( n.le.0 ) return
if( incx.eq.1 .and. incy.eq.1 ) then if( incx == 1 .and. incy == 1 ) then
! !
! code for both increments equal to 1 ! code for both increments equal to 1
! !

Write Preview
Loading…
Cancel
Save