You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
amg4psblas/mlprec/archive/mld_s_base_solver_impl.f90

339 lines
9.3 KiB
Fortran

!
! Apply: comes in two versions, on plain arrays or on encapsulated
! vectors.
! The base version throws an error, since it means that no explicit
! choice was made.
! Question: would it make sense to transform the base version into
! the ID version, i.e. "base_solver" is the identity operator?
!
subroutine mld_s_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_base_mod
use mld_s_base_solver_mod, mld_protect_name => mld_s_base_solver_apply
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(mld_s_base_solver_type), intent(in) :: sv
real(psb_spk_),intent(inout) :: x(:)
real(psb_spk_),intent(inout) :: y(:)
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_base_solver_apply'
call psb_erractionsave(err_act)
info = psb_err_missing_override_method_
call psb_errpush(info,name)
goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_s_base_solver_apply
subroutine mld_s_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_base_mod
use mld_s_base_solver_mod, mld_protect_name => mld_s_base_solver_apply_vect
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(mld_s_base_solver_type), intent(inout) :: sv
type(psb_s_vect_type),intent(inout) :: x
type(psb_s_vect_type),intent(inout) :: y
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_base_solver_apply'
call psb_erractionsave(err_act)
info = psb_err_missing_override_method_
call psb_errpush(info,name)
goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_s_base_solver_apply_vect
!
! Build
! The base version throws an error, since it means that no explicit
! choice was made.
!
subroutine mld_s_base_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold)
use psb_base_mod
use mld_s_base_solver_mod, mld_protect_name => mld_s_base_solver_bld
Implicit None
! Arguments
type(psb_sspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_s_base_solver_type), intent(inout) :: sv
character, intent(in) :: upd
integer, intent(out) :: info
type(psb_sspmat_type), intent(in), target, optional :: b
class(psb_s_base_sparse_mat), intent(in), optional :: amold
class(psb_s_base_vect_type), intent(in), optional :: vmold
Integer :: err_act
character(len=20) :: name='d_base_solver_bld'
call psb_erractionsave(err_act)
info = psb_err_missing_override_method_
call psb_errpush(info,name)
goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_s_base_solver_bld
subroutine mld_s_base_solver_check(sv,info)
use psb_base_mod
use mld_s_base_solver_mod, mld_protect_name => mld_s_base_solver_check
Implicit None
! Arguments
class(mld_s_base_solver_type), intent(inout) :: sv
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_base_solver_check'
call psb_erractionsave(err_act)
info = psb_success_
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_s_base_solver_check
!
! Set.
! The base version does nothing; the principle is that
! SET acts on what is known, and delegates what is unknown.
! Since we are at the bottom of the hierarchy, there's no one
! to delegate, so we do nothing.
!
subroutine mld_s_base_solver_seti(sv,what,val,info)
use psb_base_mod
use mld_s_base_solver_mod, mld_protect_name => mld_s_base_solver_seti
Implicit None
! Arguments
class(mld_s_base_solver_type), intent(inout) :: sv
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_base_solver_seti'
! Correct action here is doing nothing.
info = 0
return
end subroutine mld_s_base_solver_seti
subroutine mld_s_base_solver_setc(sv,what,val,info)
use psb_base_mod
use mld_s_base_solver_mod, mld_protect_name => mld_s_base_solver_setc
Implicit None
! Arguments
class(mld_s_base_solver_type), intent(inout) :: sv
integer, intent(in) :: what
character(len=*), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act, ival
character(len=20) :: name='d_base_solver_setc'
call psb_erractionsave(err_act)
info = psb_success_
call mld_stringval(val,ival,info)
if (info == psb_success_) call sv%set(what,ival,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_s_base_solver_setc
subroutine mld_s_base_solver_setr(sv,what,val,info)
use psb_base_mod
use mld_s_base_solver_mod, mld_protect_name => mld_s_base_solver_setr
Implicit None
! Arguments
class(mld_s_base_solver_type), intent(inout) :: sv
integer, intent(in) :: what
real(psb_spk_), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_base_solver_setr'
! Correct action here is doing nothing.
info = 0
return
end subroutine mld_s_base_solver_setr
!
! Free
! The base version throws an error, since it means that no explicit
! choice was made. IS THIS CORRECT? I suspect it would be better
! to be silent here, to cover reallocation.
!
subroutine mld_s_base_solver_free(sv,info)
use psb_base_mod
use mld_s_base_solver_mod, mld_protect_name => mld_s_base_solver_free
Implicit None
! Arguments
class(mld_s_base_solver_type), intent(inout) :: sv
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_base_solver_free'
call psb_erractionsave(err_act)
info = psb_err_missing_override_method_
call psb_errpush(info,name)
goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_s_base_solver_free
subroutine mld_s_base_solver_descr(sv,info,iout,coarse)
use psb_base_mod
use mld_s_base_solver_mod, mld_protect_name => mld_s_base_solver_descr
Implicit None
! Arguments
class(mld_s_base_solver_type), intent(in) :: sv
integer, intent(out) :: info
integer, intent(in), optional :: iout
logical, intent(in), optional :: coarse
! Local variables
integer :: err_act
integer :: ictxt, me, np
character(len=20), parameter :: name='mld_s_base_solver_descr'
integer :: iout_
call psb_erractionsave(err_act)
info = psb_err_missing_override_method_
call psb_errpush(info,name)
goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_s_base_solver_descr
!
! Dump. For debugging purposes.
!
subroutine mld_s_base_solver_dmp(sv,ictxt,level,info,prefix,head,solver)
use psb_base_mod
use mld_s_base_solver_mod, mld_protect_name => mld_s_base_solver_dmp
implicit none
class(mld_s_base_solver_type), intent(in) :: sv
integer, intent(in) :: ictxt,level
integer, intent(out) :: info
character(len=*), intent(in), optional :: prefix, head
logical, optional, intent(in) :: solver
integer :: i, j, il1, iln, lname, lev
integer :: icontxt,iam, np
character(len=80) :: prefix_
character(len=120) :: fname ! len should be at least 20 more than
logical :: solver_
! len of prefix_
info = 0
if (present(prefix)) then
prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
else
prefix_ = "dump_slv_s"
end if
call psb_info(ictxt,iam,np)
if (present(solver)) then
solver_ = solver
else
solver_ = .false.
end if
lname = len_trim(prefix_)
fname = trim(prefix_)
write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
lname = lname + 5
! At base level do nothing for the solver
end subroutine mld_s_base_solver_dmp