From cfb2f9ffa88008ab90d3fc03060e19160eda8365 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sun, 31 Mar 2013 10:13:10 +0000 Subject: [PATCH] psblas3: prec/impl/psb_c_diagprec_impl.f90 prec/impl/psb_d_diagprec_impl.f90 prec/impl/psb_s_diagprec_impl.f90 prec/impl/psb_z_diagprec_impl.f90 prec/psb_c_base_prec_mod.f90 prec/psb_c_bjacprec.f90 prec/psb_c_diagprec.f90 prec/psb_c_nullprec.f90 prec/psb_d_base_prec_mod.f90 prec/psb_d_bjacprec.f90 prec/psb_d_diagprec.f90 prec/psb_d_nullprec.f90 prec/psb_s_base_prec_mod.f90 prec/psb_s_bjacprec.f90 prec/psb_s_diagprec.f90 prec/psb_s_nullprec.f90 prec/psb_z_base_prec_mod.f90 prec/psb_z_bjacprec.f90 prec/psb_z_diagprec.f90 prec/psb_z_nullprec.f90 Make base_prec_type ABSTRACT. Adjust some default implementations. --- prec/impl/psb_c_diagprec_impl.f90 | 34 +++ prec/impl/psb_d_diagprec_impl.f90 | 34 +++ prec/impl/psb_s_diagprec_impl.f90 | 34 +++ prec/impl/psb_z_diagprec_impl.f90 | 34 +++ prec/psb_c_base_prec_mod.f90 | 455 ++++++++++-------------------- prec/psb_c_bjacprec.f90 | 2 +- prec/psb_c_diagprec.f90 | 96 +------ prec/psb_c_nullprec.f90 | 133 +++------ prec/psb_d_base_prec_mod.f90 | 455 ++++++++++-------------------- prec/psb_d_bjacprec.f90 | 2 +- prec/psb_d_diagprec.f90 | 96 +------ prec/psb_d_nullprec.f90 | 133 +++------ prec/psb_s_base_prec_mod.f90 | 455 ++++++++++-------------------- prec/psb_s_bjacprec.f90 | 2 +- prec/psb_s_diagprec.f90 | 96 +------ prec/psb_s_nullprec.f90 | 133 +++------ prec/psb_z_base_prec_mod.f90 | 455 ++++++++++-------------------- prec/psb_z_bjacprec.f90 | 2 +- prec/psb_z_diagprec.f90 | 96 +------ prec/psb_z_nullprec.f90 | 133 +++------ 20 files changed, 964 insertions(+), 1916 deletions(-) diff --git a/prec/impl/psb_c_diagprec_impl.f90 b/prec/impl/psb_c_diagprec_impl.f90 index b4309eac..cb09a076 100644 --- a/prec/impl/psb_c_diagprec_impl.f90 +++ b/prec/impl/psb_c_diagprec_impl.f90 @@ -30,6 +30,40 @@ !!$ !!$ +subroutine psb_c_diag_dump(prec,info,prefix,head) + use psb_base_mod + use psb_c_diagprec, psb_protect_name => psb_c_diag_dump + implicit none + class(psb_c_diag_prec_type), intent(in) :: prec + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + integer(psb_ipk_) :: i, j, il1, iln, lname, lev + integer(psb_ipk_) :: ictxt,iam, np + character(len=80) :: prefix_ + character(len=120) :: fname ! len should be at least 20 more than + + ! len of prefix_ + + info = 0 + ictxt = prec%get_ctxt() + call psb_info(ictxt,iam,np) + + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_diag_c" + end if + + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + write(fname(lname+1:),'(a,a)')'_diag.mtx' + if (allocated(prec%dv)) & + & call psb_geprt(fname,prec%dv%v%v,head=head) + +end subroutine psb_c_diag_dump + + subroutine psb_c_diag_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) use psb_base_mod use psb_c_diagprec, psb_protect_name => psb_c_diag_apply_vect diff --git a/prec/impl/psb_d_diagprec_impl.f90 b/prec/impl/psb_d_diagprec_impl.f90 index 350c4ee6..751501a7 100644 --- a/prec/impl/psb_d_diagprec_impl.f90 +++ b/prec/impl/psb_d_diagprec_impl.f90 @@ -30,6 +30,40 @@ !!$ !!$ +subroutine psb_d_diag_dump(prec,info,prefix,head) + use psb_base_mod + use psb_d_diagprec, psb_protect_name => psb_d_diag_dump + implicit none + class(psb_d_diag_prec_type), intent(in) :: prec + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + integer(psb_ipk_) :: i, j, il1, iln, lname, lev + integer(psb_ipk_) :: ictxt,iam, np + character(len=80) :: prefix_ + character(len=120) :: fname ! len should be at least 20 more than + + ! len of prefix_ + + info = 0 + ictxt = prec%get_ctxt() + call psb_info(ictxt,iam,np) + + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_diag_d" + end if + + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + write(fname(lname+1:),'(a,a)')'_diag.mtx' + if (allocated(prec%dv)) & + & call psb_geprt(fname,prec%dv%v%v,head=head) + +end subroutine psb_d_diag_dump + + subroutine psb_d_diag_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) use psb_base_mod use psb_d_diagprec, psb_protect_name => psb_d_diag_apply_vect diff --git a/prec/impl/psb_s_diagprec_impl.f90 b/prec/impl/psb_s_diagprec_impl.f90 index 6092f438..1869d50e 100644 --- a/prec/impl/psb_s_diagprec_impl.f90 +++ b/prec/impl/psb_s_diagprec_impl.f90 @@ -30,6 +30,40 @@ !!$ !!$ +subroutine psb_s_diag_dump(prec,info,prefix,head) + use psb_base_mod + use psb_s_diagprec, psb_protect_name => psb_s_diag_dump + implicit none + class(psb_s_diag_prec_type), intent(in) :: prec + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + integer(psb_ipk_) :: i, j, il1, iln, lname, lev + integer(psb_ipk_) :: ictxt,iam, np + character(len=80) :: prefix_ + character(len=120) :: fname ! len should be at least 20 more than + + ! len of prefix_ + + info = 0 + ictxt = prec%get_ctxt() + call psb_info(ictxt,iam,np) + + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_diag_s" + end if + + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + write(fname(lname+1:),'(a,a)')'_diag.mtx' + if (allocated(prec%dv)) & + & call psb_geprt(fname,prec%dv%v%v,head=head) + +end subroutine psb_s_diag_dump + + subroutine psb_s_diag_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) use psb_base_mod use psb_s_diagprec, psb_protect_name => psb_s_diag_apply_vect diff --git a/prec/impl/psb_z_diagprec_impl.f90 b/prec/impl/psb_z_diagprec_impl.f90 index 4793c667..8b4a7878 100644 --- a/prec/impl/psb_z_diagprec_impl.f90 +++ b/prec/impl/psb_z_diagprec_impl.f90 @@ -30,6 +30,40 @@ !!$ !!$ +subroutine psb_z_diag_dump(prec,info,prefix,head) + use psb_base_mod + use psb_z_diagprec, psb_protect_name => psb_z_diag_dump + implicit none + class(psb_z_diag_prec_type), intent(in) :: prec + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + integer(psb_ipk_) :: i, j, il1, iln, lname, lev + integer(psb_ipk_) :: ictxt,iam, np + character(len=80) :: prefix_ + character(len=120) :: fname ! len should be at least 20 more than + + ! len of prefix_ + + info = 0 + ictxt = prec%get_ctxt() + call psb_info(ictxt,iam,np) + + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_diag_z" + end if + + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + write(fname(lname+1:),'(a,a)')'_diag.mtx' + if (allocated(prec%dv)) & + & call psb_geprt(fname,prec%dv%v%v,head=head) + +end subroutine psb_z_diag_dump + + subroutine psb_z_diag_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) use psb_base_mod use psb_z_diagprec, psb_protect_name => psb_z_diag_apply_vect diff --git a/prec/psb_c_base_prec_mod.f90 b/prec/psb_c_base_prec_mod.f90 index d1d8b6c7..ce3e3051 100644 --- a/prec/psb_c_base_prec_mod.f90 +++ b/prec/psb_c_base_prec_mod.f90 @@ -45,176 +45,146 @@ module psb_c_base_prec_mod use psb_prec_const_mod - type psb_c_base_prec_type + type, abstract :: psb_c_base_prec_type integer(psb_ipk_) :: ictxt contains - procedure, pass(prec) :: set_ctxt => psb_c_base_set_ctxt - procedure, pass(prec) :: get_ctxt => psb_c_base_get_ctxt - procedure, pass(prec) :: c_apply_v => psb_c_base_apply_vect - procedure, pass(prec) :: c_apply => psb_c_base_apply - generic, public :: apply => c_apply, c_apply_v - procedure, pass(prec) :: precbld => psb_c_base_precbld - procedure, pass(prec) :: precseti => psb_c_base_precseti - procedure, pass(prec) :: precsetr => psb_c_base_precsetr - procedure, pass(prec) :: precsetc => psb_c_base_precsetc - procedure, pass(prec) :: sizeof => psb_c_base_sizeof - generic, public :: precset => precseti, precsetr, precsetc - procedure, pass(prec) :: precinit => psb_c_base_precinit - procedure, pass(prec) :: precfree => psb_c_base_precfree - procedure, pass(prec) :: precdescr => psb_c_base_precdescr - procedure, pass(prec) :: dump => psb_c_base_precdump + procedure, pass(prec) :: set_ctxt => psb_c_base_set_ctxt + procedure, pass(prec) :: get_ctxt => psb_c_base_get_ctxt procedure, pass(prec) :: get_nzeros => psb_c_base_get_nzeros + procedure, pass(prec) :: precseti => psb_c_base_precseti + procedure, pass(prec) :: precsetr => psb_c_base_precsetr + procedure, pass(prec) :: precsetc => psb_c_base_precsetc + generic, public :: precset => precseti, precsetr, precsetc + procedure(psb_c_base_apply_vect), pass(prec), deferred :: c_apply_v + procedure(psb_c_base_apply), pass(prec), deferred :: c_apply + generic, public :: apply => c_apply, c_apply_v + procedure(psb_c_base_precbld), pass(prec), deferred :: precbld + procedure(psb_c_base_sizeof), pass(prec), deferred :: sizeof + procedure(psb_c_base_precinit), pass(prec), deferred :: precinit + procedure(psb_c_base_precfree), pass(prec), deferred :: precfree + procedure(psb_c_base_precdescr), pass(prec), deferred :: precdescr + procedure(psb_c_base_precdump), pass(prec), deferred :: dump end type psb_c_base_prec_type - - private :: psb_c_base_apply, psb_c_base_precbld, psb_c_base_precseti,& - & psb_c_base_precsetr, psb_c_base_precsetc, psb_c_base_sizeof,& - & psb_c_base_precinit, psb_c_base_precfree, psb_c_base_precdescr,& - & psb_c_base_precdump, psb_c_base_set_ctxt, psb_c_base_get_ctxt, & - & psb_c_base_apply_vect, psb_c_base_get_nzeros - -contains - - subroutine psb_c_base_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) - implicit none - type(psb_desc_type),intent(in) :: desc_data - class(psb_c_base_prec_type), intent(inout) :: prec - complex(psb_spk_),intent(in) :: alpha, beta - type(psb_c_vect_type),intent(inout) :: x - type(psb_c_vect_type),intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - character(len=1), optional :: trans - complex(psb_spk_),intent(inout), optional, target :: work(:) - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='c_base_prec_apply' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_c_base_apply_vect - - subroutine psb_c_base_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) - implicit none - type(psb_desc_type),intent(in) :: desc_data - class(psb_c_base_prec_type), intent(in) :: prec - complex(psb_spk_),intent(in) :: alpha, beta - complex(psb_spk_),intent(inout) :: x(:) - complex(psb_spk_),intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character(len=1), optional :: trans - complex(psb_spk_),intent(inout), optional, target :: work(:) - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='c_base_prec_apply' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_c_base_apply + private :: psb_c_base_set_ctxt, psb_c_base_get_ctxt, & + & psb_c_base_get_nzeros + + abstract interface + subroutine psb_c_base_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + import psb_ipk_, psb_spk_, psb_desc_type, psb_c_vect_type, & + & psb_c_base_vect_type, psb_cspmat_type, psb_c_base_prec_type,& + & psb_c_base_sparse_mat + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_c_base_prec_type), intent(inout) :: prec + complex(psb_spk_),intent(in) :: alpha, beta + type(psb_c_vect_type),intent(inout) :: x + type(psb_c_vect_type),intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + + end subroutine psb_c_base_apply_vect + end interface + + abstract interface + subroutine psb_c_base_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + import psb_ipk_, psb_spk_, psb_desc_type, psb_c_vect_type, & + & psb_c_base_vect_type, psb_cspmat_type, psb_c_base_prec_type,& + & psb_c_base_sparse_mat + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_c_base_prec_type), intent(in) :: prec + complex(psb_spk_),intent(in) :: alpha, beta + complex(psb_spk_),intent(inout) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + + end subroutine psb_c_base_apply + end interface + + + abstract interface + subroutine psb_c_base_precinit(prec,info) + import psb_ipk_, psb_spk_, psb_desc_type, psb_c_vect_type, & + & psb_c_base_vect_type, psb_cspmat_type, psb_c_base_prec_type,& + & psb_c_base_sparse_mat + Implicit None + + class(psb_c_base_prec_type),intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info + + end subroutine psb_c_base_precinit + end interface + + + abstract interface + subroutine psb_c_base_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) + import psb_ipk_, psb_spk_, psb_desc_type, psb_c_vect_type, & + & psb_c_base_vect_type, psb_cspmat_type, psb_c_base_prec_type,& + & psb_c_base_sparse_mat + Implicit None + + type(psb_cspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_c_base_prec_type),intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: upd + character(len=*), intent(in), optional :: afmt + class(psb_c_base_sparse_mat), intent(in), optional :: amold + class(psb_c_base_vect_type), intent(in), optional :: vmold + + end subroutine psb_c_base_precbld + end interface + + + abstract interface + subroutine psb_c_base_precfree(prec,info) + import psb_ipk_, psb_spk_, psb_desc_type, psb_c_vect_type, & + & psb_c_base_vect_type, psb_cspmat_type, psb_c_base_prec_type,& + & psb_c_base_sparse_mat + Implicit None + + class(psb_c_base_prec_type), intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info + + end subroutine psb_c_base_precfree + end interface + + + abstract interface + subroutine psb_c_base_precdescr(prec,iout) + import psb_ipk_, psb_spk_, psb_desc_type, psb_c_vect_type, & + & psb_c_base_vect_type, psb_cspmat_type, psb_c_base_prec_type,& + & psb_c_base_sparse_mat + Implicit None + + class(psb_c_base_prec_type), intent(in) :: prec + integer(psb_ipk_), intent(in), optional :: iout + + end subroutine psb_c_base_precdescr + end interface + + abstract interface + subroutine psb_c_base_precdump(prec,info,prefix,head) + import psb_ipk_, psb_spk_, psb_desc_type, psb_c_vect_type, & + & psb_c_base_vect_type, psb_cspmat_type, psb_c_base_prec_type,& + & psb_c_base_sparse_mat + implicit none + class(psb_c_base_prec_type), intent(in) :: prec + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + + end subroutine psb_c_base_precdump + end interface - subroutine psb_c_base_precinit(prec,info) - Implicit None - - class(psb_c_base_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='c_base_precinit' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_c_base_precinit - - subroutine psb_c_base_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - Implicit None - - type(psb_cspmat_type), intent(in), target :: a - type(psb_desc_type), intent(in), target :: desc_a - class(psb_c_base_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: upd - character(len=*), intent(in), optional :: afmt - class(psb_c_base_sparse_mat), intent(in), optional :: amold - class(psb_c_base_vect_type), intent(in), optional :: vmold - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='c_base_precbld' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_c_base_precbld +contains subroutine psb_c_base_precseti(prec,what,val,info) Implicit None - + class(psb_c_base_prec_type),intent(inout) :: prec integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val @@ -222,31 +192,18 @@ contains integer(psb_ipk_) :: err_act, nrow character(len=20) :: name='c_base_precseti' - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? ! - info = 700 - call psb_errpush(info,name) - goto 9999 - - call psb_erractionrestore(err_act) - return + ! Base version does nothing. + + info = psb_success_ -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return + end subroutine psb_c_base_precseti subroutine psb_c_base_precsetr(prec,what,val,info) Implicit None - + class(psb_c_base_prec_type),intent(inout) :: prec integer(psb_ipk_), intent(in) :: what real(psb_spk_), intent(in) :: val @@ -254,31 +211,20 @@ contains integer(psb_ipk_) :: err_act, nrow character(len=20) :: name='c_base_precsetr' - call psb_erractionsave(err_act) ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? + ! Base version does nothing. ! - info = 700 - 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 + info = psb_success_ + return + end subroutine psb_c_base_precsetr subroutine psb_c_base_precsetc(prec,what,val,info) Implicit None - + class(psb_c_base_prec_type),intent(inout) :: prec integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val @@ -286,123 +232,16 @@ contains integer(psb_ipk_) :: err_act, nrow character(len=20) :: name='c_base_precsetc' - call psb_erractionsave(err_act) ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? + ! Base version does nothing. ! - info = 700 - 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 psb_c_base_precsetc - - subroutine psb_c_base_precfree(prec,info) - Implicit None - - class(psb_c_base_prec_type), intent(inout) :: prec - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='c_base_precfree' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - call psb_errpush(info,name) - goto 9999 - - call psb_erractionrestore(err_act) - return + info = psb_success_ -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return - - end subroutine psb_c_base_precfree - - - subroutine psb_c_base_precdescr(prec,iout) - Implicit None - class(psb_c_base_prec_type), intent(in) :: prec - integer(psb_ipk_), intent(in), optional :: iout - - integer(psb_ipk_) :: err_act, nrow, info - character(len=20) :: name='c_base_precdescr' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_c_base_precdescr - - subroutine psb_c_base_precdump(prec,info,prefix,head) - implicit none - class(psb_c_base_prec_type), intent(in) :: prec - integer(psb_ipk_), intent(out) :: info - character(len=*), intent(in), optional :: prefix,head - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='c_base_precdump' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_c_base_precdump + end subroutine psb_c_base_precsetc subroutine psb_c_base_set_ctxt(prec,ictxt) implicit none @@ -416,7 +255,7 @@ contains function psb_c_base_sizeof(prec) result(val) class(psb_c_base_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: val - + val = 0 return end function psb_c_base_sizeof @@ -424,7 +263,7 @@ contains function psb_c_base_get_ctxt(prec) result(val) class(psb_c_base_prec_type), intent(in) :: prec integer(psb_ipk_) :: val - + val = prec%ictxt return end function psb_c_base_get_ctxt @@ -432,7 +271,7 @@ contains function psb_c_base_get_nzeros(prec) result(res) class(psb_c_base_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: res - + res = 0 end function psb_c_base_get_nzeros diff --git a/prec/psb_c_bjacprec.f90 b/prec/psb_c_bjacprec.f90 index 5fc18244..8454015c 100644 --- a/prec/psb_c_bjacprec.f90 +++ b/prec/psb_c_bjacprec.f90 @@ -34,7 +34,7 @@ module psb_c_bjacprec use psb_c_base_prec_mod type, extends(psb_c_base_prec_type) :: psb_c_bjac_prec_type - integer(psb_ipk_), allocatable :: iprcparm(:) + integer(psb_ipk_), allocatable :: iprcparm(:) type(psb_cspmat_type), allocatable :: av(:) type(psb_c_vect_type), allocatable :: dv contains diff --git a/prec/psb_c_diagprec.f90 b/prec/psb_c_diagprec.f90 index 359915d7..051c630a 100644 --- a/prec/psb_c_diagprec.f90 +++ b/prec/psb_c_diagprec.f90 @@ -41,17 +41,14 @@ module psb_c_diagprec procedure, pass(prec) :: c_apply => psb_c_diag_apply procedure, pass(prec) :: precbld => psb_c_diag_precbld procedure, pass(prec) :: precinit => psb_c_diag_precinit - procedure, pass(prec) :: precseti => psb_c_diag_precseti - procedure, pass(prec) :: precsetr => psb_c_diag_precsetr - procedure, pass(prec) :: precsetc => psb_c_diag_precsetc procedure, pass(prec) :: precfree => psb_c_diag_precfree procedure, pass(prec) :: precdescr => psb_c_diag_precdescr procedure, pass(prec) :: sizeof => psb_c_diag_sizeof + procedure, pass(prec) :: dump => psb_c_diag_dump procedure, pass(prec) :: get_nzeros => psb_c_diag_get_nzeros end type psb_c_diag_prec_type - private :: psb_c_diag_precseti,& - & psb_c_diag_precsetr, psb_c_diag_precsetc, psb_c_diag_sizeof,& + private :: psb_c_diag_sizeof,& & psb_c_diag_precinit, psb_c_diag_precfree, psb_c_diag_precdescr,& & psb_c_diag_get_nzeros @@ -99,6 +96,16 @@ module psb_c_diagprec class(psb_c_base_vect_type), intent(in), optional :: vmold end subroutine psb_c_diag_precbld end interface + + interface + subroutine psb_c_diag_dump(prec,info,prefix,head) + import :: psb_ipk_, psb_desc_type, psb_c_diag_prec_type, psb_c_vect_type, psb_spk_ + implicit none + class(psb_c_diag_prec_type), intent(in) :: prec + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + end subroutine psb_c_diag_dump + end interface contains @@ -130,85 +137,6 @@ contains end subroutine psb_c_diag_precinit - subroutine psb_c_diag_precseti(prec,what,val,info) - Implicit None - - class(psb_c_diag_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='c_diag_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_c_diag_precseti - - subroutine psb_c_diag_precsetr(prec,what,val,info) - - Implicit None - - class(psb_c_diag_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - real(psb_spk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='c_diag_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_c_diag_precsetr - - subroutine psb_c_diag_precsetc(prec,what,val,info) - Implicit None - - class(psb_c_diag_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='c_diag_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_c_diag_precsetc - subroutine psb_c_diag_precfree(prec,info) Implicit None diff --git a/prec/psb_c_nullprec.f90 b/prec/psb_c_nullprec.f90 index 365cfffd..e60c0547 100644 --- a/prec/psb_c_nullprec.f90 +++ b/prec/psb_c_nullprec.f90 @@ -39,16 +39,13 @@ module psb_c_nullprec procedure, pass(prec) :: c_apply => psb_c_null_apply procedure, pass(prec) :: precbld => psb_c_null_precbld procedure, pass(prec) :: precinit => psb_c_null_precinit - procedure, pass(prec) :: precseti => psb_c_null_precseti - procedure, pass(prec) :: precsetr => psb_c_null_precsetr - procedure, pass(prec) :: precsetc => psb_c_null_precsetc procedure, pass(prec) :: precfree => psb_c_null_precfree procedure, pass(prec) :: precdescr => psb_c_null_precdescr procedure, pass(prec) :: sizeof => psb_c_null_sizeof + procedure, pass(prec) :: dump => psb_c_null_dump end type psb_c_null_prec_type - private :: psb_c_null_precbld, psb_c_null_precseti,& - & psb_c_null_precsetr, psb_c_null_precsetc, psb_c_null_sizeof,& + private :: psb_c_null_precbld, psb_c_null_sizeof,& & psb_c_null_precinit, psb_c_null_precfree, psb_c_null_precdescr @@ -142,87 +139,6 @@ contains return end subroutine psb_c_null_precbld - subroutine psb_c_null_precseti(prec,what,val,info) - - Implicit None - - class(psb_c_null_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='c_null_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_c_null_precseti - - subroutine psb_c_null_precsetr(prec,what,val,info) - - Implicit None - - class(psb_c_null_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - real(psb_spk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='c_null_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_c_null_precsetr - - subroutine psb_c_null_precsetc(prec,what,val,info) - - Implicit None - - class(psb_c_null_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='c_null_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_c_null_precsetc - subroutine psb_c_null_precfree(prec,info) Implicit None @@ -287,6 +203,51 @@ contains end subroutine psb_c_null_precdescr + + subroutine psb_c_null_dump(prec,info,prefix,head) + use psb_base_mod, only : psb_info + implicit none + class(psb_c_null_prec_type), intent(in) :: prec + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + integer(psb_ipk_) :: iout, iam, np, ictxt, lname + logical :: isopen + character(len=80) :: prefix_ + character(len=120) :: fname ! len should be at least 20 more than + + ! len of prefix_ + + info = 0 + ictxt = prec%get_ctxt() + call psb_info(ictxt,iam,np) + + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_null_c" + end if + + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + lname = lname + 5 + ! Search for an unused unit to write + iout = 7 + do + inquire(unit=iout, opened=isopen) + if (.not.isopen) exit + iout = iout + 1 + if (iout > 99) exit + end do + if (iout > 99) then + write(psb_err_unit,*) 'Error: could not find a free unit for I/O' + return + end if + open(iout,file=fname,iostat=info) + write(iout,*) 'Null (Identity) Preconditioner. Nothing to be printed, really!' + + end subroutine psb_c_null_dump + function psb_c_null_sizeof(prec) result(val) class(psb_c_null_prec_type), intent(in) :: prec diff --git a/prec/psb_d_base_prec_mod.f90 b/prec/psb_d_base_prec_mod.f90 index 1f30297c..bfb83d74 100644 --- a/prec/psb_d_base_prec_mod.f90 +++ b/prec/psb_d_base_prec_mod.f90 @@ -45,176 +45,146 @@ module psb_d_base_prec_mod use psb_prec_const_mod - type psb_d_base_prec_type + type, abstract :: psb_d_base_prec_type integer(psb_ipk_) :: ictxt contains - procedure, pass(prec) :: set_ctxt => psb_d_base_set_ctxt - procedure, pass(prec) :: get_ctxt => psb_d_base_get_ctxt - procedure, pass(prec) :: d_apply_v => psb_d_base_apply_vect - procedure, pass(prec) :: d_apply => psb_d_base_apply - generic, public :: apply => d_apply, d_apply_v - procedure, pass(prec) :: precbld => psb_d_base_precbld - procedure, pass(prec) :: precseti => psb_d_base_precseti - procedure, pass(prec) :: precsetr => psb_d_base_precsetr - procedure, pass(prec) :: precsetc => psb_d_base_precsetc - procedure, pass(prec) :: sizeof => psb_d_base_sizeof - generic, public :: precset => precseti, precsetr, precsetc - procedure, pass(prec) :: precinit => psb_d_base_precinit - procedure, pass(prec) :: precfree => psb_d_base_precfree - procedure, pass(prec) :: precdescr => psb_d_base_precdescr - procedure, pass(prec) :: dump => psb_d_base_precdump + procedure, pass(prec) :: set_ctxt => psb_d_base_set_ctxt + procedure, pass(prec) :: get_ctxt => psb_d_base_get_ctxt procedure, pass(prec) :: get_nzeros => psb_d_base_get_nzeros + procedure, pass(prec) :: precseti => psb_d_base_precseti + procedure, pass(prec) :: precsetr => psb_d_base_precsetr + procedure, pass(prec) :: precsetc => psb_d_base_precsetc + generic, public :: precset => precseti, precsetr, precsetc + procedure(psb_d_base_apply_vect), pass(prec), deferred :: d_apply_v + procedure(psb_d_base_apply), pass(prec), deferred :: d_apply + generic, public :: apply => d_apply, d_apply_v + procedure(psb_d_base_precbld), pass(prec), deferred :: precbld + procedure(psb_d_base_sizeof), pass(prec), deferred :: sizeof + procedure(psb_d_base_precinit), pass(prec), deferred :: precinit + procedure(psb_d_base_precfree), pass(prec), deferred :: precfree + procedure(psb_d_base_precdescr), pass(prec), deferred :: precdescr + procedure(psb_d_base_precdump), pass(prec), deferred :: dump end type psb_d_base_prec_type - - private :: psb_d_base_apply, psb_d_base_precbld, psb_d_base_precseti,& - & psb_d_base_precsetr, psb_d_base_precsetc, psb_d_base_sizeof,& - & psb_d_base_precinit, psb_d_base_precfree, psb_d_base_precdescr,& - & psb_d_base_precdump, psb_d_base_set_ctxt, psb_d_base_get_ctxt, & - & psb_d_base_apply_vect, psb_d_base_get_nzeros - -contains - - subroutine psb_d_base_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) - implicit none - type(psb_desc_type),intent(in) :: desc_data - class(psb_d_base_prec_type), intent(inout) :: prec - real(psb_dpk_),intent(in) :: alpha, beta - type(psb_d_vect_type),intent(inout) :: x - type(psb_d_vect_type),intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - character(len=1), optional :: trans - real(psb_dpk_),intent(inout), optional, target :: work(:) - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='d_base_prec_apply' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_d_base_apply_vect - - subroutine psb_d_base_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) - implicit none - type(psb_desc_type),intent(in) :: desc_data - class(psb_d_base_prec_type), intent(in) :: prec - real(psb_dpk_),intent(in) :: alpha, beta - real(psb_dpk_),intent(inout) :: x(:) - real(psb_dpk_),intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character(len=1), optional :: trans - real(psb_dpk_),intent(inout), optional, target :: work(:) - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='d_base_prec_apply' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_d_base_apply + private :: psb_d_base_set_ctxt, psb_d_base_get_ctxt, & + & psb_d_base_get_nzeros + + abstract interface + subroutine psb_d_base_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + import psb_ipk_, psb_dpk_, psb_desc_type, psb_d_vect_type, & + & psb_d_base_vect_type, psb_dspmat_type, psb_d_base_prec_type,& + & psb_d_base_sparse_mat + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_d_base_prec_type), intent(inout) :: prec + real(psb_dpk_),intent(in) :: alpha, beta + type(psb_d_vect_type),intent(inout) :: x + type(psb_d_vect_type),intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + character(len=1), optional :: trans + real(psb_dpk_),intent(inout), optional, target :: work(:) + + end subroutine psb_d_base_apply_vect + end interface + + abstract interface + subroutine psb_d_base_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + import psb_ipk_, psb_dpk_, psb_desc_type, psb_d_vect_type, & + & psb_d_base_vect_type, psb_dspmat_type, psb_d_base_prec_type,& + & psb_d_base_sparse_mat + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_d_base_prec_type), intent(in) :: prec + real(psb_dpk_),intent(in) :: alpha, beta + real(psb_dpk_),intent(inout) :: x(:) + real(psb_dpk_),intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + character(len=1), optional :: trans + real(psb_dpk_),intent(inout), optional, target :: work(:) + + end subroutine psb_d_base_apply + end interface + + + abstract interface + subroutine psb_d_base_precinit(prec,info) + import psb_ipk_, psb_dpk_, psb_desc_type, psb_d_vect_type, & + & psb_d_base_vect_type, psb_dspmat_type, psb_d_base_prec_type,& + & psb_d_base_sparse_mat + Implicit None + + class(psb_d_base_prec_type),intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info + + end subroutine psb_d_base_precinit + end interface + + + abstract interface + subroutine psb_d_base_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) + import psb_ipk_, psb_dpk_, psb_desc_type, psb_d_vect_type, & + & psb_d_base_vect_type, psb_dspmat_type, psb_d_base_prec_type,& + & psb_d_base_sparse_mat + Implicit None + + type(psb_dspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_d_base_prec_type),intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: upd + character(len=*), intent(in), optional :: afmt + class(psb_d_base_sparse_mat), intent(in), optional :: amold + class(psb_d_base_vect_type), intent(in), optional :: vmold + + end subroutine psb_d_base_precbld + end interface + + + abstract interface + subroutine psb_d_base_precfree(prec,info) + import psb_ipk_, psb_dpk_, psb_desc_type, psb_d_vect_type, & + & psb_d_base_vect_type, psb_dspmat_type, psb_d_base_prec_type,& + & psb_d_base_sparse_mat + Implicit None + + class(psb_d_base_prec_type), intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info + + end subroutine psb_d_base_precfree + end interface + + + abstract interface + subroutine psb_d_base_precdescr(prec,iout) + import psb_ipk_, psb_dpk_, psb_desc_type, psb_d_vect_type, & + & psb_d_base_vect_type, psb_dspmat_type, psb_d_base_prec_type,& + & psb_d_base_sparse_mat + Implicit None + + class(psb_d_base_prec_type), intent(in) :: prec + integer(psb_ipk_), intent(in), optional :: iout + + end subroutine psb_d_base_precdescr + end interface + + abstract interface + subroutine psb_d_base_precdump(prec,info,prefix,head) + import psb_ipk_, psb_dpk_, psb_desc_type, psb_d_vect_type, & + & psb_d_base_vect_type, psb_dspmat_type, psb_d_base_prec_type,& + & psb_d_base_sparse_mat + implicit none + class(psb_d_base_prec_type), intent(in) :: prec + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + + end subroutine psb_d_base_precdump + end interface - subroutine psb_d_base_precinit(prec,info) - Implicit None - - class(psb_d_base_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='d_base_precinit' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_d_base_precinit - - subroutine psb_d_base_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - Implicit None - - type(psb_dspmat_type), intent(in), target :: a - type(psb_desc_type), intent(in), target :: desc_a - class(psb_d_base_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: upd - character(len=*), intent(in), optional :: afmt - class(psb_d_base_sparse_mat), intent(in), optional :: amold - class(psb_d_base_vect_type), intent(in), optional :: vmold - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='d_base_precbld' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_d_base_precbld +contains subroutine psb_d_base_precseti(prec,what,val,info) Implicit None - + class(psb_d_base_prec_type),intent(inout) :: prec integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val @@ -222,31 +192,18 @@ contains integer(psb_ipk_) :: err_act, nrow character(len=20) :: name='d_base_precseti' - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? ! - info = 700 - call psb_errpush(info,name) - goto 9999 - - call psb_erractionrestore(err_act) - return + ! Base version does nothing. + + info = psb_success_ -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return + end subroutine psb_d_base_precseti subroutine psb_d_base_precsetr(prec,what,val,info) Implicit None - + class(psb_d_base_prec_type),intent(inout) :: prec integer(psb_ipk_), intent(in) :: what real(psb_dpk_), intent(in) :: val @@ -254,31 +211,20 @@ contains integer(psb_ipk_) :: err_act, nrow character(len=20) :: name='d_base_precsetr' - call psb_erractionsave(err_act) ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? + ! Base version does nothing. ! - info = 700 - 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 + info = psb_success_ + return + end subroutine psb_d_base_precsetr subroutine psb_d_base_precsetc(prec,what,val,info) Implicit None - + class(psb_d_base_prec_type),intent(inout) :: prec integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val @@ -286,123 +232,16 @@ contains integer(psb_ipk_) :: err_act, nrow character(len=20) :: name='d_base_precsetc' - call psb_erractionsave(err_act) ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? + ! Base version does nothing. ! - info = 700 - 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 psb_d_base_precsetc - - subroutine psb_d_base_precfree(prec,info) - Implicit None - - class(psb_d_base_prec_type), intent(inout) :: prec - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='d_base_precfree' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - call psb_errpush(info,name) - goto 9999 - - call psb_erractionrestore(err_act) - return + info = psb_success_ -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return - - end subroutine psb_d_base_precfree - - - subroutine psb_d_base_precdescr(prec,iout) - Implicit None - class(psb_d_base_prec_type), intent(in) :: prec - integer(psb_ipk_), intent(in), optional :: iout - - integer(psb_ipk_) :: err_act, nrow, info - character(len=20) :: name='d_base_precdescr' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_d_base_precdescr - - subroutine psb_d_base_precdump(prec,info,prefix,head) - implicit none - class(psb_d_base_prec_type), intent(in) :: prec - integer(psb_ipk_), intent(out) :: info - character(len=*), intent(in), optional :: prefix,head - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='d_base_precdump' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_d_base_precdump + end subroutine psb_d_base_precsetc subroutine psb_d_base_set_ctxt(prec,ictxt) implicit none @@ -416,7 +255,7 @@ contains function psb_d_base_sizeof(prec) result(val) class(psb_d_base_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: val - + val = 0 return end function psb_d_base_sizeof @@ -424,7 +263,7 @@ contains function psb_d_base_get_ctxt(prec) result(val) class(psb_d_base_prec_type), intent(in) :: prec integer(psb_ipk_) :: val - + val = prec%ictxt return end function psb_d_base_get_ctxt @@ -432,7 +271,7 @@ contains function psb_d_base_get_nzeros(prec) result(res) class(psb_d_base_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: res - + res = 0 end function psb_d_base_get_nzeros diff --git a/prec/psb_d_bjacprec.f90 b/prec/psb_d_bjacprec.f90 index 98ea3173..359c9459 100644 --- a/prec/psb_d_bjacprec.f90 +++ b/prec/psb_d_bjacprec.f90 @@ -34,7 +34,7 @@ module psb_d_bjacprec use psb_d_base_prec_mod type, extends(psb_d_base_prec_type) :: psb_d_bjac_prec_type - integer(psb_ipk_), allocatable :: iprcparm(:) + integer(psb_ipk_), allocatable :: iprcparm(:) type(psb_dspmat_type), allocatable :: av(:) type(psb_d_vect_type), allocatable :: dv contains diff --git a/prec/psb_d_diagprec.f90 b/prec/psb_d_diagprec.f90 index f8c19fa0..cdc3e0e4 100644 --- a/prec/psb_d_diagprec.f90 +++ b/prec/psb_d_diagprec.f90 @@ -41,17 +41,14 @@ module psb_d_diagprec procedure, pass(prec) :: d_apply => psb_d_diag_apply procedure, pass(prec) :: precbld => psb_d_diag_precbld procedure, pass(prec) :: precinit => psb_d_diag_precinit - procedure, pass(prec) :: precseti => psb_d_diag_precseti - procedure, pass(prec) :: precsetr => psb_d_diag_precsetr - procedure, pass(prec) :: precsetc => psb_d_diag_precsetc procedure, pass(prec) :: precfree => psb_d_diag_precfree procedure, pass(prec) :: precdescr => psb_d_diag_precdescr procedure, pass(prec) :: sizeof => psb_d_diag_sizeof + procedure, pass(prec) :: dump => psb_d_diag_dump procedure, pass(prec) :: get_nzeros => psb_d_diag_get_nzeros end type psb_d_diag_prec_type - private :: psb_d_diag_precseti,& - & psb_d_diag_precsetr, psb_d_diag_precsetc, psb_d_diag_sizeof,& + private :: psb_d_diag_sizeof,& & psb_d_diag_precinit, psb_d_diag_precfree, psb_d_diag_precdescr,& & psb_d_diag_get_nzeros @@ -99,6 +96,16 @@ module psb_d_diagprec class(psb_d_base_vect_type), intent(in), optional :: vmold end subroutine psb_d_diag_precbld end interface + + interface + subroutine psb_d_diag_dump(prec,info,prefix,head) + import :: psb_ipk_, psb_desc_type, psb_d_diag_prec_type, psb_d_vect_type, psb_dpk_ + implicit none + class(psb_d_diag_prec_type), intent(in) :: prec + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + end subroutine psb_d_diag_dump + end interface contains @@ -130,85 +137,6 @@ contains end subroutine psb_d_diag_precinit - subroutine psb_d_diag_precseti(prec,what,val,info) - Implicit None - - class(psb_d_diag_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='d_diag_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_d_diag_precseti - - subroutine psb_d_diag_precsetr(prec,what,val,info) - - Implicit None - - class(psb_d_diag_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='d_diag_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_d_diag_precsetr - - subroutine psb_d_diag_precsetc(prec,what,val,info) - Implicit None - - class(psb_d_diag_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='d_diag_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_d_diag_precsetc - subroutine psb_d_diag_precfree(prec,info) Implicit None diff --git a/prec/psb_d_nullprec.f90 b/prec/psb_d_nullprec.f90 index f331aadc..31bb7b68 100644 --- a/prec/psb_d_nullprec.f90 +++ b/prec/psb_d_nullprec.f90 @@ -39,16 +39,13 @@ module psb_d_nullprec procedure, pass(prec) :: d_apply => psb_d_null_apply procedure, pass(prec) :: precbld => psb_d_null_precbld procedure, pass(prec) :: precinit => psb_d_null_precinit - procedure, pass(prec) :: precseti => psb_d_null_precseti - procedure, pass(prec) :: precsetr => psb_d_null_precsetr - procedure, pass(prec) :: precsetc => psb_d_null_precsetc procedure, pass(prec) :: precfree => psb_d_null_precfree procedure, pass(prec) :: precdescr => psb_d_null_precdescr procedure, pass(prec) :: sizeof => psb_d_null_sizeof + procedure, pass(prec) :: dump => psb_d_null_dump end type psb_d_null_prec_type - private :: psb_d_null_precbld, psb_d_null_precseti,& - & psb_d_null_precsetr, psb_d_null_precsetc, psb_d_null_sizeof,& + private :: psb_d_null_precbld, psb_d_null_sizeof,& & psb_d_null_precinit, psb_d_null_precfree, psb_d_null_precdescr @@ -142,87 +139,6 @@ contains return end subroutine psb_d_null_precbld - subroutine psb_d_null_precseti(prec,what,val,info) - - Implicit None - - class(psb_d_null_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='d_null_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_d_null_precseti - - subroutine psb_d_null_precsetr(prec,what,val,info) - - Implicit None - - class(psb_d_null_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='d_null_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_d_null_precsetr - - subroutine psb_d_null_precsetc(prec,what,val,info) - - Implicit None - - class(psb_d_null_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='d_null_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_d_null_precsetc - subroutine psb_d_null_precfree(prec,info) Implicit None @@ -287,6 +203,51 @@ contains end subroutine psb_d_null_precdescr + + subroutine psb_d_null_dump(prec,info,prefix,head) + use psb_base_mod, only : psb_info + implicit none + class(psb_d_null_prec_type), intent(in) :: prec + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + integer(psb_ipk_) :: iout, iam, np, ictxt, lname + logical :: isopen + character(len=80) :: prefix_ + character(len=120) :: fname ! len should be at least 20 more than + + ! len of prefix_ + + info = 0 + ictxt = prec%get_ctxt() + call psb_info(ictxt,iam,np) + + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_null_d" + end if + + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + lname = lname + 5 + ! Search for an unused unit to write + iout = 7 + do + inquire(unit=iout, opened=isopen) + if (.not.isopen) exit + iout = iout + 1 + if (iout > 99) exit + end do + if (iout > 99) then + write(psb_err_unit,*) 'Error: could not find a free unit for I/O' + return + end if + open(iout,file=fname,iostat=info) + write(iout,*) 'Null (Identity) Preconditioner. Nothing to be printed, really!' + + end subroutine psb_d_null_dump + function psb_d_null_sizeof(prec) result(val) class(psb_d_null_prec_type), intent(in) :: prec diff --git a/prec/psb_s_base_prec_mod.f90 b/prec/psb_s_base_prec_mod.f90 index e98026a1..d478e50b 100644 --- a/prec/psb_s_base_prec_mod.f90 +++ b/prec/psb_s_base_prec_mod.f90 @@ -45,176 +45,146 @@ module psb_s_base_prec_mod use psb_prec_const_mod - type psb_s_base_prec_type + type, abstract :: psb_s_base_prec_type integer(psb_ipk_) :: ictxt contains - procedure, pass(prec) :: set_ctxt => psb_s_base_set_ctxt - procedure, pass(prec) :: get_ctxt => psb_s_base_get_ctxt - procedure, pass(prec) :: s_apply_v => psb_s_base_apply_vect - procedure, pass(prec) :: s_apply => psb_s_base_apply - generic, public :: apply => s_apply, s_apply_v - procedure, pass(prec) :: precbld => psb_s_base_precbld - procedure, pass(prec) :: precseti => psb_s_base_precseti - procedure, pass(prec) :: precsetr => psb_s_base_precsetr - procedure, pass(prec) :: precsetc => psb_s_base_precsetc - procedure, pass(prec) :: sizeof => psb_s_base_sizeof - generic, public :: precset => precseti, precsetr, precsetc - procedure, pass(prec) :: precinit => psb_s_base_precinit - procedure, pass(prec) :: precfree => psb_s_base_precfree - procedure, pass(prec) :: precdescr => psb_s_base_precdescr - procedure, pass(prec) :: dump => psb_s_base_precdump + procedure, pass(prec) :: set_ctxt => psb_s_base_set_ctxt + procedure, pass(prec) :: get_ctxt => psb_s_base_get_ctxt procedure, pass(prec) :: get_nzeros => psb_s_base_get_nzeros + procedure, pass(prec) :: precseti => psb_s_base_precseti + procedure, pass(prec) :: precsetr => psb_s_base_precsetr + procedure, pass(prec) :: precsetc => psb_s_base_precsetc + generic, public :: precset => precseti, precsetr, precsetc + procedure(psb_s_base_apply_vect), pass(prec), deferred :: s_apply_v + procedure(psb_s_base_apply), pass(prec), deferred :: s_apply + generic, public :: apply => s_apply, s_apply_v + procedure(psb_s_base_precbld), pass(prec), deferred :: precbld + procedure(psb_s_base_sizeof), pass(prec), deferred :: sizeof + procedure(psb_s_base_precinit), pass(prec), deferred :: precinit + procedure(psb_s_base_precfree), pass(prec), deferred :: precfree + procedure(psb_s_base_precdescr), pass(prec), deferred :: precdescr + procedure(psb_s_base_precdump), pass(prec), deferred :: dump end type psb_s_base_prec_type - - private :: psb_s_base_apply, psb_s_base_precbld, psb_s_base_precseti,& - & psb_s_base_precsetr, psb_s_base_precsetc, psb_s_base_sizeof,& - & psb_s_base_precinit, psb_s_base_precfree, psb_s_base_precdescr,& - & psb_s_base_precdump, psb_s_base_set_ctxt, psb_s_base_get_ctxt, & - & psb_s_base_apply_vect, psb_s_base_get_nzeros - -contains - - subroutine psb_s_base_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) - implicit none - type(psb_desc_type),intent(in) :: desc_data - class(psb_s_base_prec_type), intent(inout) :: prec - real(psb_spk_),intent(in) :: alpha, beta - type(psb_s_vect_type),intent(inout) :: x - type(psb_s_vect_type),intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - character(len=1), optional :: trans - real(psb_spk_),intent(inout), optional, target :: work(:) - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='s_base_prec_apply' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_s_base_apply_vect - - subroutine psb_s_base_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) - implicit none - type(psb_desc_type),intent(in) :: desc_data - class(psb_s_base_prec_type), intent(in) :: prec - real(psb_spk_),intent(in) :: alpha, beta - real(psb_spk_),intent(inout) :: x(:) - real(psb_spk_),intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character(len=1), optional :: trans - real(psb_spk_),intent(inout), optional, target :: work(:) - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='s_base_prec_apply' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_s_base_apply + private :: psb_s_base_set_ctxt, psb_s_base_get_ctxt, & + & psb_s_base_get_nzeros + + abstract interface + subroutine psb_s_base_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + import psb_ipk_, psb_spk_, psb_desc_type, psb_s_vect_type, & + & psb_s_base_vect_type, psb_sspmat_type, psb_s_base_prec_type,& + & psb_s_base_sparse_mat + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_s_base_prec_type), intent(inout) :: prec + real(psb_spk_),intent(in) :: alpha, beta + type(psb_s_vect_type),intent(inout) :: x + type(psb_s_vect_type),intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + + end subroutine psb_s_base_apply_vect + end interface + + abstract interface + subroutine psb_s_base_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + import psb_ipk_, psb_spk_, psb_desc_type, psb_s_vect_type, & + & psb_s_base_vect_type, psb_sspmat_type, psb_s_base_prec_type,& + & psb_s_base_sparse_mat + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_s_base_prec_type), intent(in) :: prec + real(psb_spk_),intent(in) :: alpha, beta + real(psb_spk_),intent(inout) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + + end subroutine psb_s_base_apply + end interface + + + abstract interface + subroutine psb_s_base_precinit(prec,info) + import psb_ipk_, psb_spk_, psb_desc_type, psb_s_vect_type, & + & psb_s_base_vect_type, psb_sspmat_type, psb_s_base_prec_type,& + & psb_s_base_sparse_mat + Implicit None + + class(psb_s_base_prec_type),intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info + + end subroutine psb_s_base_precinit + end interface + + + abstract interface + subroutine psb_s_base_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) + import psb_ipk_, psb_spk_, psb_desc_type, psb_s_vect_type, & + & psb_s_base_vect_type, psb_sspmat_type, psb_s_base_prec_type,& + & psb_s_base_sparse_mat + Implicit None + + type(psb_sspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_s_base_prec_type),intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: upd + character(len=*), intent(in), optional :: afmt + class(psb_s_base_sparse_mat), intent(in), optional :: amold + class(psb_s_base_vect_type), intent(in), optional :: vmold + + end subroutine psb_s_base_precbld + end interface + + + abstract interface + subroutine psb_s_base_precfree(prec,info) + import psb_ipk_, psb_spk_, psb_desc_type, psb_s_vect_type, & + & psb_s_base_vect_type, psb_sspmat_type, psb_s_base_prec_type,& + & psb_s_base_sparse_mat + Implicit None + + class(psb_s_base_prec_type), intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info + + end subroutine psb_s_base_precfree + end interface + + + abstract interface + subroutine psb_s_base_precdescr(prec,iout) + import psb_ipk_, psb_spk_, psb_desc_type, psb_s_vect_type, & + & psb_s_base_vect_type, psb_sspmat_type, psb_s_base_prec_type,& + & psb_s_base_sparse_mat + Implicit None + + class(psb_s_base_prec_type), intent(in) :: prec + integer(psb_ipk_), intent(in), optional :: iout + + end subroutine psb_s_base_precdescr + end interface + + abstract interface + subroutine psb_s_base_precdump(prec,info,prefix,head) + import psb_ipk_, psb_spk_, psb_desc_type, psb_s_vect_type, & + & psb_s_base_vect_type, psb_sspmat_type, psb_s_base_prec_type,& + & psb_s_base_sparse_mat + implicit none + class(psb_s_base_prec_type), intent(in) :: prec + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + + end subroutine psb_s_base_precdump + end interface - subroutine psb_s_base_precinit(prec,info) - Implicit None - - class(psb_s_base_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='s_base_precinit' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_s_base_precinit - - subroutine psb_s_base_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - Implicit None - - type(psb_sspmat_type), intent(in), target :: a - type(psb_desc_type), intent(in), target :: desc_a - class(psb_s_base_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: upd - character(len=*), intent(in), optional :: afmt - class(psb_s_base_sparse_mat), intent(in), optional :: amold - class(psb_s_base_vect_type), intent(in), optional :: vmold - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='s_base_precbld' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_s_base_precbld +contains subroutine psb_s_base_precseti(prec,what,val,info) Implicit None - + class(psb_s_base_prec_type),intent(inout) :: prec integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val @@ -222,31 +192,18 @@ contains integer(psb_ipk_) :: err_act, nrow character(len=20) :: name='s_base_precseti' - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? ! - info = 700 - call psb_errpush(info,name) - goto 9999 - - call psb_erractionrestore(err_act) - return + ! Base version does nothing. + + info = psb_success_ -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return + end subroutine psb_s_base_precseti subroutine psb_s_base_precsetr(prec,what,val,info) Implicit None - + class(psb_s_base_prec_type),intent(inout) :: prec integer(psb_ipk_), intent(in) :: what real(psb_spk_), intent(in) :: val @@ -254,31 +211,20 @@ contains integer(psb_ipk_) :: err_act, nrow character(len=20) :: name='s_base_precsetr' - call psb_erractionsave(err_act) ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? + ! Base version does nothing. ! - info = 700 - 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 + info = psb_success_ + return + end subroutine psb_s_base_precsetr subroutine psb_s_base_precsetc(prec,what,val,info) Implicit None - + class(psb_s_base_prec_type),intent(inout) :: prec integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val @@ -286,123 +232,16 @@ contains integer(psb_ipk_) :: err_act, nrow character(len=20) :: name='s_base_precsetc' - call psb_erractionsave(err_act) ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? + ! Base version does nothing. ! - info = 700 - 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 psb_s_base_precsetc - - subroutine psb_s_base_precfree(prec,info) - Implicit None - - class(psb_s_base_prec_type), intent(inout) :: prec - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='s_base_precfree' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - call psb_errpush(info,name) - goto 9999 - - call psb_erractionrestore(err_act) - return + info = psb_success_ -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return - - end subroutine psb_s_base_precfree - - - subroutine psb_s_base_precdescr(prec,iout) - Implicit None - class(psb_s_base_prec_type), intent(in) :: prec - integer(psb_ipk_), intent(in), optional :: iout - - integer(psb_ipk_) :: err_act, nrow, info - character(len=20) :: name='s_base_precdescr' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_s_base_precdescr - - subroutine psb_s_base_precdump(prec,info,prefix,head) - implicit none - class(psb_s_base_prec_type), intent(in) :: prec - integer(psb_ipk_), intent(out) :: info - character(len=*), intent(in), optional :: prefix,head - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='s_base_precdump' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_s_base_precdump + end subroutine psb_s_base_precsetc subroutine psb_s_base_set_ctxt(prec,ictxt) implicit none @@ -416,7 +255,7 @@ contains function psb_s_base_sizeof(prec) result(val) class(psb_s_base_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: val - + val = 0 return end function psb_s_base_sizeof @@ -424,7 +263,7 @@ contains function psb_s_base_get_ctxt(prec) result(val) class(psb_s_base_prec_type), intent(in) :: prec integer(psb_ipk_) :: val - + val = prec%ictxt return end function psb_s_base_get_ctxt @@ -432,7 +271,7 @@ contains function psb_s_base_get_nzeros(prec) result(res) class(psb_s_base_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: res - + res = 0 end function psb_s_base_get_nzeros diff --git a/prec/psb_s_bjacprec.f90 b/prec/psb_s_bjacprec.f90 index 2aeb14df..358ab247 100644 --- a/prec/psb_s_bjacprec.f90 +++ b/prec/psb_s_bjacprec.f90 @@ -34,7 +34,7 @@ module psb_s_bjacprec use psb_s_base_prec_mod type, extends(psb_s_base_prec_type) :: psb_s_bjac_prec_type - integer(psb_ipk_), allocatable :: iprcparm(:) + integer(psb_ipk_), allocatable :: iprcparm(:) type(psb_sspmat_type), allocatable :: av(:) type(psb_s_vect_type), allocatable :: dv contains diff --git a/prec/psb_s_diagprec.f90 b/prec/psb_s_diagprec.f90 index 6271454a..36c62190 100644 --- a/prec/psb_s_diagprec.f90 +++ b/prec/psb_s_diagprec.f90 @@ -41,17 +41,14 @@ module psb_s_diagprec procedure, pass(prec) :: s_apply => psb_s_diag_apply procedure, pass(prec) :: precbld => psb_s_diag_precbld procedure, pass(prec) :: precinit => psb_s_diag_precinit - procedure, pass(prec) :: precseti => psb_s_diag_precseti - procedure, pass(prec) :: precsetr => psb_s_diag_precsetr - procedure, pass(prec) :: precsetc => psb_s_diag_precsetc procedure, pass(prec) :: precfree => psb_s_diag_precfree procedure, pass(prec) :: precdescr => psb_s_diag_precdescr procedure, pass(prec) :: sizeof => psb_s_diag_sizeof + procedure, pass(prec) :: dump => psb_s_diag_dump procedure, pass(prec) :: get_nzeros => psb_s_diag_get_nzeros end type psb_s_diag_prec_type - private :: psb_s_diag_precseti,& - & psb_s_diag_precsetr, psb_s_diag_precsetc, psb_s_diag_sizeof,& + private :: psb_s_diag_sizeof,& & psb_s_diag_precinit, psb_s_diag_precfree, psb_s_diag_precdescr,& & psb_s_diag_get_nzeros @@ -99,6 +96,16 @@ module psb_s_diagprec class(psb_s_base_vect_type), intent(in), optional :: vmold end subroutine psb_s_diag_precbld end interface + + interface + subroutine psb_s_diag_dump(prec,info,prefix,head) + import :: psb_ipk_, psb_desc_type, psb_s_diag_prec_type, psb_s_vect_type, psb_spk_ + implicit none + class(psb_s_diag_prec_type), intent(in) :: prec + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + end subroutine psb_s_diag_dump + end interface contains @@ -130,85 +137,6 @@ contains end subroutine psb_s_diag_precinit - subroutine psb_s_diag_precseti(prec,what,val,info) - Implicit None - - class(psb_s_diag_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='s_diag_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_s_diag_precseti - - subroutine psb_s_diag_precsetr(prec,what,val,info) - - Implicit None - - class(psb_s_diag_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - real(psb_spk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='s_diag_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_s_diag_precsetr - - subroutine psb_s_diag_precsetc(prec,what,val,info) - Implicit None - - class(psb_s_diag_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='s_diag_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_s_diag_precsetc - subroutine psb_s_diag_precfree(prec,info) Implicit None diff --git a/prec/psb_s_nullprec.f90 b/prec/psb_s_nullprec.f90 index e156ce2e..60519337 100644 --- a/prec/psb_s_nullprec.f90 +++ b/prec/psb_s_nullprec.f90 @@ -39,16 +39,13 @@ module psb_s_nullprec procedure, pass(prec) :: s_apply => psb_s_null_apply procedure, pass(prec) :: precbld => psb_s_null_precbld procedure, pass(prec) :: precinit => psb_s_null_precinit - procedure, pass(prec) :: precseti => psb_s_null_precseti - procedure, pass(prec) :: precsetr => psb_s_null_precsetr - procedure, pass(prec) :: precsetc => psb_s_null_precsetc procedure, pass(prec) :: precfree => psb_s_null_precfree procedure, pass(prec) :: precdescr => psb_s_null_precdescr procedure, pass(prec) :: sizeof => psb_s_null_sizeof + procedure, pass(prec) :: dump => psb_s_null_dump end type psb_s_null_prec_type - private :: psb_s_null_precbld, psb_s_null_precseti,& - & psb_s_null_precsetr, psb_s_null_precsetc, psb_s_null_sizeof,& + private :: psb_s_null_precbld, psb_s_null_sizeof,& & psb_s_null_precinit, psb_s_null_precfree, psb_s_null_precdescr @@ -142,87 +139,6 @@ contains return end subroutine psb_s_null_precbld - subroutine psb_s_null_precseti(prec,what,val,info) - - Implicit None - - class(psb_s_null_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='s_null_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_s_null_precseti - - subroutine psb_s_null_precsetr(prec,what,val,info) - - Implicit None - - class(psb_s_null_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - real(psb_spk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='s_null_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_s_null_precsetr - - subroutine psb_s_null_precsetc(prec,what,val,info) - - Implicit None - - class(psb_s_null_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='s_null_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_s_null_precsetc - subroutine psb_s_null_precfree(prec,info) Implicit None @@ -287,6 +203,51 @@ contains end subroutine psb_s_null_precdescr + + subroutine psb_s_null_dump(prec,info,prefix,head) + use psb_base_mod, only : psb_info + implicit none + class(psb_s_null_prec_type), intent(in) :: prec + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + integer(psb_ipk_) :: iout, iam, np, ictxt, lname + logical :: isopen + character(len=80) :: prefix_ + character(len=120) :: fname ! len should be at least 20 more than + + ! len of prefix_ + + info = 0 + ictxt = prec%get_ctxt() + call psb_info(ictxt,iam,np) + + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_null_s" + end if + + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + lname = lname + 5 + ! Search for an unused unit to write + iout = 7 + do + inquire(unit=iout, opened=isopen) + if (.not.isopen) exit + iout = iout + 1 + if (iout > 99) exit + end do + if (iout > 99) then + write(psb_err_unit,*) 'Error: could not find a free unit for I/O' + return + end if + open(iout,file=fname,iostat=info) + write(iout,*) 'Null (Identity) Preconditioner. Nothing to be printed, really!' + + end subroutine psb_s_null_dump + function psb_s_null_sizeof(prec) result(val) class(psb_s_null_prec_type), intent(in) :: prec diff --git a/prec/psb_z_base_prec_mod.f90 b/prec/psb_z_base_prec_mod.f90 index 1f8a4718..88f585d6 100644 --- a/prec/psb_z_base_prec_mod.f90 +++ b/prec/psb_z_base_prec_mod.f90 @@ -45,176 +45,146 @@ module psb_z_base_prec_mod use psb_prec_const_mod - type psb_z_base_prec_type + type, abstract :: psb_z_base_prec_type integer(psb_ipk_) :: ictxt contains - procedure, pass(prec) :: set_ctxt => psb_z_base_set_ctxt - procedure, pass(prec) :: get_ctxt => psb_z_base_get_ctxt - procedure, pass(prec) :: z_apply_v => psb_z_base_apply_vect - procedure, pass(prec) :: z_apply => psb_z_base_apply - generic, public :: apply => z_apply, z_apply_v - procedure, pass(prec) :: precbld => psb_z_base_precbld - procedure, pass(prec) :: precseti => psb_z_base_precseti - procedure, pass(prec) :: precsetr => psb_z_base_precsetr - procedure, pass(prec) :: precsetc => psb_z_base_precsetc - procedure, pass(prec) :: sizeof => psb_z_base_sizeof - generic, public :: precset => precseti, precsetr, precsetc - procedure, pass(prec) :: precinit => psb_z_base_precinit - procedure, pass(prec) :: precfree => psb_z_base_precfree - procedure, pass(prec) :: precdescr => psb_z_base_precdescr - procedure, pass(prec) :: dump => psb_z_base_precdump + procedure, pass(prec) :: set_ctxt => psb_z_base_set_ctxt + procedure, pass(prec) :: get_ctxt => psb_z_base_get_ctxt procedure, pass(prec) :: get_nzeros => psb_z_base_get_nzeros + procedure, pass(prec) :: precseti => psb_z_base_precseti + procedure, pass(prec) :: precsetr => psb_z_base_precsetr + procedure, pass(prec) :: precsetc => psb_z_base_precsetc + generic, public :: precset => precseti, precsetr, precsetc + procedure(psb_z_base_apply_vect), pass(prec), deferred :: z_apply_v + procedure(psb_z_base_apply), pass(prec), deferred :: z_apply + generic, public :: apply => z_apply, z_apply_v + procedure(psb_z_base_precbld), pass(prec), deferred :: precbld + procedure(psb_z_base_sizeof), pass(prec), deferred :: sizeof + procedure(psb_z_base_precinit), pass(prec), deferred :: precinit + procedure(psb_z_base_precfree), pass(prec), deferred :: precfree + procedure(psb_z_base_precdescr), pass(prec), deferred :: precdescr + procedure(psb_z_base_precdump), pass(prec), deferred :: dump end type psb_z_base_prec_type - - private :: psb_z_base_apply, psb_z_base_precbld, psb_z_base_precseti,& - & psb_z_base_precsetr, psb_z_base_precsetc, psb_z_base_sizeof,& - & psb_z_base_precinit, psb_z_base_precfree, psb_z_base_precdescr,& - & psb_z_base_precdump, psb_z_base_set_ctxt, psb_z_base_get_ctxt, & - & psb_z_base_apply_vect, psb_z_base_get_nzeros - -contains - - subroutine psb_z_base_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) - implicit none - type(psb_desc_type),intent(in) :: desc_data - class(psb_z_base_prec_type), intent(inout) :: prec - complex(psb_dpk_),intent(in) :: alpha, beta - type(psb_z_vect_type),intent(inout) :: x - type(psb_z_vect_type),intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - character(len=1), optional :: trans - complex(psb_dpk_),intent(inout), optional, target :: work(:) - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='z_base_prec_apply' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_z_base_apply_vect - - subroutine psb_z_base_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) - implicit none - type(psb_desc_type),intent(in) :: desc_data - class(psb_z_base_prec_type), intent(in) :: prec - complex(psb_dpk_),intent(in) :: alpha, beta - complex(psb_dpk_),intent(inout) :: x(:) - complex(psb_dpk_),intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character(len=1), optional :: trans - complex(psb_dpk_),intent(inout), optional, target :: work(:) - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='z_base_prec_apply' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_z_base_apply + private :: psb_z_base_set_ctxt, psb_z_base_get_ctxt, & + & psb_z_base_get_nzeros + + abstract interface + subroutine psb_z_base_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + import psb_ipk_, psb_dpk_, psb_desc_type, psb_z_vect_type, & + & psb_z_base_vect_type, psb_zspmat_type, psb_z_base_prec_type,& + & psb_z_base_sparse_mat + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_z_base_prec_type), intent(inout) :: prec + complex(psb_dpk_),intent(in) :: alpha, beta + type(psb_z_vect_type),intent(inout) :: x + type(psb_z_vect_type),intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + character(len=1), optional :: trans + complex(psb_dpk_),intent(inout), optional, target :: work(:) + + end subroutine psb_z_base_apply_vect + end interface + + abstract interface + subroutine psb_z_base_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + import psb_ipk_, psb_dpk_, psb_desc_type, psb_z_vect_type, & + & psb_z_base_vect_type, psb_zspmat_type, psb_z_base_prec_type,& + & psb_z_base_sparse_mat + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_z_base_prec_type), intent(in) :: prec + complex(psb_dpk_),intent(in) :: alpha, beta + complex(psb_dpk_),intent(inout) :: x(:) + complex(psb_dpk_),intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + character(len=1), optional :: trans + complex(psb_dpk_),intent(inout), optional, target :: work(:) + + end subroutine psb_z_base_apply + end interface + + + abstract interface + subroutine psb_z_base_precinit(prec,info) + import psb_ipk_, psb_dpk_, psb_desc_type, psb_z_vect_type, & + & psb_z_base_vect_type, psb_zspmat_type, psb_z_base_prec_type,& + & psb_z_base_sparse_mat + Implicit None + + class(psb_z_base_prec_type),intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info + + end subroutine psb_z_base_precinit + end interface + + + abstract interface + subroutine psb_z_base_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) + import psb_ipk_, psb_dpk_, psb_desc_type, psb_z_vect_type, & + & psb_z_base_vect_type, psb_zspmat_type, psb_z_base_prec_type,& + & psb_z_base_sparse_mat + Implicit None + + type(psb_zspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_z_base_prec_type),intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: upd + character(len=*), intent(in), optional :: afmt + class(psb_z_base_sparse_mat), intent(in), optional :: amold + class(psb_z_base_vect_type), intent(in), optional :: vmold + + end subroutine psb_z_base_precbld + end interface + + + abstract interface + subroutine psb_z_base_precfree(prec,info) + import psb_ipk_, psb_dpk_, psb_desc_type, psb_z_vect_type, & + & psb_z_base_vect_type, psb_zspmat_type, psb_z_base_prec_type,& + & psb_z_base_sparse_mat + Implicit None + + class(psb_z_base_prec_type), intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info + + end subroutine psb_z_base_precfree + end interface + + + abstract interface + subroutine psb_z_base_precdescr(prec,iout) + import psb_ipk_, psb_dpk_, psb_desc_type, psb_z_vect_type, & + & psb_z_base_vect_type, psb_zspmat_type, psb_z_base_prec_type,& + & psb_z_base_sparse_mat + Implicit None + + class(psb_z_base_prec_type), intent(in) :: prec + integer(psb_ipk_), intent(in), optional :: iout + + end subroutine psb_z_base_precdescr + end interface + + abstract interface + subroutine psb_z_base_precdump(prec,info,prefix,head) + import psb_ipk_, psb_dpk_, psb_desc_type, psb_z_vect_type, & + & psb_z_base_vect_type, psb_zspmat_type, psb_z_base_prec_type,& + & psb_z_base_sparse_mat + implicit none + class(psb_z_base_prec_type), intent(in) :: prec + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + + end subroutine psb_z_base_precdump + end interface - subroutine psb_z_base_precinit(prec,info) - Implicit None - - class(psb_z_base_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='z_base_precinit' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_z_base_precinit - - subroutine psb_z_base_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - Implicit None - - type(psb_zspmat_type), intent(in), target :: a - type(psb_desc_type), intent(in), target :: desc_a - class(psb_z_base_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: upd - character(len=*), intent(in), optional :: afmt - class(psb_z_base_sparse_mat), intent(in), optional :: amold - class(psb_z_base_vect_type), intent(in), optional :: vmold - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='z_base_precbld' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_z_base_precbld +contains subroutine psb_z_base_precseti(prec,what,val,info) Implicit None - + class(psb_z_base_prec_type),intent(inout) :: prec integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val @@ -222,31 +192,18 @@ contains integer(psb_ipk_) :: err_act, nrow character(len=20) :: name='z_base_precseti' - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? ! - info = 700 - call psb_errpush(info,name) - goto 9999 - - call psb_erractionrestore(err_act) - return + ! Base version does nothing. + + info = psb_success_ -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return + end subroutine psb_z_base_precseti subroutine psb_z_base_precsetr(prec,what,val,info) Implicit None - + class(psb_z_base_prec_type),intent(inout) :: prec integer(psb_ipk_), intent(in) :: what real(psb_dpk_), intent(in) :: val @@ -254,31 +211,20 @@ contains integer(psb_ipk_) :: err_act, nrow character(len=20) :: name='z_base_precsetr' - call psb_erractionsave(err_act) ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? + ! Base version does nothing. ! - info = 700 - 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 + info = psb_success_ + return + end subroutine psb_z_base_precsetr subroutine psb_z_base_precsetc(prec,what,val,info) Implicit None - + class(psb_z_base_prec_type),intent(inout) :: prec integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val @@ -286,123 +232,16 @@ contains integer(psb_ipk_) :: err_act, nrow character(len=20) :: name='z_base_precsetc' - call psb_erractionsave(err_act) ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? + ! Base version does nothing. ! - info = 700 - 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 psb_z_base_precsetc - - subroutine psb_z_base_precfree(prec,info) - Implicit None - - class(psb_z_base_prec_type), intent(inout) :: prec - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='z_base_precfree' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - call psb_errpush(info,name) - goto 9999 - - call psb_erractionrestore(err_act) - return + info = psb_success_ -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return - - end subroutine psb_z_base_precfree - - - subroutine psb_z_base_precdescr(prec,iout) - Implicit None - class(psb_z_base_prec_type), intent(in) :: prec - integer(psb_ipk_), intent(in), optional :: iout - - integer(psb_ipk_) :: err_act, nrow, info - character(len=20) :: name='z_base_precdescr' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_z_base_precdescr - - subroutine psb_z_base_precdump(prec,info,prefix,head) - implicit none - class(psb_z_base_prec_type), intent(in) :: prec - integer(psb_ipk_), intent(out) :: info - character(len=*), intent(in), optional :: prefix,head - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='z_base_precdump' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preconditioner??? - ! - info = 700 - 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 psb_z_base_precdump + end subroutine psb_z_base_precsetc subroutine psb_z_base_set_ctxt(prec,ictxt) implicit none @@ -416,7 +255,7 @@ contains function psb_z_base_sizeof(prec) result(val) class(psb_z_base_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: val - + val = 0 return end function psb_z_base_sizeof @@ -424,7 +263,7 @@ contains function psb_z_base_get_ctxt(prec) result(val) class(psb_z_base_prec_type), intent(in) :: prec integer(psb_ipk_) :: val - + val = prec%ictxt return end function psb_z_base_get_ctxt @@ -432,7 +271,7 @@ contains function psb_z_base_get_nzeros(prec) result(res) class(psb_z_base_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: res - + res = 0 end function psb_z_base_get_nzeros diff --git a/prec/psb_z_bjacprec.f90 b/prec/psb_z_bjacprec.f90 index 0d7c7137..3541e48c 100644 --- a/prec/psb_z_bjacprec.f90 +++ b/prec/psb_z_bjacprec.f90 @@ -34,7 +34,7 @@ module psb_z_bjacprec use psb_z_base_prec_mod type, extends(psb_z_base_prec_type) :: psb_z_bjac_prec_type - integer(psb_ipk_), allocatable :: iprcparm(:) + integer(psb_ipk_), allocatable :: iprcparm(:) type(psb_zspmat_type), allocatable :: av(:) type(psb_z_vect_type), allocatable :: dv contains diff --git a/prec/psb_z_diagprec.f90 b/prec/psb_z_diagprec.f90 index 607436ec..a2938ff3 100644 --- a/prec/psb_z_diagprec.f90 +++ b/prec/psb_z_diagprec.f90 @@ -41,17 +41,14 @@ module psb_z_diagprec procedure, pass(prec) :: z_apply => psb_z_diag_apply procedure, pass(prec) :: precbld => psb_z_diag_precbld procedure, pass(prec) :: precinit => psb_z_diag_precinit - procedure, pass(prec) :: precseti => psb_z_diag_precseti - procedure, pass(prec) :: precsetr => psb_z_diag_precsetr - procedure, pass(prec) :: precsetc => psb_z_diag_precsetc procedure, pass(prec) :: precfree => psb_z_diag_precfree procedure, pass(prec) :: precdescr => psb_z_diag_precdescr procedure, pass(prec) :: sizeof => psb_z_diag_sizeof + procedure, pass(prec) :: dump => psb_z_diag_dump procedure, pass(prec) :: get_nzeros => psb_z_diag_get_nzeros end type psb_z_diag_prec_type - private :: psb_z_diag_precseti,& - & psb_z_diag_precsetr, psb_z_diag_precsetc, psb_z_diag_sizeof,& + private :: psb_z_diag_sizeof,& & psb_z_diag_precinit, psb_z_diag_precfree, psb_z_diag_precdescr,& & psb_z_diag_get_nzeros @@ -99,6 +96,16 @@ module psb_z_diagprec class(psb_z_base_vect_type), intent(in), optional :: vmold end subroutine psb_z_diag_precbld end interface + + interface + subroutine psb_z_diag_dump(prec,info,prefix,head) + import :: psb_ipk_, psb_desc_type, psb_z_diag_prec_type, psb_z_vect_type, psb_dpk_ + implicit none + class(psb_z_diag_prec_type), intent(in) :: prec + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + end subroutine psb_z_diag_dump + end interface contains @@ -130,85 +137,6 @@ contains end subroutine psb_z_diag_precinit - subroutine psb_z_diag_precseti(prec,what,val,info) - Implicit None - - class(psb_z_diag_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='z_diag_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_z_diag_precseti - - subroutine psb_z_diag_precsetr(prec,what,val,info) - - Implicit None - - class(psb_z_diag_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='z_diag_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_z_diag_precsetr - - subroutine psb_z_diag_precsetc(prec,what,val,info) - Implicit None - - class(psb_z_diag_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='z_diag_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_z_diag_precsetc - subroutine psb_z_diag_precfree(prec,info) Implicit None diff --git a/prec/psb_z_nullprec.f90 b/prec/psb_z_nullprec.f90 index 0150285a..e7137057 100644 --- a/prec/psb_z_nullprec.f90 +++ b/prec/psb_z_nullprec.f90 @@ -39,16 +39,13 @@ module psb_z_nullprec procedure, pass(prec) :: z_apply => psb_z_null_apply procedure, pass(prec) :: precbld => psb_z_null_precbld procedure, pass(prec) :: precinit => psb_z_null_precinit - procedure, pass(prec) :: precseti => psb_z_null_precseti - procedure, pass(prec) :: precsetr => psb_z_null_precsetr - procedure, pass(prec) :: precsetc => psb_z_null_precsetc procedure, pass(prec) :: precfree => psb_z_null_precfree procedure, pass(prec) :: precdescr => psb_z_null_precdescr procedure, pass(prec) :: sizeof => psb_z_null_sizeof + procedure, pass(prec) :: dump => psb_z_null_dump end type psb_z_null_prec_type - private :: psb_z_null_precbld, psb_z_null_precseti,& - & psb_z_null_precsetr, psb_z_null_precsetc, psb_z_null_sizeof,& + private :: psb_z_null_precbld, psb_z_null_sizeof,& & psb_z_null_precinit, psb_z_null_precfree, psb_z_null_precdescr @@ -142,87 +139,6 @@ contains return end subroutine psb_z_null_precbld - subroutine psb_z_null_precseti(prec,what,val,info) - - Implicit None - - class(psb_z_null_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='z_null_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_z_null_precseti - - subroutine psb_z_null_precsetr(prec,what,val,info) - - Implicit None - - class(psb_z_null_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='z_null_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_z_null_precsetr - - subroutine psb_z_null_precsetc(prec,what,val,info) - - Implicit None - - class(psb_z_null_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='z_null_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_z_null_precsetc - subroutine psb_z_null_precfree(prec,info) Implicit None @@ -287,6 +203,51 @@ contains end subroutine psb_z_null_precdescr + + subroutine psb_z_null_dump(prec,info,prefix,head) + use psb_base_mod, only : psb_info + implicit none + class(psb_z_null_prec_type), intent(in) :: prec + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + integer(psb_ipk_) :: iout, iam, np, ictxt, lname + logical :: isopen + character(len=80) :: prefix_ + character(len=120) :: fname ! len should be at least 20 more than + + ! len of prefix_ + + info = 0 + ictxt = prec%get_ctxt() + call psb_info(ictxt,iam,np) + + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_null_z" + end if + + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + lname = lname + 5 + ! Search for an unused unit to write + iout = 7 + do + inquire(unit=iout, opened=isopen) + if (.not.isopen) exit + iout = iout + 1 + if (iout > 99) exit + end do + if (iout > 99) then + write(psb_err_unit,*) 'Error: could not find a free unit for I/O' + return + end if + open(iout,file=fname,iostat=info) + write(iout,*) 'Null (Identity) Preconditioner. Nothing to be printed, really!' + + end subroutine psb_z_null_dump + function psb_z_null_sizeof(prec) result(val) class(psb_z_null_prec_type), intent(in) :: prec