diff --git a/prec/Makefile b/prec/Makefile index fa49936f..2f99933f 100644 --- a/prec/Makefile +++ b/prec/Makefile @@ -12,14 +12,6 @@ MODOBJS=psb_prec_const_mod.o\ psb_c_diagprec.o psb_c_nullprec.o psb_c_bjacprec.o \ psb_z_diagprec.o psb_z_nullprec.o psb_z_bjacprec.o -F90OBJS= psb_dilu_fct.o\ - psb_dprecbld.o psb_dprecset.o psb_dprecinit.o \ - psb_silu_fct.o\ - psb_sprecbld.o psb_sprecset.o psb_sprecinit.o \ - psb_cilu_fct.o\ - psb_cprecbld.o psb_cprecset.o psb_cprecinit.o \ - psb_zilu_fct.o\ - psb_zprecbld.o psb_zprecset.o psb_zprecinit.o LIBMOD=psb_prec_mod$(.mod) LOCAL_MODS=$(MODOBJS:.o=$(.mod)) @@ -39,7 +31,6 @@ impld: $(OBJS) $(OBJS): $(LIBDIR)/psb_base_mod$(.mod) -$(F90OBJS): $(MODOBJS) psb_s_base_prec_mod.o psb_d_base_prec_mod.o psb_c_base_prec_mod.o psb_z_base_prec_mod.o: psb_prec_const_mod.o psb_s_prec_type.o: psb_s_base_prec_mod.o @@ -60,6 +51,8 @@ psb_z_bjacprec.o psb_z_diagprec.o psb_z_nullprec.o: psb_prec_mod.o psb_z_base_pr veryclean: clean /bin/rm -f $(LIBNAME) -clean: +iclean: + cd impl && $(MAKE) clean +clean: iclean /bin/rm -f $(OBJS) $(LOCAL_MODS) diff --git a/prec/impl/Makefile b/prec/impl/Makefile index 48947be3..4e566fa6 100644 --- a/prec/impl/Makefile +++ b/prec/impl/Makefile @@ -3,17 +3,19 @@ include ../../Make.inc LIBDIR=../../lib HERE=.. OBJS=psb_s_prec_type_impl.o psb_d_prec_type_impl.o \ - psb_c_prec_type_impl.o psb_z_prec_type_impl.o - - -F90OBJS= psb_dilu_fct.o\ - psb_dprecbld.o psb_dprecset.o psb_dprecinit.o \ - psb_silu_fct.o\ - psb_sprecbld.o psb_sprecset.o psb_sprecinit.o \ - psb_cilu_fct.o\ - psb_cprecbld.o psb_cprecset.o psb_cprecinit.o \ - psb_zilu_fct.o\ - psb_zprecbld.o psb_zprecset.o psb_zprecinit.o + psb_c_prec_type_impl.o psb_z_prec_type_impl.o \ + psb_d_diagprec_impl.o psb_d_bjacprec_impl.o psb_d_nullprec_impl.o \ + psb_dilu_fct.o\ + psb_dprecbld.o psb_dprecset.o psb_dprecinit.o \ + psb_s_diagprec_impl.o psb_s_bjacprec_impl.o psb_s_nullprec_impl.o \ + psb_silu_fct.o\ + psb_sprecbld.o psb_sprecset.o psb_sprecinit.o \ + psb_c_diagprec_impl.o psb_c_bjacprec_impl.o psb_c_nullprec_impl.o \ + psb_cilu_fct.o\ + psb_cprecbld.o psb_cprecset.o psb_cprecinit.o \ + psb_z_diagprec_impl.o psb_z_bjacprec_impl.o psb_z_nullprec_impl.o \ + psb_zilu_fct.o\ + psb_zprecbld.o psb_zprecset.o psb_zprecinit.o LIBNAME=$(PRECLIBNAME) COBJS= diff --git a/prec/impl/psb_c_bjacprec_impl.f90 b/prec/impl/psb_c_bjacprec_impl.f90 new file mode 100644 index 00000000..fb958d9e --- /dev/null +++ b/prec/impl/psb_c_bjacprec_impl.f90 @@ -0,0 +1,605 @@ + +subroutine psb_c_bjac_dump(prec,info,prefix,head) + use psb_base_mod + use psb_c_bjacprec, psb_protect_name => psb_c_bjac_dump + implicit none + class(psb_c_bjac_prec_type), intent(in) :: prec + integer, intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + integer :: i, j, il1, iln, lname, lev + integer :: 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_fact_c" + end if + + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + lname = lname + 5 + write(fname(lname+1:),'(a)')'_lower.mtx' + if (prec%av(psb_l_pr_)%is_asb()) & + & call prec%av(psb_l_pr_)%print(fname,head=head) + write(fname(lname+1:),'(a,a)')'_diag.mtx' + if (allocated(prec%d)) & + & call psb_geprt(fname,prec%d,head=head) + write(fname(lname+1:),'(a)')'_upper.mtx' + if (prec%av(psb_u_pr_)%is_asb()) & + & call prec%av(psb_u_pr_)%print(fname,head=head) + +end subroutine psb_c_bjac_dump + +subroutine psb_c_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + use psb_base_mod + use psb_c_bjacprec, psb_protect_name => psb_c_bjac_apply_vect + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_c_bjac_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, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + + ! Local variables + integer :: n_row,n_col + complex(psb_spk_), pointer :: ww(:), aux(:) + type(psb_c_vect_type) :: wv, wv1 + integer :: ictxt,np,me, err_act, int_err(5) + integer :: debug_level, debug_unit + character :: trans_ + character(len=20) :: name='c_bjac_prec_apply' + character(len=20) :: ch_err + + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + + trans_ = psb_toupper(trans) + select case(trans_) + case('N','T','C') + ! Ok + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + if (x%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,i_err=(/2,n_row,0,0,0/)) + goto 9999 + end if + if (y%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n_row,0,0,0/)) + goto 9999 + end if + if (.not.allocated(prec%dv)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + if (prec%dv%get_nrows() < n_row) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + endif + if (info == psb_success_) allocate(wv%v,mold=x%v) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(wv1,desc_data,info,mold=x%v,scratch=.true.) + + select case(prec%iprcparm(psb_f_type_)) + case(psb_f_ilu_n_) + + select case(trans_) + case('N') + call psb_spsm(cone,prec%av(psb_l_pr_),x,czero,wv,desc_data,info,& + & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_,work=aux) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),wv,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) + + case('T') + call psb_spsm(cone,prec%av(psb_u_pr_),x,czero,wv,desc_data,info,& + & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_, work=aux) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case('C') + + call psb_spsm(cone,prec%av(psb_u_pr_),x,czero,wv,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) + + call wv1%mlt(cone,prec%dv,wv,czero,info,conjgx=trans_) + + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) + + end select + if (info /= psb_success_) then + ch_err="psb_spsm" + goto 9999 + end if + + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid factorization') + goto 9999 + end select + + call psb_halo(y,desc_data,info,data=psb_comm_mov_) + + call wv%free(info) + call wv1%free(info) + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_c_bjac_apply_vect + +subroutine psb_c_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + use psb_base_mod + use psb_c_bjacprec, psb_protect_name => psb_c_bjac_apply + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_c_bjac_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, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + + ! Local variables + integer :: n_row,n_col + complex(psb_spk_), pointer :: ww(:), aux(:) + integer :: ictxt,np,me, err_act, int_err(5) + integer :: debug_level, debug_unit + character :: trans_ + character(len=20) :: name='c_bjac_prec_apply' + character(len=20) :: ch_err + + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + + trans_ = psb_toupper(trans) + select case(trans_) + case('N','T','C') + ! Ok + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + if (size(x) < n_row) then + info = 36 + call psb_errpush(info,name,i_err=(/2,n_row,0,0,0/)) + goto 9999 + end if + if (size(y) < n_row) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n_row,0,0,0/)) + goto 9999 + end if + if (.not.allocated(prec%dv)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + if (prec%dv%get_nrows() < n_row) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + endif + + + select case(prec%iprcparm(psb_f_type_)) + case(psb_f_ilu_n_) + + select case(trans_) + case('N') + call psb_spsm(cone,prec%av(psb_l_pr_),x,czero,ww,desc_data,info,& + & trans=trans_,scale='L',diag=prec%dv%v%v,choice=psb_none_,work=aux) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),ww,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) + + case('T') + call psb_spsm(cone,prec%av(psb_u_pr_),x,czero,ww,desc_data,info,& + & trans=trans_,scale='L',diag=prec%dv%v%v,choice=psb_none_, work=aux) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case('C') + + call psb_spsm(cone,prec%av(psb_u_pr_),x,czero,ww,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) + ww(1:n_row) = ww(1:n_row)*conjg(prec%dv%v%v(1:n_row)) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) + + end select + if (info /= psb_success_) then + ch_err="psb_spsm" + goto 9999 + end if + + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid factorization') + goto 9999 + end select + + call psb_halo(y,desc_data,info,data=psb_comm_mov_) + + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_c_bjac_apply + +subroutine psb_c_bjac_precinit(prec,info) + use psb_base_mod + use psb_c_bjacprec, psb_protect_name => psb_c_bjac_precinit + Implicit None + + class(psb_c_bjac_prec_type),intent(inout) :: prec + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='c_bjac_precinit' + + call psb_erractionsave(err_act) + + info = psb_success_ + call psb_realloc(psb_ifpsz,prec%iprcparm,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_Errpush(info,name) + goto 9999 + end if + + prec%iprcparm(:) = 0 + prec%iprcparm(psb_p_type_) = psb_bjac_ + prec%iprcparm(psb_f_type_) = psb_f_ilu_n_ + prec%iprcparm(psb_ilu_fill_in_) = 0 + + + 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_bjac_precinit + + +subroutine psb_c_bjac_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) + + use psb_base_mod + use psb_prec_mod, only : psb_ilu_fct + use psb_c_bjacprec, psb_protect_name => psb_c_bjac_precbld + Implicit None + + type(psb_cspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_c_bjac_prec_type),intent(inout) :: prec + integer, 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 + + ! .. Local Scalars .. + integer :: i, m + integer :: int_err(5) + character :: trans, unitd + type(psb_c_csr_sparse_mat), allocatable :: lf, uf + complex(psb_spk_), allocatable :: dd(:) + integer nztota, err_act, n_row, nrow_a,n_col, nhalo + integer :: ictxt,np,me + character(len=20) :: name='c_bjac_precbld' + character(len=20) :: ch_err + + + if(psb_get_errstatus() /= 0) return + info = psb_success_ + + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + call psb_info(ictxt, me, np) + + call prec%set_ctxt(ictxt) + + m = a%get_nrows() + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + trans = 'N' + unitd = 'U' + + select case(prec%iprcparm(psb_f_type_)) + + case(psb_f_ilu_n_) + + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_c_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! This is where we have no renumbering, thus no need + call psb_ilu_fct(a,lf,uf,dd,info) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf) + call prec%av(psb_u_pr_)%mv_from(uf) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_ilu_fct' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_none_) + info=psb_err_from_subroutine_ + ch_err='Inconsistent prec psb_f_none_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + + case default + info=psb_err_from_subroutine_ + ch_err='Unknown psb_f_type_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end select + + if (present(amold)) then + call prec%av(psb_l_pr_)%cscnv(info,mold=amold) + call prec%av(psb_u_pr_)%cscnv(info,mold=amold) + else if (present(afmt)) then + call prec%av(psb_l_pr_)%cscnv(info,type=afmt) + call prec%av(psb_u_pr_)%cscnv(info,type=afmt) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_bjac_precbld + +subroutine psb_c_bjac_precseti(prec,what,val,info) + + use psb_base_mod + use psb_c_bjacprec, psb_protect_name => psb_c_bjac_precseti + Implicit None + + class(psb_c_bjac_prec_type),intent(inout) :: prec + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='c_bjac_precset' + + call psb_erractionsave(err_act) + + info = psb_success_ + if (.not.allocated(prec%iprcparm)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + + select case(what) + case (psb_f_type_) + if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then + write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& + & prec%iprcparm(psb_p_type_),& + & 'ignoring user specification' + return + endif + prec%iprcparm(psb_f_type_) = val + + case (psb_ilu_fill_in_) + if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.& + & (prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then + write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& + & prec%iprcparm(psb_p_type_),& + & 'ignoring user specification' + return + endif + prec%iprcparm(psb_ilu_fill_in_) = val + + case default + write(psb_err_unit,*) 'WHAT is invalid, ignoring user specification' + + end select + + 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_bjac_precseti diff --git a/prec/impl/psb_c_diagprec_impl.f90 b/prec/impl/psb_c_diagprec_impl.f90 new file mode 100644 index 00000000..7ebdb5af --- /dev/null +++ b/prec/impl/psb_c_diagprec_impl.f90 @@ -0,0 +1,259 @@ + +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 + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_c_diag_prec_type), intent(inout) :: prec + type(psb_c_vect_type),intent(inout) :: x + complex(psb_spk_),intent(in) :: alpha, beta + type(psb_c_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + Integer :: err_act, nrow + character(len=20) :: name='c_diag_prec_apply' + complex(psb_spk_), pointer :: ww(:) + class(psb_c_base_vect_type), allocatable :: dw + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the DIAG preonditioner??? + ! + info = psb_success_ + + nrow = desc_data%get_local_rows() + if (x%get_nrows() < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) + goto 9999 + end if + if (y%get_nrows() < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) + goto 9999 + end if + if (.not.allocated(prec%d)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + if (size(prec%d) < nrow) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + + if (size(work) >= x%get_nrows()) then + ww => work + else + allocate(ww(x%get_nrows()),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,& + & i_err=(/x%get_nrows(),0,0,0,0/),a_err='complex(psb_spk_)') + goto 9999 + end if + end if + + + call y%mlt(alpha,prec%dv,x,beta,info,conjgx=trans) + + if (size(work) < x%get_nrows()) then + deallocate(ww,stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') + goto 9999 + end if + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_diag_apply_vect + + +subroutine psb_c_diag_apply(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 + implicit none + + type(psb_desc_type),intent(in) :: desc_data + class(psb_c_diag_prec_type), intent(in) :: prec + complex(psb_spk_),intent(inout) :: x(:) + complex(psb_spk_),intent(in) :: alpha, beta + complex(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + Integer :: err_act, nrow + character :: trans_ + character(len=20) :: name='c_diag_prec_apply' + complex(psb_spk_), pointer :: ww(:) + + call psb_erractionsave(err_act) + + info = psb_success_ + + nrow = desc_data%get_local_rows() + if (size(x) < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) + goto 9999 + end if + if (size(y) < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) + goto 9999 + end if + if (.not.allocated(prec%d)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + if (size(prec%d) < nrow) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + if (present(trans)) then + trans_ = psb_toupper(trans) + else + trans_='N' + end if + + select case(trans_) + case('N') + case('T','C') + case default + info=psb_err_iarg_invalid_i_ + call psb_errpush(info,name,& + & i_err=(/6,0,0,0,0/),a_err=trans_) + goto 9999 + end select + + if (size(work) >= size(x)) then + ww => work + else + allocate(ww(size(x)),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,& + & i_err=(/size(x),0,0,0,0/),a_err='complex(psb_spk_)') + goto 9999 + end if + end if + + + if (trans_ == 'C') then + ww(1:nrow) = x(1:nrow)*conjg(prec%d(1:nrow)) + else + ww(1:nrow) = x(1:nrow)*prec%d(1:nrow) + endif + call psb_geaxpby(alpha,ww,beta,y,desc_data,info) + + if (size(work) < size(x)) then + deallocate(ww,stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') + goto 9999 + end if + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_diag_apply + + +subroutine psb_c_diag_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) + use psb_base_mod + use psb_c_diagprec, psb_protect_name => psb_c_diag_precbld + + Implicit None + + type(psb_cspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_c_diag_prec_type),intent(inout) :: prec + integer, 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 :: err_act, nrow,i + character(len=20) :: name='c_diag_precbld' + + call psb_erractionsave(err_act) + + info = psb_success_ + nrow = desc_a%get_local_cols() + if (allocated(prec%d)) then + if (size(prec%d) < nrow) then + deallocate(prec%d,stat=info) + end if + end if + if ((info == psb_success_).and.(.not.allocated(prec%d))) then + allocate(prec%d(nrow), stat=info) + end if + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + call a%get_diag(prec%d,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='get_diag') + goto 9999 + end if + + do i=1,nrow + if (prec%d(i) == dzero) then + prec%d(i) = done + else + prec%d(i) = done/prec%d(i) + endif + end do + allocate(prec%dv,stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_c_base_vect_type :: prec%dv%v,stat=info) + end if + end if + if (info == 0) then + call prec%dv%bld(prec%d) + else + write(0,*) 'Error on precbld ',info + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return +end subroutine psb_c_diag_precbld + diff --git a/prec/impl/psb_c_nullprec_impl.f90 b/prec/impl/psb_c_nullprec_impl.f90 new file mode 100644 index 00000000..eb16158a --- /dev/null +++ b/prec/impl/psb_c_nullprec_impl.f90 @@ -0,0 +1,107 @@ +subroutine psb_c_null_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + use psb_base_mod + use psb_c_nullprec, psb_protect_name => psb_c_null_apply_vect + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_c_null_prec_type), intent(inout) :: prec + type(psb_c_vect_type),intent(inout) :: x + complex(psb_spk_),intent(in) :: alpha, beta + type(psb_c_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + Integer :: err_act, nrow + character(len=20) :: name='c_null_prec_apply' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = psb_success_ + + nrow = desc_data%get_local_rows() + if (x%get_nrows() < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) + goto 9999 + end if + if (y%get_nrows() < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) + goto 9999 + end if + + call psb_geaxpby(alpha,x,beta,y,desc_data,info) + if (info /= psb_success_ ) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="psb_geaxpby") + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_null_apply_vect + +subroutine psb_c_null_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + use psb_base_mod + use psb_c_nullprec, psb_protect_name => psb_c_null_apply + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_c_null_prec_type), intent(in) :: prec + complex(psb_spk_),intent(inout) :: x(:) + complex(psb_spk_),intent(in) :: alpha, beta + complex(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + Integer :: err_act, nrow + character(len=20) :: name='c_null_prec_apply' + + call psb_erractionsave(err_act) + + ! + ! + info = psb_success_ + + nrow = desc_data%get_local_rows() + if (size(x) < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) + goto 9999 + end if + if (size(y) < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) + goto 9999 + end if + + call psb_geaxpby(alpha,x,beta,y,desc_data,info) + if (info /= psb_success_ ) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="psb_geaxpby") + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_null_apply diff --git a/prec/psb_cilu_fct.f90 b/prec/impl/psb_cilu_fct.f90 similarity index 100% rename from prec/psb_cilu_fct.f90 rename to prec/impl/psb_cilu_fct.f90 diff --git a/prec/psb_cprecbld.f90 b/prec/impl/psb_cprecbld.f90 similarity index 100% rename from prec/psb_cprecbld.f90 rename to prec/impl/psb_cprecbld.f90 diff --git a/prec/psb_cprecinit.f90 b/prec/impl/psb_cprecinit.f90 similarity index 100% rename from prec/psb_cprecinit.f90 rename to prec/impl/psb_cprecinit.f90 diff --git a/prec/psb_cprecset.f90 b/prec/impl/psb_cprecset.f90 similarity index 100% rename from prec/psb_cprecset.f90 rename to prec/impl/psb_cprecset.f90 diff --git a/prec/impl/psb_d_bjacprec_impl.f90 b/prec/impl/psb_d_bjacprec_impl.f90 new file mode 100644 index 00000000..f377fefe --- /dev/null +++ b/prec/impl/psb_d_bjacprec_impl.f90 @@ -0,0 +1,605 @@ + +subroutine psb_d_bjac_dump(prec,info,prefix,head) + use psb_base_mod + use psb_d_bjacprec, psb_protect_name => psb_d_bjac_dump + implicit none + class(psb_d_bjac_prec_type), intent(in) :: prec + integer, intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + integer :: i, j, il1, iln, lname, lev + integer :: 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_fact_d" + end if + + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + lname = lname + 5 + write(fname(lname+1:),'(a)')'_lower.mtx' + if (prec%av(psb_l_pr_)%is_asb()) & + & call prec%av(psb_l_pr_)%print(fname,head=head) + write(fname(lname+1:),'(a,a)')'_diag.mtx' + if (allocated(prec%d)) & + & call psb_geprt(fname,prec%d,head=head) + write(fname(lname+1:),'(a)')'_upper.mtx' + if (prec%av(psb_u_pr_)%is_asb()) & + & call prec%av(psb_u_pr_)%print(fname,head=head) + +end subroutine psb_d_bjac_dump + +subroutine psb_d_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + use psb_base_mod + use psb_d_bjacprec, psb_protect_name => psb_d_bjac_apply_vect + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_d_bjac_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, intent(out) :: info + character(len=1), optional :: trans + real(psb_dpk_),intent(inout), optional, target :: work(:) + + ! Local variables + integer :: n_row,n_col + real(psb_dpk_), pointer :: ww(:), aux(:) + type(psb_d_vect_type) :: wv, wv1 + integer :: ictxt,np,me, err_act, int_err(5) + integer :: debug_level, debug_unit + character :: trans_ + character(len=20) :: name='d_bjac_prec_apply' + character(len=20) :: ch_err + + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + + trans_ = psb_toupper(trans) + select case(trans_) + case('N','T','C') + ! Ok + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + if (x%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,i_err=(/2,n_row,0,0,0/)) + goto 9999 + end if + if (y%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n_row,0,0,0/)) + goto 9999 + end if + if (.not.allocated(prec%dv)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + if (prec%dv%get_nrows() < n_row) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + endif + if (info == psb_success_) allocate(wv%v,mold=x%v) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(wv1,desc_data,info,mold=x%v,scratch=.true.) + + select case(prec%iprcparm(psb_f_type_)) + case(psb_f_ilu_n_) + + select case(trans_) + case('N') + call psb_spsm(done,prec%av(psb_l_pr_),x,dzero,wv,desc_data,info,& + & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_,work=aux) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),wv,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) + + case('T') + call psb_spsm(done,prec%av(psb_u_pr_),x,dzero,wv,desc_data,info,& + & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_, work=aux) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case('C') + + call psb_spsm(done,prec%av(psb_u_pr_),x,dzero,wv,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) + + call wv1%mlt(done,prec%dv,wv,dzero,info,conjgx=trans_) + + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) + + end select + if (info /= psb_success_) then + ch_err="psb_spsm" + goto 9999 + end if + + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid factorization') + goto 9999 + end select + + call psb_halo(y,desc_data,info,data=psb_comm_mov_) + + call wv%free(info) + call wv1%free(info) + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_d_bjac_apply_vect + +subroutine psb_d_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + use psb_base_mod + use psb_d_bjacprec, psb_protect_name => psb_d_bjac_apply + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_d_bjac_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, intent(out) :: info + character(len=1), optional :: trans + real(psb_dpk_),intent(inout), optional, target :: work(:) + + ! Local variables + integer :: n_row,n_col + real(psb_dpk_), pointer :: ww(:), aux(:) + integer :: ictxt,np,me, err_act, int_err(5) + integer :: debug_level, debug_unit + character :: trans_ + character(len=20) :: name='d_bjac_prec_apply' + character(len=20) :: ch_err + + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + + trans_ = psb_toupper(trans) + select case(trans_) + case('N','T','C') + ! Ok + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + if (size(x) < n_row) then + info = 36 + call psb_errpush(info,name,i_err=(/2,n_row,0,0,0/)) + goto 9999 + end if + if (size(y) < n_row) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n_row,0,0,0/)) + goto 9999 + end if + if (.not.allocated(prec%dv)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + if (prec%dv%get_nrows() < n_row) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + endif + + + select case(prec%iprcparm(psb_f_type_)) + case(psb_f_ilu_n_) + + select case(trans_) + case('N') + call psb_spsm(done,prec%av(psb_l_pr_),x,dzero,ww,desc_data,info,& + & trans=trans_,scale='L',diag=prec%dv%v%v,choice=psb_none_,work=aux) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),ww,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) + + case('T') + call psb_spsm(done,prec%av(psb_u_pr_),x,dzero,ww,desc_data,info,& + & trans=trans_,scale='L',diag=prec%dv%v%v,choice=psb_none_, work=aux) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case('C') + + call psb_spsm(done,prec%av(psb_u_pr_),x,dzero,ww,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) + ww(1:n_row) = ww(1:n_row)*(prec%dv%v%v(1:n_row)) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) + + end select + if (info /= psb_success_) then + ch_err="psb_spsm" + goto 9999 + end if + + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid factorization') + goto 9999 + end select + + call psb_halo(y,desc_data,info,data=psb_comm_mov_) + + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_d_bjac_apply + +subroutine psb_d_bjac_precinit(prec,info) + use psb_base_mod + use psb_d_bjacprec, psb_protect_name => psb_d_bjac_precinit + Implicit None + + class(psb_d_bjac_prec_type),intent(inout) :: prec + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='d_bjac_precinit' + + call psb_erractionsave(err_act) + + info = psb_success_ + call psb_realloc(psb_ifpsz,prec%iprcparm,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_Errpush(info,name) + goto 9999 + end if + + prec%iprcparm(:) = 0 + prec%iprcparm(psb_p_type_) = psb_bjac_ + prec%iprcparm(psb_f_type_) = psb_f_ilu_n_ + prec%iprcparm(psb_ilu_fill_in_) = 0 + + + 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_bjac_precinit + + +subroutine psb_d_bjac_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) + + use psb_base_mod + use psb_prec_mod, only : psb_ilu_fct + use psb_d_bjacprec, psb_protect_name => psb_d_bjac_precbld + Implicit None + + type(psb_dspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_d_bjac_prec_type),intent(inout) :: prec + integer, 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 + + ! .. Local Scalars .. + integer :: i, m + integer :: int_err(5) + character :: trans, unitd + type(psb_d_csr_sparse_mat), allocatable :: lf, uf + real(psb_dpk_), allocatable :: dd(:) + integer nztota, err_act, n_row, nrow_a,n_col, nhalo + integer :: ictxt,np,me + character(len=20) :: name='d_bjac_precbld' + character(len=20) :: ch_err + + + if(psb_get_errstatus() /= 0) return + info = psb_success_ + + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + call psb_info(ictxt, me, np) + + call prec%set_ctxt(ictxt) + + m = a%get_nrows() + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + trans = 'N' + unitd = 'U' + + select case(prec%iprcparm(psb_f_type_)) + + case(psb_f_ilu_n_) + + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_d_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! This is where we have no renumbering, thus no need + call psb_ilu_fct(a,lf,uf,dd,info) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf) + call prec%av(psb_u_pr_)%mv_from(uf) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_ilu_fct' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_none_) + info=psb_err_from_subroutine_ + ch_err='Inconsistent prec psb_f_none_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + + case default + info=psb_err_from_subroutine_ + ch_err='Unknown psb_f_type_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end select + + if (present(amold)) then + call prec%av(psb_l_pr_)%cscnv(info,mold=amold) + call prec%av(psb_u_pr_)%cscnv(info,mold=amold) + else if (present(afmt)) then + call prec%av(psb_l_pr_)%cscnv(info,type=afmt) + call prec%av(psb_u_pr_)%cscnv(info,type=afmt) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_bjac_precbld + +subroutine psb_d_bjac_precseti(prec,what,val,info) + + use psb_base_mod + use psb_d_bjacprec, psb_protect_name => psb_d_bjac_precseti + Implicit None + + class(psb_d_bjac_prec_type),intent(inout) :: prec + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='d_bjac_precset' + + call psb_erractionsave(err_act) + + info = psb_success_ + if (.not.allocated(prec%iprcparm)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + + select case(what) + case (psb_f_type_) + if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then + write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& + & prec%iprcparm(psb_p_type_),& + & 'ignoring user specification' + return + endif + prec%iprcparm(psb_f_type_) = val + + case (psb_ilu_fill_in_) + if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.& + & (prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then + write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& + & prec%iprcparm(psb_p_type_),& + & 'ignoring user specification' + return + endif + prec%iprcparm(psb_ilu_fill_in_) = val + + case default + write(psb_err_unit,*) 'WHAT is invalid, ignoring user specification' + + end select + + 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_bjac_precseti diff --git a/prec/impl/psb_d_diagprec_impl.f90 b/prec/impl/psb_d_diagprec_impl.f90 new file mode 100644 index 00000000..025d4033 --- /dev/null +++ b/prec/impl/psb_d_diagprec_impl.f90 @@ -0,0 +1,259 @@ + +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 + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_d_diag_prec_type), intent(inout) :: prec + type(psb_d_vect_type),intent(inout) :: x + real(psb_dpk_),intent(in) :: alpha, beta + type(psb_d_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_dpk_),intent(inout), optional, target :: work(:) + Integer :: err_act, nrow + character(len=20) :: name='d_diag_prec_apply' + real(psb_dpk_), pointer :: ww(:) + class(psb_d_base_vect_type), allocatable :: dw + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the DIAG preonditioner??? + ! + info = psb_success_ + + nrow = desc_data%get_local_rows() + if (x%get_nrows() < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) + goto 9999 + end if + if (y%get_nrows() < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) + goto 9999 + end if + if (.not.allocated(prec%d)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + if (size(prec%d) < nrow) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + + if (size(work) >= x%get_nrows()) then + ww => work + else + allocate(ww(x%get_nrows()),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,& + & i_err=(/x%get_nrows(),0,0,0,0/),a_err='real(psb_dpk_)') + goto 9999 + end if + end if + + + call y%mlt(alpha,prec%dv,x,beta,info,conjgx=trans) + + if (size(work) < x%get_nrows()) then + deallocate(ww,stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') + goto 9999 + end if + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_diag_apply_vect + + +subroutine psb_d_diag_apply(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 + implicit none + + type(psb_desc_type),intent(in) :: desc_data + class(psb_d_diag_prec_type), intent(in) :: prec + real(psb_dpk_),intent(inout) :: x(:) + real(psb_dpk_),intent(in) :: alpha, beta + real(psb_dpk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_dpk_),intent(inout), optional, target :: work(:) + Integer :: err_act, nrow + character :: trans_ + character(len=20) :: name='d_diag_prec_apply' + real(psb_dpk_), pointer :: ww(:) + + call psb_erractionsave(err_act) + + info = psb_success_ + + nrow = desc_data%get_local_rows() + if (size(x) < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) + goto 9999 + end if + if (size(y) < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) + goto 9999 + end if + if (.not.allocated(prec%d)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + if (size(prec%d) < nrow) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + if (present(trans)) then + trans_ = psb_toupper(trans) + else + trans_='N' + end if + + select case(trans_) + case('N') + case('T','C') + case default + info=psb_err_iarg_invalid_i_ + call psb_errpush(info,name,& + & i_err=(/6,0,0,0,0/),a_err=trans_) + goto 9999 + end select + + if (size(work) >= size(x)) then + ww => work + else + allocate(ww(size(x)),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,& + & i_err=(/size(x),0,0,0,0/),a_err='real(psb_dpk_)') + goto 9999 + end if + end if + + + if (trans_ == 'C') then + ww(1:nrow) = x(1:nrow)*(prec%d(1:nrow)) + else + ww(1:nrow) = x(1:nrow)*prec%d(1:nrow) + endif + call psb_geaxpby(alpha,ww,beta,y,desc_data,info) + + if (size(work) < size(x)) then + deallocate(ww,stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') + goto 9999 + end if + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_diag_apply + + +subroutine psb_d_diag_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) + use psb_base_mod + use psb_d_diagprec, psb_protect_name => psb_d_diag_precbld + + Implicit None + + type(psb_dspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_d_diag_prec_type),intent(inout) :: prec + integer, 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 :: err_act, nrow,i + character(len=20) :: name='d_diag_precbld' + + call psb_erractionsave(err_act) + + info = psb_success_ + nrow = desc_a%get_local_cols() + if (allocated(prec%d)) then + if (size(prec%d) < nrow) then + deallocate(prec%d,stat=info) + end if + end if + if ((info == psb_success_).and.(.not.allocated(prec%d))) then + allocate(prec%d(nrow), stat=info) + end if + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + call a%get_diag(prec%d,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='get_diag') + goto 9999 + end if + + do i=1,nrow + if (prec%d(i) == dzero) then + prec%d(i) = done + else + prec%d(i) = done/prec%d(i) + endif + end do + allocate(prec%dv,stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_d_base_vect_type :: prec%dv%v,stat=info) + end if + end if + if (info == 0) then + call prec%dv%bld(prec%d) + else + write(0,*) 'Error on precbld ',info + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return +end subroutine psb_d_diag_precbld + diff --git a/prec/impl/psb_d_nullprec_impl.f90 b/prec/impl/psb_d_nullprec_impl.f90 new file mode 100644 index 00000000..07c817fe --- /dev/null +++ b/prec/impl/psb_d_nullprec_impl.f90 @@ -0,0 +1,107 @@ +subroutine psb_d_null_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + use psb_base_mod + use psb_d_nullprec, psb_protect_name => psb_d_null_apply_vect + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_d_null_prec_type), intent(inout) :: prec + type(psb_d_vect_type),intent(inout) :: x + real(psb_dpk_),intent(in) :: alpha, beta + type(psb_d_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_dpk_),intent(inout), optional, target :: work(:) + Integer :: err_act, nrow + character(len=20) :: name='c_null_prec_apply' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = psb_success_ + + nrow = desc_data%get_local_rows() + if (x%get_nrows() < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) + goto 9999 + end if + if (y%get_nrows() < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) + goto 9999 + end if + + call psb_geaxpby(alpha,x,beta,y,desc_data,info) + if (info /= psb_success_ ) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="psb_geaxpby") + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_null_apply_vect + +subroutine psb_d_null_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + use psb_base_mod + use psb_d_nullprec, psb_protect_name => psb_d_null_apply + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_d_null_prec_type), intent(in) :: prec + real(psb_dpk_),intent(inout) :: x(:) + real(psb_dpk_),intent(in) :: alpha, beta + real(psb_dpk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_dpk_),intent(inout), optional, target :: work(:) + Integer :: err_act, nrow + character(len=20) :: name='c_null_prec_apply' + + call psb_erractionsave(err_act) + + ! + ! + info = psb_success_ + + nrow = desc_data%get_local_rows() + if (size(x) < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) + goto 9999 + end if + if (size(y) < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) + goto 9999 + end if + + call psb_geaxpby(alpha,x,beta,y,desc_data,info) + if (info /= psb_success_ ) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="psb_geaxpby") + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_null_apply diff --git a/prec/psb_dilu_fct.f90 b/prec/impl/psb_dilu_fct.f90 similarity index 100% rename from prec/psb_dilu_fct.f90 rename to prec/impl/psb_dilu_fct.f90 diff --git a/prec/psb_dprecbld.f90 b/prec/impl/psb_dprecbld.f90 similarity index 100% rename from prec/psb_dprecbld.f90 rename to prec/impl/psb_dprecbld.f90 diff --git a/prec/psb_dprecinit.f90 b/prec/impl/psb_dprecinit.f90 similarity index 100% rename from prec/psb_dprecinit.f90 rename to prec/impl/psb_dprecinit.f90 diff --git a/prec/psb_dprecset.f90 b/prec/impl/psb_dprecset.f90 similarity index 100% rename from prec/psb_dprecset.f90 rename to prec/impl/psb_dprecset.f90 diff --git a/prec/impl/psb_s_bjacprec_impl.f90 b/prec/impl/psb_s_bjacprec_impl.f90 new file mode 100644 index 00000000..5ae02d26 --- /dev/null +++ b/prec/impl/psb_s_bjacprec_impl.f90 @@ -0,0 +1,605 @@ + +subroutine psb_s_bjac_dump(prec,info,prefix,head) + use psb_base_mod + use psb_s_bjacprec, psb_protect_name => psb_s_bjac_dump + implicit none + class(psb_s_bjac_prec_type), intent(in) :: prec + integer, intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + integer :: i, j, il1, iln, lname, lev + integer :: 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_fact_s" + end if + + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + lname = lname + 5 + write(fname(lname+1:),'(a)')'_lower.mtx' + if (prec%av(psb_l_pr_)%is_asb()) & + & call prec%av(psb_l_pr_)%print(fname,head=head) + write(fname(lname+1:),'(a,a)')'_diag.mtx' + if (allocated(prec%d)) & + & call psb_geprt(fname,prec%d,head=head) + write(fname(lname+1:),'(a)')'_upper.mtx' + if (prec%av(psb_u_pr_)%is_asb()) & + & call prec%av(psb_u_pr_)%print(fname,head=head) + +end subroutine psb_s_bjac_dump + +subroutine psb_s_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + use psb_base_mod + use psb_s_bjacprec, psb_protect_name => psb_s_bjac_apply_vect + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_s_bjac_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, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + + ! Local variables + integer :: n_row,n_col + real(psb_spk_), pointer :: ww(:), aux(:) + type(psb_s_vect_type) :: wv, wv1 + integer :: ictxt,np,me, err_act, int_err(5) + integer :: debug_level, debug_unit + character :: trans_ + character(len=20) :: name='s_bjac_prec_apply' + character(len=20) :: ch_err + + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + + trans_ = psb_toupper(trans) + select case(trans_) + case('N','T','C') + ! Ok + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + if (x%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,i_err=(/2,n_row,0,0,0/)) + goto 9999 + end if + if (y%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n_row,0,0,0/)) + goto 9999 + end if + if (.not.allocated(prec%dv)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + if (prec%dv%get_nrows() < n_row) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + endif + if (info == psb_success_) allocate(wv%v,mold=x%v) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(wv1,desc_data,info,mold=x%v,scratch=.true.) + + select case(prec%iprcparm(psb_f_type_)) + case(psb_f_ilu_n_) + + select case(trans_) + case('N') + call psb_spsm(sone,prec%av(psb_l_pr_),x,szero,wv,desc_data,info,& + & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_,work=aux) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),wv,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) + + case('T') + call psb_spsm(sone,prec%av(psb_u_pr_),x,szero,wv,desc_data,info,& + & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_, work=aux) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case('C') + + call psb_spsm(sone,prec%av(psb_u_pr_),x,szero,wv,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) + + call wv1%mlt(sone,prec%dv,wv,szero,info,conjgx=trans_) + + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) + + end select + if (info /= psb_success_) then + ch_err="psb_spsm" + goto 9999 + end if + + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid factorization') + goto 9999 + end select + + call psb_halo(y,desc_data,info,data=psb_comm_mov_) + + call wv%free(info) + call wv1%free(info) + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_s_bjac_apply_vect + +subroutine psb_s_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + use psb_base_mod + use psb_s_bjacprec, psb_protect_name => psb_s_bjac_apply + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_s_bjac_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, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + + ! Local variables + integer :: n_row,n_col + real(psb_spk_), pointer :: ww(:), aux(:) + integer :: ictxt,np,me, err_act, int_err(5) + integer :: debug_level, debug_unit + character :: trans_ + character(len=20) :: name='s_bjac_prec_apply' + character(len=20) :: ch_err + + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + + trans_ = psb_toupper(trans) + select case(trans_) + case('N','T','C') + ! Ok + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + if (size(x) < n_row) then + info = 36 + call psb_errpush(info,name,i_err=(/2,n_row,0,0,0/)) + goto 9999 + end if + if (size(y) < n_row) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n_row,0,0,0/)) + goto 9999 + end if + if (.not.allocated(prec%dv)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + if (prec%dv%get_nrows() < n_row) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + endif + + + select case(prec%iprcparm(psb_f_type_)) + case(psb_f_ilu_n_) + + select case(trans_) + case('N') + call psb_spsm(sone,prec%av(psb_l_pr_),x,szero,ww,desc_data,info,& + & trans=trans_,scale='L',diag=prec%dv%v%v,choice=psb_none_,work=aux) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),ww,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) + + case('T') + call psb_spsm(sone,prec%av(psb_u_pr_),x,szero,ww,desc_data,info,& + & trans=trans_,scale='L',diag=prec%dv%v%v,choice=psb_none_, work=aux) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case('C') + + call psb_spsm(sone,prec%av(psb_u_pr_),x,szero,ww,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) + ww(1:n_row) = ww(1:n_row)*(prec%dv%v%v(1:n_row)) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) + + end select + if (info /= psb_success_) then + ch_err="psb_spsm" + goto 9999 + end if + + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid factorization') + goto 9999 + end select + + call psb_halo(y,desc_data,info,data=psb_comm_mov_) + + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_s_bjac_apply + +subroutine psb_s_bjac_precinit(prec,info) + use psb_base_mod + use psb_s_bjacprec, psb_protect_name => psb_s_bjac_precinit + Implicit None + + class(psb_s_bjac_prec_type),intent(inout) :: prec + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='s_bjac_precinit' + + call psb_erractionsave(err_act) + + info = psb_success_ + call psb_realloc(psb_ifpsz,prec%iprcparm,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_Errpush(info,name) + goto 9999 + end if + + prec%iprcparm(:) = 0 + prec%iprcparm(psb_p_type_) = psb_bjac_ + prec%iprcparm(psb_f_type_) = psb_f_ilu_n_ + prec%iprcparm(psb_ilu_fill_in_) = 0 + + + 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_bjac_precinit + + +subroutine psb_s_bjac_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) + + use psb_base_mod + use psb_prec_mod, only : psb_ilu_fct + use psb_s_bjacprec, psb_protect_name => psb_s_bjac_precbld + Implicit None + + type(psb_sspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_s_bjac_prec_type),intent(inout) :: prec + integer, 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 + + ! .. Local Scalars .. + integer :: i, m + integer :: int_err(5) + character :: trans, unitd + type(psb_s_csr_sparse_mat), allocatable :: lf, uf + real(psb_spk_), allocatable :: dd(:) + integer nztota, err_act, n_row, nrow_a,n_col, nhalo + integer :: ictxt,np,me + character(len=20) :: name='s_bjac_precbld' + character(len=20) :: ch_err + + + if(psb_get_errstatus() /= 0) return + info = psb_success_ + + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + call psb_info(ictxt, me, np) + + call prec%set_ctxt(ictxt) + + m = a%get_nrows() + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + trans = 'N' + unitd = 'U' + + select case(prec%iprcparm(psb_f_type_)) + + case(psb_f_ilu_n_) + + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_s_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! This is where we have no renumbering, thus no need + call psb_ilu_fct(a,lf,uf,dd,info) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf) + call prec%av(psb_u_pr_)%mv_from(uf) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_ilu_fct' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_none_) + info=psb_err_from_subroutine_ + ch_err='Inconsistent prec psb_f_none_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + + case default + info=psb_err_from_subroutine_ + ch_err='Unknown psb_f_type_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end select + + if (present(amold)) then + call prec%av(psb_l_pr_)%cscnv(info,mold=amold) + call prec%av(psb_u_pr_)%cscnv(info,mold=amold) + else if (present(afmt)) then + call prec%av(psb_l_pr_)%cscnv(info,type=afmt) + call prec%av(psb_u_pr_)%cscnv(info,type=afmt) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_bjac_precbld + +subroutine psb_s_bjac_precseti(prec,what,val,info) + + use psb_base_mod + use psb_s_bjacprec, psb_protect_name => psb_s_bjac_precseti + Implicit None + + class(psb_s_bjac_prec_type),intent(inout) :: prec + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='s_bjac_precset' + + call psb_erractionsave(err_act) + + info = psb_success_ + if (.not.allocated(prec%iprcparm)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + + select case(what) + case (psb_f_type_) + if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then + write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& + & prec%iprcparm(psb_p_type_),& + & 'ignoring user specification' + return + endif + prec%iprcparm(psb_f_type_) = val + + case (psb_ilu_fill_in_) + if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.& + & (prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then + write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& + & prec%iprcparm(psb_p_type_),& + & 'ignoring user specification' + return + endif + prec%iprcparm(psb_ilu_fill_in_) = val + + case default + write(psb_err_unit,*) 'WHAT is invalid, ignoring user specification' + + end select + + 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_bjac_precseti diff --git a/prec/impl/psb_s_diagprec_impl.f90 b/prec/impl/psb_s_diagprec_impl.f90 new file mode 100644 index 00000000..eede3e8c --- /dev/null +++ b/prec/impl/psb_s_diagprec_impl.f90 @@ -0,0 +1,259 @@ + +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 + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_s_diag_prec_type), intent(inout) :: prec + type(psb_s_vect_type),intent(inout) :: x + real(psb_spk_),intent(in) :: alpha, beta + type(psb_s_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + Integer :: err_act, nrow + character(len=20) :: name='s_diag_prec_apply' + real(psb_spk_), pointer :: ww(:) + class(psb_s_base_vect_type), allocatable :: dw + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the DIAG preonditioner??? + ! + info = psb_success_ + + nrow = desc_data%get_local_rows() + if (x%get_nrows() < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) + goto 9999 + end if + if (y%get_nrows() < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) + goto 9999 + end if + if (.not.allocated(prec%d)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + if (size(prec%d) < nrow) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + + if (size(work) >= x%get_nrows()) then + ww => work + else + allocate(ww(x%get_nrows()),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,& + & i_err=(/x%get_nrows(),0,0,0,0/),a_err='real(psb_spk_)') + goto 9999 + end if + end if + + + call y%mlt(alpha,prec%dv,x,beta,info,conjgx=trans) + + if (size(work) < x%get_nrows()) then + deallocate(ww,stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') + goto 9999 + end if + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_diag_apply_vect + + +subroutine psb_s_diag_apply(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 + implicit none + + type(psb_desc_type),intent(in) :: desc_data + class(psb_s_diag_prec_type), intent(in) :: prec + real(psb_spk_),intent(inout) :: x(:) + real(psb_spk_),intent(in) :: alpha, beta + real(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + Integer :: err_act, nrow + character :: trans_ + character(len=20) :: name='s_diag_prec_apply' + real(psb_spk_), pointer :: ww(:) + + call psb_erractionsave(err_act) + + info = psb_success_ + + nrow = desc_data%get_local_rows() + if (size(x) < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) + goto 9999 + end if + if (size(y) < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) + goto 9999 + end if + if (.not.allocated(prec%d)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + if (size(prec%d) < nrow) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + if (present(trans)) then + trans_ = psb_toupper(trans) + else + trans_='N' + end if + + select case(trans_) + case('N') + case('T','C') + case default + info=psb_err_iarg_invalid_i_ + call psb_errpush(info,name,& + & i_err=(/6,0,0,0,0/),a_err=trans_) + goto 9999 + end select + + if (size(work) >= size(x)) then + ww => work + else + allocate(ww(size(x)),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,& + & i_err=(/size(x),0,0,0,0/),a_err='real(psb_spk_)') + goto 9999 + end if + end if + + + if (trans_ == 'C') then + ww(1:nrow) = x(1:nrow)*(prec%d(1:nrow)) + else + ww(1:nrow) = x(1:nrow)*prec%d(1:nrow) + endif + call psb_geaxpby(alpha,ww,beta,y,desc_data,info) + + if (size(work) < size(x)) then + deallocate(ww,stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') + goto 9999 + end if + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_diag_apply + + +subroutine psb_s_diag_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) + use psb_base_mod + use psb_s_diagprec, psb_protect_name => psb_s_diag_precbld + + Implicit None + + type(psb_sspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_s_diag_prec_type),intent(inout) :: prec + integer, 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 :: err_act, nrow,i + character(len=20) :: name='s_diag_precbld' + + call psb_erractionsave(err_act) + + info = psb_success_ + nrow = desc_a%get_local_cols() + if (allocated(prec%d)) then + if (size(prec%d) < nrow) then + deallocate(prec%d,stat=info) + end if + end if + if ((info == psb_success_).and.(.not.allocated(prec%d))) then + allocate(prec%d(nrow), stat=info) + end if + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + call a%get_diag(prec%d,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='get_diag') + goto 9999 + end if + + do i=1,nrow + if (prec%d(i) == dzero) then + prec%d(i) = done + else + prec%d(i) = done/prec%d(i) + endif + end do + allocate(prec%dv,stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_s_base_vect_type :: prec%dv%v,stat=info) + end if + end if + if (info == 0) then + call prec%dv%bld(prec%d) + else + write(0,*) 'Error on precbld ',info + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return +end subroutine psb_s_diag_precbld + diff --git a/prec/impl/psb_s_nullprec_impl.f90 b/prec/impl/psb_s_nullprec_impl.f90 new file mode 100644 index 00000000..a34207a9 --- /dev/null +++ b/prec/impl/psb_s_nullprec_impl.f90 @@ -0,0 +1,107 @@ +subroutine psb_s_null_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + use psb_base_mod + use psb_s_nullprec, psb_protect_name => psb_s_null_apply_vect + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_s_null_prec_type), intent(inout) :: prec + type(psb_s_vect_type),intent(inout) :: x + real(psb_spk_),intent(in) :: alpha, beta + type(psb_s_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + Integer :: err_act, nrow + character(len=20) :: name='c_null_prec_apply' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = psb_success_ + + nrow = desc_data%get_local_rows() + if (x%get_nrows() < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) + goto 9999 + end if + if (y%get_nrows() < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) + goto 9999 + end if + + call psb_geaxpby(alpha,x,beta,y,desc_data,info) + if (info /= psb_success_ ) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="psb_geaxpby") + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_null_apply_vect + +subroutine psb_s_null_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + use psb_base_mod + use psb_s_nullprec, psb_protect_name => psb_s_null_apply + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_s_null_prec_type), intent(in) :: prec + real(psb_spk_),intent(inout) :: x(:) + real(psb_spk_),intent(in) :: alpha, beta + real(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + Integer :: err_act, nrow + character(len=20) :: name='c_null_prec_apply' + + call psb_erractionsave(err_act) + + ! + ! + info = psb_success_ + + nrow = desc_data%get_local_rows() + if (size(x) < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) + goto 9999 + end if + if (size(y) < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) + goto 9999 + end if + + call psb_geaxpby(alpha,x,beta,y,desc_data,info) + if (info /= psb_success_ ) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="psb_geaxpby") + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_null_apply diff --git a/prec/psb_silu_fct.f90 b/prec/impl/psb_silu_fct.f90 similarity index 100% rename from prec/psb_silu_fct.f90 rename to prec/impl/psb_silu_fct.f90 diff --git a/prec/psb_sprecbld.f90 b/prec/impl/psb_sprecbld.f90 similarity index 100% rename from prec/psb_sprecbld.f90 rename to prec/impl/psb_sprecbld.f90 diff --git a/prec/psb_sprecinit.f90 b/prec/impl/psb_sprecinit.f90 similarity index 100% rename from prec/psb_sprecinit.f90 rename to prec/impl/psb_sprecinit.f90 diff --git a/prec/psb_sprecset.f90 b/prec/impl/psb_sprecset.f90 similarity index 100% rename from prec/psb_sprecset.f90 rename to prec/impl/psb_sprecset.f90 diff --git a/prec/impl/psb_z_bjacprec_impl.f90 b/prec/impl/psb_z_bjacprec_impl.f90 new file mode 100644 index 00000000..a5b3738e --- /dev/null +++ b/prec/impl/psb_z_bjacprec_impl.f90 @@ -0,0 +1,605 @@ + +subroutine psb_z_bjac_dump(prec,info,prefix,head) + use psb_base_mod + use psb_z_bjacprec, psb_protect_name => psb_z_bjac_dump + implicit none + class(psb_z_bjac_prec_type), intent(in) :: prec + integer, intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + integer :: i, j, il1, iln, lname, lev + integer :: 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_fact_z" + end if + + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + lname = lname + 5 + write(fname(lname+1:),'(a)')'_lower.mtx' + if (prec%av(psb_l_pr_)%is_asb()) & + & call prec%av(psb_l_pr_)%print(fname,head=head) + write(fname(lname+1:),'(a,a)')'_diag.mtx' + if (allocated(prec%d)) & + & call psb_geprt(fname,prec%d,head=head) + write(fname(lname+1:),'(a)')'_upper.mtx' + if (prec%av(psb_u_pr_)%is_asb()) & + & call prec%av(psb_u_pr_)%print(fname,head=head) + +end subroutine psb_z_bjac_dump + +subroutine psb_z_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + use psb_base_mod + use psb_z_bjacprec, psb_protect_name => psb_z_bjac_apply_vect + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_z_bjac_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, intent(out) :: info + character(len=1), optional :: trans + complex(psb_dpk_),intent(inout), optional, target :: work(:) + + ! Local variables + integer :: n_row,n_col + complex(psb_dpk_), pointer :: ww(:), aux(:) + type(psb_z_vect_type) :: wv, wv1 + integer :: ictxt,np,me, err_act, int_err(5) + integer :: debug_level, debug_unit + character :: trans_ + character(len=20) :: name='z_bjac_prec_apply' + character(len=20) :: ch_err + + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + + trans_ = psb_toupper(trans) + select case(trans_) + case('N','T','C') + ! Ok + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + if (x%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,i_err=(/2,n_row,0,0,0/)) + goto 9999 + end if + if (y%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n_row,0,0,0/)) + goto 9999 + end if + if (.not.allocated(prec%dv)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + if (prec%dv%get_nrows() < n_row) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + endif + if (info == psb_success_) allocate(wv%v,mold=x%v) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(wv1,desc_data,info,mold=x%v,scratch=.true.) + + select case(prec%iprcparm(psb_f_type_)) + case(psb_f_ilu_n_) + + select case(trans_) + case('N') + call psb_spsm(zone,prec%av(psb_l_pr_),x,zzero,wv,desc_data,info,& + & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_,work=aux) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),wv,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) + + case('T') + call psb_spsm(zone,prec%av(psb_u_pr_),x,zzero,wv,desc_data,info,& + & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_, work=aux) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case('C') + + call psb_spsm(zone,prec%av(psb_u_pr_),x,zzero,wv,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) + + call wv1%mlt(zone,prec%dv,wv,zzero,info,conjgx=trans_) + + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) + + end select + if (info /= psb_success_) then + ch_err="psb_spsm" + goto 9999 + end if + + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid factorization') + goto 9999 + end select + + call psb_halo(y,desc_data,info,data=psb_comm_mov_) + + call wv%free(info) + call wv1%free(info) + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_z_bjac_apply_vect + +subroutine psb_z_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + use psb_base_mod + use psb_z_bjacprec, psb_protect_name => psb_z_bjac_apply + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_z_bjac_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, intent(out) :: info + character(len=1), optional :: trans + complex(psb_dpk_),intent(inout), optional, target :: work(:) + + ! Local variables + integer :: n_row,n_col + complex(psb_dpk_), pointer :: ww(:), aux(:) + integer :: ictxt,np,me, err_act, int_err(5) + integer :: debug_level, debug_unit + character :: trans_ + character(len=20) :: name='z_bjac_prec_apply' + character(len=20) :: ch_err + + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + + trans_ = psb_toupper(trans) + select case(trans_) + case('N','T','C') + ! Ok + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + if (size(x) < n_row) then + info = 36 + call psb_errpush(info,name,i_err=(/2,n_row,0,0,0/)) + goto 9999 + end if + if (size(y) < n_row) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n_row,0,0,0/)) + goto 9999 + end if + if (.not.allocated(prec%dv)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + if (prec%dv%get_nrows() < n_row) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + endif + + + select case(prec%iprcparm(psb_f_type_)) + case(psb_f_ilu_n_) + + select case(trans_) + case('N') + call psb_spsm(zone,prec%av(psb_l_pr_),x,zzero,ww,desc_data,info,& + & trans=trans_,scale='L',diag=prec%dv%v%v,choice=psb_none_,work=aux) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),ww,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) + + case('T') + call psb_spsm(zone,prec%av(psb_u_pr_),x,zzero,ww,desc_data,info,& + & trans=trans_,scale='L',diag=prec%dv%v%v,choice=psb_none_, work=aux) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case('C') + + call psb_spsm(zone,prec%av(psb_u_pr_),x,zzero,ww,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) + ww(1:n_row) = ww(1:n_row)*conjg(prec%dv%v%v(1:n_row)) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,& + & beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) + + end select + if (info /= psb_success_) then + ch_err="psb_spsm" + goto 9999 + end if + + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid factorization') + goto 9999 + end select + + call psb_halo(y,desc_data,info,data=psb_comm_mov_) + + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_z_bjac_apply + +subroutine psb_z_bjac_precinit(prec,info) + use psb_base_mod + use psb_z_bjacprec, psb_protect_name => psb_z_bjac_precinit + Implicit None + + class(psb_z_bjac_prec_type),intent(inout) :: prec + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='z_bjac_precinit' + + call psb_erractionsave(err_act) + + info = psb_success_ + call psb_realloc(psb_ifpsz,prec%iprcparm,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_Errpush(info,name) + goto 9999 + end if + + prec%iprcparm(:) = 0 + prec%iprcparm(psb_p_type_) = psb_bjac_ + prec%iprcparm(psb_f_type_) = psb_f_ilu_n_ + prec%iprcparm(psb_ilu_fill_in_) = 0 + + + 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_bjac_precinit + + +subroutine psb_z_bjac_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) + + use psb_base_mod + use psb_prec_mod, only : psb_ilu_fct + use psb_z_bjacprec, psb_protect_name => psb_z_bjac_precbld + Implicit None + + type(psb_zspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_z_bjac_prec_type),intent(inout) :: prec + integer, 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 + + ! .. Local Scalars .. + integer :: i, m + integer :: int_err(5) + character :: trans, unitd + type(psb_z_csr_sparse_mat), allocatable :: lf, uf + complex(psb_dpk_), allocatable :: dd(:) + integer nztota, err_act, n_row, nrow_a,n_col, nhalo + integer :: ictxt,np,me + character(len=20) :: name='z_bjac_precbld' + character(len=20) :: ch_err + + + if(psb_get_errstatus() /= 0) return + info = psb_success_ + + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + call psb_info(ictxt, me, np) + + call prec%set_ctxt(ictxt) + + m = a%get_nrows() + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + trans = 'N' + unitd = 'U' + + select case(prec%iprcparm(psb_f_type_)) + + case(psb_f_ilu_n_) + + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_z_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! This is where we have no renumbering, thus no need + call psb_ilu_fct(a,lf,uf,dd,info) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf) + call prec%av(psb_u_pr_)%mv_from(uf) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_ilu_fct' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_none_) + info=psb_err_from_subroutine_ + ch_err='Inconsistent prec psb_f_none_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + + case default + info=psb_err_from_subroutine_ + ch_err='Unknown psb_f_type_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end select + + if (present(amold)) then + call prec%av(psb_l_pr_)%cscnv(info,mold=amold) + call prec%av(psb_u_pr_)%cscnv(info,mold=amold) + else if (present(afmt)) then + call prec%av(psb_l_pr_)%cscnv(info,type=afmt) + call prec%av(psb_u_pr_)%cscnv(info,type=afmt) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_bjac_precbld + +subroutine psb_z_bjac_precseti(prec,what,val,info) + + use psb_base_mod + use psb_z_bjacprec, psb_protect_name => psb_z_bjac_precseti + Implicit None + + class(psb_z_bjac_prec_type),intent(inout) :: prec + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='z_bjac_precset' + + call psb_erractionsave(err_act) + + info = psb_success_ + if (.not.allocated(prec%iprcparm)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + + select case(what) + case (psb_f_type_) + if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then + write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& + & prec%iprcparm(psb_p_type_),& + & 'ignoring user specification' + return + endif + prec%iprcparm(psb_f_type_) = val + + case (psb_ilu_fill_in_) + if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.& + & (prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then + write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& + & prec%iprcparm(psb_p_type_),& + & 'ignoring user specification' + return + endif + prec%iprcparm(psb_ilu_fill_in_) = val + + case default + write(psb_err_unit,*) 'WHAT is invalid, ignoring user specification' + + end select + + 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_bjac_precseti diff --git a/prec/impl/psb_z_diagprec_impl.f90 b/prec/impl/psb_z_diagprec_impl.f90 new file mode 100644 index 00000000..3b5fae6e --- /dev/null +++ b/prec/impl/psb_z_diagprec_impl.f90 @@ -0,0 +1,259 @@ + +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 + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_z_diag_prec_type), intent(inout) :: prec + type(psb_z_vect_type),intent(inout) :: x + complex(psb_dpk_),intent(in) :: alpha, beta + type(psb_z_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_dpk_),intent(inout), optional, target :: work(:) + Integer :: err_act, nrow + character(len=20) :: name='z_diag_prec_apply' + complex(psb_dpk_), pointer :: ww(:) + class(psb_z_base_vect_type), allocatable :: dw + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the DIAG preonditioner??? + ! + info = psb_success_ + + nrow = desc_data%get_local_rows() + if (x%get_nrows() < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) + goto 9999 + end if + if (y%get_nrows() < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) + goto 9999 + end if + if (.not.allocated(prec%d)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + if (size(prec%d) < nrow) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + + if (size(work) >= x%get_nrows()) then + ww => work + else + allocate(ww(x%get_nrows()),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,& + & i_err=(/x%get_nrows(),0,0,0,0/),a_err='complex(psb_dpk_)') + goto 9999 + end if + end if + + + call y%mlt(alpha,prec%dv,x,beta,info,conjgx=trans) + + if (size(work) < x%get_nrows()) then + deallocate(ww,stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') + goto 9999 + end if + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_diag_apply_vect + + +subroutine psb_z_diag_apply(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 + implicit none + + type(psb_desc_type),intent(in) :: desc_data + class(psb_z_diag_prec_type), intent(in) :: prec + complex(psb_dpk_),intent(inout) :: x(:) + complex(psb_dpk_),intent(in) :: alpha, beta + complex(psb_dpk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_dpk_),intent(inout), optional, target :: work(:) + Integer :: err_act, nrow + character :: trans_ + character(len=20) :: name='z_diag_prec_apply' + complex(psb_dpk_), pointer :: ww(:) + + call psb_erractionsave(err_act) + + info = psb_success_ + + nrow = desc_data%get_local_rows() + if (size(x) < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) + goto 9999 + end if + if (size(y) < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) + goto 9999 + end if + if (.not.allocated(prec%d)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + if (size(prec%d) < nrow) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner: D") + goto 9999 + end if + if (present(trans)) then + trans_ = psb_toupper(trans) + else + trans_='N' + end if + + select case(trans_) + case('N') + case('T','C') + case default + info=psb_err_iarg_invalid_i_ + call psb_errpush(info,name,& + & i_err=(/6,0,0,0,0/),a_err=trans_) + goto 9999 + end select + + if (size(work) >= size(x)) then + ww => work + else + allocate(ww(size(x)),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,& + & i_err=(/size(x),0,0,0,0/),a_err='complex(psb_dpk_)') + goto 9999 + end if + end if + + + if (trans_ == 'C') then + ww(1:nrow) = x(1:nrow)*conjg(prec%d(1:nrow)) + else + ww(1:nrow) = x(1:nrow)*prec%d(1:nrow) + endif + call psb_geaxpby(alpha,ww,beta,y,desc_data,info) + + if (size(work) < size(x)) then + deallocate(ww,stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') + goto 9999 + end if + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_diag_apply + + +subroutine psb_z_diag_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) + use psb_base_mod + use psb_z_diagprec, psb_protect_name => psb_z_diag_precbld + + Implicit None + + type(psb_zspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_z_diag_prec_type),intent(inout) :: prec + integer, 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 :: err_act, nrow,i + character(len=20) :: name='z_diag_precbld' + + call psb_erractionsave(err_act) + + info = psb_success_ + nrow = desc_a%get_local_cols() + if (allocated(prec%d)) then + if (size(prec%d) < nrow) then + deallocate(prec%d,stat=info) + end if + end if + if ((info == psb_success_).and.(.not.allocated(prec%d))) then + allocate(prec%d(nrow), stat=info) + end if + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + call a%get_diag(prec%d,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='get_diag') + goto 9999 + end if + + do i=1,nrow + if (prec%d(i) == dzero) then + prec%d(i) = done + else + prec%d(i) = done/prec%d(i) + endif + end do + allocate(prec%dv,stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_z_base_vect_type :: prec%dv%v,stat=info) + end if + end if + if (info == 0) then + call prec%dv%bld(prec%d) + else + write(0,*) 'Error on precbld ',info + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return +end subroutine psb_z_diag_precbld + diff --git a/prec/impl/psb_z_nullprec_impl.f90 b/prec/impl/psb_z_nullprec_impl.f90 new file mode 100644 index 00000000..31898b74 --- /dev/null +++ b/prec/impl/psb_z_nullprec_impl.f90 @@ -0,0 +1,107 @@ +subroutine psb_z_null_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + use psb_base_mod + use psb_z_nullprec, psb_protect_name => psb_z_null_apply_vect + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_z_null_prec_type), intent(inout) :: prec + type(psb_z_vect_type),intent(inout) :: x + complex(psb_dpk_),intent(in) :: alpha, beta + type(psb_z_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_dpk_),intent(inout), optional, target :: work(:) + Integer :: err_act, nrow + character(len=20) :: name='c_null_prec_apply' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = psb_success_ + + nrow = desc_data%get_local_rows() + if (x%get_nrows() < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) + goto 9999 + end if + if (y%get_nrows() < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) + goto 9999 + end if + + call psb_geaxpby(alpha,x,beta,y,desc_data,info) + if (info /= psb_success_ ) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="psb_geaxpby") + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_null_apply_vect + +subroutine psb_z_null_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + use psb_base_mod + use psb_z_nullprec, psb_protect_name => psb_z_null_apply + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_z_null_prec_type), intent(in) :: prec + complex(psb_dpk_),intent(inout) :: x(:) + complex(psb_dpk_),intent(in) :: alpha, beta + complex(psb_dpk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_dpk_),intent(inout), optional, target :: work(:) + Integer :: err_act, nrow + character(len=20) :: name='c_null_prec_apply' + + call psb_erractionsave(err_act) + + ! + ! + info = psb_success_ + + nrow = desc_data%get_local_rows() + if (size(x) < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) + goto 9999 + end if + if (size(y) < nrow) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) + goto 9999 + end if + + call psb_geaxpby(alpha,x,beta,y,desc_data,info) + if (info /= psb_success_ ) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="psb_geaxpby") + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_null_apply diff --git a/prec/psb_zilu_fct.f90 b/prec/impl/psb_zilu_fct.f90 similarity index 100% rename from prec/psb_zilu_fct.f90 rename to prec/impl/psb_zilu_fct.f90 diff --git a/prec/psb_zprecbld.f90 b/prec/impl/psb_zprecbld.f90 similarity index 100% rename from prec/psb_zprecbld.f90 rename to prec/impl/psb_zprecbld.f90 diff --git a/prec/psb_zprecinit.f90 b/prec/impl/psb_zprecinit.f90 similarity index 100% rename from prec/psb_zprecinit.f90 rename to prec/impl/psb_zprecinit.f90 diff --git a/prec/psb_zprecset.f90 b/prec/impl/psb_zprecset.f90 similarity index 100% rename from prec/psb_zprecset.f90 rename to prec/impl/psb_zprecset.f90 diff --git a/prec/psb_c_base_prec_mod.f90 b/prec/psb_c_base_prec_mod.f90 index aab973c8..a481a649 100644 --- a/prec/psb_c_base_prec_mod.f90 +++ b/prec/psb_c_base_prec_mod.f90 @@ -38,7 +38,7 @@ module psb_c_base_prec_mod ! Reduces size of .mod file. use psb_base_mod, only : psb_spk_, psb_long_int_k_,& & psb_desc_type, psb_sizeof, psb_free, psb_cdfree, psb_errpush, psb_act_abort_,& - & psb_erractionsave, psb_erractionrestore, psb_error, psb_get_errstatus,& + & psb_erractionsave, psb_erractionrestore, psb_error, psb_get_errstatus, psb_success_,& & psb_c_base_sparse_mat, psb_cspmat_type, psb_c_csr_sparse_mat,& & psb_c_base_vect_type, psb_c_vect_type diff --git a/prec/psb_c_bjacprec.f90 b/prec/psb_c_bjacprec.f90 index 2f525142..d90bbf89 100644 --- a/prec/psb_c_bjacprec.f90 +++ b/prec/psb_c_bjacprec.f90 @@ -22,577 +22,195 @@ module psb_c_bjacprec procedure, pass(prec) :: get_nzeros => psb_c_bjac_get_nzeros end type psb_c_bjac_prec_type - private :: psb_c_bjac_apply, psb_c_bjac_precbld, psb_c_bjac_precseti,& - & psb_c_bjac_precsetr, psb_c_bjac_precsetc, psb_c_bjac_sizeof,& - & psb_c_bjac_precinit, psb_c_bjac_precfree, psb_c_bjac_precdescr,& - & psb_c_bjac_dump, psb_c_bjac_apply_vect, psb_c_bjac_get_nzeros + private :: psb_c_bjac_sizeof, psb_c_bjac_precdescr, psb_c_bjac_get_nzeros character(len=15), parameter, private :: & & fact_names(0:2)=(/'None ','ILU(n) ',& & 'ILU(eps) '/) -contains - subroutine psb_c_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_c_bjac_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, intent(out) :: info - character(len=1), optional :: trans - complex(psb_spk_),intent(inout), optional, target :: work(:) - - ! Local variables - integer :: n_row,n_col - complex(psb_spk_), pointer :: ww(:), aux(:) - type(psb_c_vect_type) :: wv - integer :: ictxt,np,me, err_act, int_err(5) - integer :: debug_level, debug_unit - character :: trans_ - character(len=20) :: name='d_bjac_prec_apply' - character(len=20) :: ch_err - - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) - - - trans_ = psb_toupper(trans) - select case(trans_) - case('N','T','C') - ! Ok - case default - call psb_errpush(psb_err_iarg_invalid_i_,name) - goto 9999 - end select - - - n_row = desc_data%get_local_rows() - n_col = desc_data%get_local_cols() - - if (x%get_nrows() < n_row) then - info = 36 - call psb_errpush(info,name,i_err=(/2,n_row,0,0,0/)) - goto 9999 - end if - if (y%get_nrows() < n_row) then - info = 36 - call psb_errpush(info,name,i_err=(/3,n_row,0,0,0/)) - goto 9999 - end if - if (.not.allocated(prec%d)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - if (size(prec%d) < n_row) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if + interface psb_c_bjac_dump + subroutine psb_c_bjac_dump(prec,info,prefix,head) + import :: psb_desc_type, psb_c_bjac_prec_type, psb_c_vect_type, psb_spk_ + class(psb_c_bjac_prec_type), intent(in) :: prec + integer, intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + end subroutine psb_c_bjac_dump + end interface psb_c_bjac_dump + + interface psb_c_bjac_apply_vect + subroutine psb_c_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_c_bjac_prec_type, psb_c_vect_type, psb_spk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_c_bjac_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, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + end subroutine psb_c_bjac_apply_vect + end interface psb_c_bjac_apply_vect + + interface psb_c_bjac_apply + subroutine psb_c_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_c_bjac_prec_type, psb_c_vect_type, psb_spk_ + + type(psb_desc_type),intent(in) :: desc_data + class(psb_c_bjac_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, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + end subroutine psb_c_bjac_apply + end interface psb_c_bjac_apply + + interface psb_c_bjac_precinit + subroutine psb_c_bjac_precinit(prec,info) + import :: psb_desc_type, psb_c_bjac_prec_type, psb_c_vect_type, psb_spk_ + class(psb_c_bjac_prec_type),intent(inout) :: prec + integer, intent(out) :: info + end subroutine psb_c_bjac_precinit + end interface psb_c_bjac_precinit + + interface psb_c_bjac_precbld + subroutine psb_c_bjac_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) + import :: psb_desc_type, psb_c_bjac_prec_type, psb_c_vect_type, psb_spk_, & + & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type + type(psb_cspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_c_bjac_prec_type),intent(inout) :: prec + integer, 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_bjac_precbld + end interface psb_c_bjac_precbld + + interface psb_c_bjac_precseti + subroutine psb_c_bjac_precseti(prec,what,val,info) + import :: psb_desc_type, psb_c_bjac_prec_type, psb_c_vect_type, psb_spk_ + class(psb_c_bjac_prec_type),intent(inout) :: prec + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + end subroutine psb_c_bjac_precseti + end interface psb_c_bjac_precseti + +!!$ interface psb_c_bjac_precsetr +!!$ subroutine psb_c_bjac_precsetr(prec,what,val,info) +!!$ import :: psb_desc_type, psb_c_bjac_prec_type, psb_c_vect_type, psb_spk_ +!!$ class(psb_c_bjac_prec_type),intent(inout) :: prec +!!$ integer, intent(in) :: what +!!$ real(psb_spk_), intent(in) :: val +!!$ integer, intent(out) :: info +!!$ end subroutine psb_c_bjac_precsetr +!!$ end interface psb_c_bjac_precsetr +!!$ +!!$ interface psb_c_bjac_precsetc +!!$ subroutine psb_c_bjac_precsetc(prec,what,val,info) +!!$ import :: psb_desc_type, psb_c_bjac_prec_type, psb_c_vect_type, psb_spk_ +!!$ class(psb_c_bjac_prec_type),intent(inout) :: prec +!!$ integer, intent(in) :: what +!!$ character(len=*), intent(in) :: val +!!$ integer, intent(out) :: info +!!$ end subroutine psb_c_bjac_precsetc +!!$ end interface psb_c_bjac_precsetc +!!$ +!!$ interface psb_c_bjac_precfree +!!$ subroutine psb_c_bjac_precfree(prec,info) +!!$ import :: psb_desc_type, psb_c_bjac_prec_type, psb_c_vect_type, psb_spk_ +!!$ class(psb_c_bjac_prec_type), intent(inout) :: prec +!!$ integer, intent(out) :: info +!!$ end subroutine psb_c_bjac_precfree +!!$ end interface psb_c_bjac_precfree - - if (n_col <= size(work)) then - ww => work(1:n_col) - if ((4*n_col+n_col) <= size(work)) then - aux => work(n_col+1:) - else - allocate(aux(4*n_col),stat=info) - - endif - else - allocate(ww(n_col),aux(4*n_col),stat=info) - endif - if (info == psb_success_) allocate(wv%v,mold=x%v) +contains - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - call wv%bld(n_col,mold=x%v) - - select case(prec%iprcparm(psb_f_type_)) - case(psb_f_ilu_n_) - - select case(trans_) - case('N') - call psb_spsm(cone,prec%av(psb_l_pr_),x,czero,wv,desc_data,info,& - & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_,work=aux) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),wv,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_, work=aux) - - case('T') - call psb_spsm(cone,prec%av(psb_u_pr_),x,czero,wv,desc_data,info,& - & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_, work=aux) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) - - case('C') - write(0,*) 'WARNING: Conjguate case not fixed yet' - call psb_spsm(cone,prec%av(psb_u_pr_),x,czero,wv,desc_data,info,& - & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_, work=aux) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) - - end select - if (info /= psb_success_) then - ch_err="psb_spsm" - goto 9999 - end if - - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Invalid factorization') - goto 9999 - end select - - call psb_halo(y,desc_data,info,data=psb_comm_mov_) - - call wv%free(info) - if (n_col <= size(work)) then - if ((4*n_col+n_col) <= size(work)) then - else - deallocate(aux) - endif - else - deallocate(ww,aux) - endif - - - call psb_erractionrestore(err_act) - return + subroutine psb_c_bjac_precdescr(prec,iout) -9999 continue - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return + Implicit None + class(psb_c_bjac_prec_type), intent(in) :: prec + integer, intent(in), optional :: iout - end subroutine psb_c_bjac_apply_vect - - subroutine psb_c_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_c_bjac_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, intent(out) :: info - character(len=1), optional :: trans - complex(psb_spk_),intent(inout), optional, target :: work(:) - - ! Local variables - integer :: n_row,n_col - complex(psb_spk_), pointer :: ww(:), aux(:) - integer :: ictxt,np,me, err_act, int_err(5) - integer :: debug_level, debug_unit - character :: trans_ - character(len=20) :: name='c_bjac_prec_apply' - character(len=20) :: ch_err + Integer :: err_act, nrow, info + character(len=20) :: name='c_bjac_precdescr' + integer :: iout_ - info = psb_success_ call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) - - - trans_ = psb_toupper(trans) - select case(trans_) - case('N','T','C') - ! Ok - case default - call psb_errpush(psb_err_iarg_invalid_i_,name) - goto 9999 - end select - - - n_row = desc_data%get_local_rows() - n_col = desc_data%get_local_cols() - if (size(x) < n_row) then - info = 36 - call psb_errpush(info,name,i_err=(/2,n_row,0,0,0/)) - goto 9999 - end if - if (size(y) < n_row) then - info = 36 - call psb_errpush(info,name,i_err=(/3,n_row,0,0,0/)) - goto 9999 + info = psb_success_ + + if (present(iout)) then + iout_ = iout + else + iout_ = 6 end if -!!$ if (.not.allocated(prec%d)) then -!!$ info = 1124 -!!$ call psb_errpush(info,name,a_err="preconditioner: D") -!!$ goto 9999 -!!$ end if -!!$ if (size(prec%d) < n_row) then -!!$ info = 1124 -!!$ call psb_errpush(info,name,a_err="preconditioner: D") -!!$ goto 9999 -!!$ end if - - if (n_col <= size(work)) then - ww => work(1:n_col) - if ((4*n_col+n_col) <= size(work)) then - aux => work(n_col+1:) - else - allocate(aux(4*n_col),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - - endif - else - allocate(ww(n_col),aux(4*n_col),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - endif - - - select case(prec%iprcparm(psb_f_type_)) - case(psb_f_ilu_n_) - - select case(trans_) - case('N') - call psb_spsm(cone,prec%av(psb_l_pr_),x,czero,ww,desc_data,info,& - & trans=trans_,scale='L',diag=prec%dv%v%v,choice=psb_none_,work=aux) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),ww,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_, work=aux) - - case('T') - call psb_spsm(cone,prec%av(psb_u_pr_),x,czero,ww,desc_data,info,& - & trans=trans_,scale='L',diag=prec%dv%v%v,choice=psb_none_, work=aux) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) - - case('C') -!!$ call psb_spsm(cone,prec%av(psb_u_pr_),x,czero,ww,desc_data,info,& -!!$ & trans=trans_,scale='L',diag=conjg(prec%dv%v%v),choice=psb_none_, work=aux) - call psb_spsm(cone,prec%av(psb_u_pr_),x,czero,ww,desc_data,info,& - & trans=trans_,scale='L',choice=psb_none_, work=aux) - ww(1:n_row) = ww(1:n_row)*conjg(prec%dv%v%v(1:n_row)) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) - - end select - if (info /= psb_success_) then - ch_err="psb_spsm" - goto 9999 - end if - - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Invalid factorization') + if (.not.allocated(prec%iprcparm)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") goto 9999 - end select - - call psb_halo(y,desc_data,info,data=psb_comm_mov_) - - if (n_col <= size(work)) then - if ((4*n_col+n_col) <= size(work)) then - else - deallocate(aux) - endif - else - deallocate(ww,aux) - endif + end if + write(iout_,*) 'Block Jacobi with: ',& + & fact_names(prec%iprcparm(psb_f_type_)) call psb_erractionrestore(err_act) return - + 9999 continue - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then call psb_error() return end if return - - - end subroutine psb_c_bjac_apply - - subroutine psb_c_bjac_precinit(prec,info) - use psb_base_mod - Implicit None - - class(psb_c_bjac_prec_type),intent(inout) :: prec - integer, intent(out) :: info - Integer :: err_act, nrow - character(len=20) :: name='c_bjac_precinit' + end subroutine psb_c_bjac_precdescr - call psb_erractionsave(err_act) - info = psb_success_ - call psb_realloc(psb_ifpsz,prec%iprcparm,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_Errpush(info,name) - goto 9999 - end if + function psb_c_bjac_sizeof(prec) result(val) + class(psb_c_bjac_prec_type), intent(in) :: prec + integer(psb_long_int_k_) :: val - prec%iprcparm(:) = 0 - prec%iprcparm(psb_p_type_) = psb_bjac_ - prec%iprcparm(psb_f_type_) = psb_f_ilu_n_ - prec%iprcparm(psb_ilu_fill_in_) = 0 - - - 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 + val = 0 + if (allocated(prec%dv)) then + val = val + (2*psb_sizeof_sp) * prec%dv%get_nrows() + endif + if (allocated(prec%av)) then + val = val + prec%av(psb_l_pr_)%sizeof() + val = val + prec%av(psb_u_pr_)%sizeof() + endif return - end subroutine psb_c_bjac_precinit - - - subroutine psb_c_bjac_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - - use psb_base_mod - use psb_prec_mod, only : psb_ilu_fct - Implicit None - - type(psb_cspmat_type), intent(in), target :: a - type(psb_desc_type), intent(in), target :: desc_a - class(psb_c_bjac_prec_type),intent(inout) :: prec - integer, 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 - - ! .. Local Scalars .. - integer :: i, m - integer :: int_err(5) - character :: trans, unitd - type(psb_c_csr_sparse_mat), allocatable :: lf, uf - complex(psb_spk_), allocatable :: dd(:) - integer nztota, err_act, n_row, nrow_a,n_col, nhalo - integer :: ictxt,np,me - character(len=20) :: name='c_bjac_precbld' - character(len=20) :: ch_err - - - if(psb_get_errstatus() /= 0) return - info = psb_success_ - - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + end function psb_c_bjac_sizeof - call prec%set_ctxt(ictxt) + function psb_c_bjac_get_nzeros(prec) result(val) - m = a%get_nrows() - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,i_err=int_err) - goto 9999 + class(psb_c_bjac_prec_type), intent(in) :: prec + integer(psb_long_int_k_) :: val + + val = 0 + if (allocated(prec%dv)) then + val = val + prec%dv%get_nrows() + endif + if (allocated(prec%av)) then + val = val + prec%av(psb_l_pr_)%get_nzeros() + val = val + prec%av(psb_u_pr_)%get_nzeros() endif - trans = 'N' - unitd = 'U' - - select case(prec%iprcparm(psb_f_type_)) - - case(psb_f_ilu_n_) - - if (allocated(prec%av)) then - if (size(prec%av) < psb_bp_ilu_avsz) then - do i=1,size(prec%av) - call prec%av(i)%free() - enddo - deallocate(prec%av,stat=info) - endif - end if - if (.not.allocated(prec%av)) then - allocate(prec%av(psb_max_avsz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - endif - - nrow_a = desc_a%get_local_rows() - nztota = a%get_nzeros() - - n_col = desc_a%get_local_cols() - nhalo = n_col-nrow_a - n_row = nrow_a - - allocate(lf,uf,stat=info) - if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) - if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) - - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - allocate(dd(n_row),stat=info) - if (info == psb_success_) then - allocate(prec%dv, stat=info) - if (info == 0) then - if (present(vmold)) then - allocate(prec%dv%v,mold=vmold,stat=info) - else - allocate(psb_c_base_vect_type :: prec%dv%v,stat=info) - end if - end if - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - endif - ! This is where we have no renumbering, thus no need - call psb_ilu_fct(a,lf,uf,dd,info) - - if(info == psb_success_) then - call prec%av(psb_l_pr_)%mv_from(lf) - call prec%av(psb_u_pr_)%mv_from(uf) - call prec%av(psb_l_pr_)%set_asb() - call prec%av(psb_u_pr_)%set_asb() - call prec%av(psb_l_pr_)%trim() - call prec%av(psb_u_pr_)%trim() - call prec%dv%bld(dd) - call move_alloc(dd,prec%d) - else - info=psb_err_from_subroutine_ - ch_err='psb_ilu_fct' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case(psb_f_none_) - info=psb_err_from_subroutine_ - ch_err='Inconsistent prec psb_f_none_' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - - case default - info=psb_err_from_subroutine_ - ch_err='Unknown psb_f_type_' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - - if (present(amold)) then - call prec%av(psb_l_pr_)%cscnv(info,mold=amold) - call prec%av(psb_u_pr_)%cscnv(info,mold=amold) - else if (present(afmt)) then - call prec%av(psb_l_pr_)%cscnv(info,type=afmt) - call prec%av(psb_u_pr_)%cscnv(info,type=afmt) - end if - - call psb_erractionrestore(err_act) return + end function psb_c_bjac_get_nzeros -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_bjac_precbld + subroutine psb_c_bjac_precsetr(prec,what,val,info) - subroutine psb_c_bjac_precseti(prec,what,val,info) - - use psb_base_mod Implicit None - - class(psb_c_bjac_prec_type),intent(inout) :: prec - integer, intent(in) :: what - integer, intent(in) :: val - integer, intent(out) :: info - Integer :: err_act, nrow - character(len=20) :: name='c_bjac_precset' - call psb_erractionsave(err_act) - - info = psb_success_ - if (.not.allocated(prec%iprcparm)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - - select case(what) - case (psb_f_type_) - if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then - write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& - & prec%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif - prec%iprcparm(psb_f_type_) = val - - case (psb_ilu_fill_in_) - if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.& - & (prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then - write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& - & prec%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif - prec%iprcparm(psb_ilu_fill_in_) = val - - case default - write(psb_err_unit,*) 'WHAT is invalid, ignoring user specification' - - end select - - 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_bjac_precseti - - subroutine psb_c_bjac_precsetr(prec,what,val,info) - - use psb_base_mod - Implicit None - class(psb_c_bjac_prec_type),intent(inout) :: prec integer, intent(in) :: what real(psb_spk_), intent(in) :: val @@ -603,7 +221,7 @@ contains call psb_erractionsave(err_act) info = psb_success_ - + call psb_erractionrestore(err_act) return @@ -617,10 +235,9 @@ contains end subroutine psb_c_bjac_precsetr subroutine psb_c_bjac_precsetc(prec,what,val,info) - - use psb_base_mod + Implicit None - + class(psb_c_bjac_prec_type),intent(inout) :: prec integer, intent(in) :: what character(len=*), intent(in) :: val @@ -631,7 +248,7 @@ contains call psb_erractionsave(err_act) info = psb_success_ - + call psb_erractionrestore(err_act) return @@ -645,18 +262,17 @@ contains end subroutine psb_c_bjac_precsetc subroutine psb_c_bjac_precfree(prec,info) - - use psb_base_mod + Implicit None class(psb_c_bjac_prec_type), intent(inout) :: prec integer, intent(out) :: info - + Integer :: err_act, i character(len=20) :: name='c_bjac_precfree' - + call psb_erractionsave(err_act) - + info = psb_success_ if (allocated(prec%av)) then do i=1,size(prec%av) @@ -681,128 +297,7 @@ contains return end if return - - end subroutine psb_c_bjac_precfree - - - subroutine psb_c_bjac_precdescr(prec,iout) - - use psb_base_mod - Implicit None - - class(psb_c_bjac_prec_type), intent(in) :: prec - integer, intent(in), optional :: iout - - Integer :: err_act, nrow, info - character(len=20) :: name='c_bjac_precdescr' - integer :: iout_ - - call psb_erractionsave(err_act) - - info = psb_success_ - - if (present(iout)) then - iout_ = iout - else - iout_ = 6 - end if - - if (.not.allocated(prec%iprcparm)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - - write(iout_,*) 'Block Jacobi with: ',& - & fact_names(prec%iprcparm(psb_f_type_)) - - 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_bjac_precdescr - - subroutine psb_c_bjac_dump(prec,info,prefix,head) - use psb_base_mod - implicit none - class(psb_c_bjac_prec_type), intent(in) :: prec - integer, intent(out) :: info - character(len=*), intent(in), optional :: prefix,head - integer :: i, j, il1, iln, lname, lev - integer :: 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_fact_d" - end if - - lname = len_trim(prefix_) - fname = trim(prefix_) - write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam - lname = lname + 5 - write(fname(lname+1:),'(a)')'_lower.mtx' - if (prec%av(psb_l_pr_)%is_asb()) & - & call prec%av(psb_l_pr_)%print(fname,head=head) - write(fname(lname+1:),'(a,a)')'_diag.mtx' - if (allocated(prec%d)) & - & call psb_geprt(fname,prec%d,head=head) - write(fname(lname+1:),'(a)')'_upper.mtx' - if (prec%av(psb_u_pr_)%is_asb()) & - & call prec%av(psb_u_pr_)%print(fname,head=head) - - end subroutine psb_c_bjac_dump - - function psb_c_bjac_sizeof(prec) result(val) - use psb_base_mod, only : psb_long_int_k_ - class(psb_c_bjac_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val - - val = 0 - if (allocated(prec%d)) then - val = val + 2*psb_sizeof_sp * size(prec%d) - endif - if (allocated(prec%av)) then - val = val + psb_sizeof(prec%av(psb_l_pr_)) - val = val + psb_sizeof(prec%av(psb_u_pr_)) - endif - return - end function psb_c_bjac_sizeof - - function psb_c_bjac_get_nzeros(prec) result(val) - use psb_base_mod, only : psb_long_int_k_ - class(psb_c_bjac_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val - - val = 0 - if (allocated(prec%dv)) then - val = val + prec%dv%get_nrows() - endif - if (allocated(prec%av)) then - val = val + prec%av(psb_l_pr_)%get_nzeros() - val = val + prec%av(psb_u_pr_)%get_nzeros() - endif - return - end function psb_c_bjac_get_nzeros + end subroutine psb_c_bjac_precfree end module psb_c_bjacprec diff --git a/prec/psb_c_diagprec.f90 b/prec/psb_c_diagprec.f90 index fc489b6c..a690e68d 100644 --- a/prec/psb_c_diagprec.f90 +++ b/prec/psb_c_diagprec.f90 @@ -19,195 +19,61 @@ module psb_c_diagprec procedure, pass(prec) :: get_nzeros => psb_c_diag_get_nzeros end type psb_c_diag_prec_type - private :: psb_c_diag_apply, psb_c_diag_precbld, psb_c_diag_precseti,& + private :: psb_c_diag_precseti,& & psb_c_diag_precsetr, psb_c_diag_precsetc, psb_c_diag_sizeof,& & psb_c_diag_precinit, psb_c_diag_precfree, psb_c_diag_precdescr,& - & psb_c_diag_apply_vect, psb_c_diag_get_nzeros + & psb_c_diag_get_nzeros + + + + interface psb_c_diag_apply_vect + subroutine psb_c_diag_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_c_diag_prec_type, psb_c_vect_type, psb_spk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_c_diag_prec_type), intent(inout) :: prec + type(psb_c_vect_type),intent(inout) :: x + complex(psb_spk_),intent(in) :: alpha, beta + type(psb_c_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + end subroutine psb_c_diag_apply_vect + end interface psb_c_diag_apply_vect + + interface psb_c_diag_apply + subroutine psb_c_diag_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_c_diag_prec_type, psb_c_vect_type, psb_spk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_c_diag_prec_type), intent(in) :: prec + complex(psb_spk_),intent(inout) :: x(:) + complex(psb_spk_),intent(in) :: alpha, beta + complex(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + end subroutine psb_c_diag_apply + end interface psb_c_diag_apply + + interface psb_c_diag_precbld + subroutine psb_c_diag_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) + import :: psb_desc_type, psb_c_diag_prec_type, psb_c_vect_type, psb_spk_, & + & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type + type(psb_cspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_c_diag_prec_type),intent(inout) :: prec + integer, 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_diag_precbld + end interface psb_c_diag_precbld contains - subroutine psb_c_diag_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_c_diag_prec_type), intent(inout) :: prec - type(psb_c_vect_type),intent(inout) :: x - complex(psb_spk_),intent(in) :: alpha, beta - type(psb_c_vect_type),intent(inout) :: y - integer, intent(out) :: info - character(len=1), optional :: trans - complex(psb_spk_),intent(inout), optional, target :: work(:) - Integer :: err_act, nrow - character(len=20) :: name='d_diag_prec_apply' - complex(psb_spk_), pointer :: ww(:) - class(psb_c_base_vect_type), allocatable :: dw - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the DIAG preonditioner??? - ! - info = psb_success_ - - nrow = desc_data%get_local_rows() - if (x%get_nrows() < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) - goto 9999 - end if - if (y%get_nrows() < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) - goto 9999 - end if - if (.not.allocated(prec%d)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - if (size(prec%d) < nrow) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - - if (size(work) >= x%get_nrows()) then - ww => work - else - allocate(ww(x%get_nrows()),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,& - & i_err=(/x%get_nrows(),0,0,0,0/),a_err='complex(psb_spk_)') - goto 9999 - end if - end if - - - call y%mlt(alpha,prec%dv,x,beta,info,conjgx=trans) - - if (size(work) < x%get_nrows()) then - deallocate(ww,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') - goto 9999 - end if - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psb_c_diag_apply_vect - - - subroutine psb_c_diag_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_c_diag_prec_type), intent(in) :: prec - complex(psb_spk_),intent(inout) :: x(:) - complex(psb_spk_),intent(in) :: alpha, beta - complex(psb_spk_),intent(inout) :: y(:) - integer, intent(out) :: info - character(len=1), optional :: trans - complex(psb_spk_),intent(inout), optional, target :: work(:) - Integer :: err_act, nrow - character :: trans_ - character(len=20) :: name='c_diag_prec_apply' - complex(psb_spk_), pointer :: ww(:) - - call psb_erractionsave(err_act) - - info = psb_success_ - - nrow = desc_data%get_local_rows() - if (size(x) < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) - goto 9999 - end if - if (size(y) < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) - goto 9999 - end if - if (.not.allocated(prec%d)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - if (size(prec%d) < nrow) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - if (present(trans)) then - trans_ = psb_toupper(trans) - else - trans_='N' - end if - - select case(trans_) - case('N') - case('T','C') - case default - info=psb_err_iarg_invalid_i_ - call psb_errpush(info,name,& - & i_err=(/6,0,0,0,0/),a_err=trans_) - goto 9999 - end select - - if (size(work) >= size(x)) then - ww => work - else - allocate(ww(size(x)),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,& - & i_err=(/size(x),0,0,0,0/),a_err='complex(psb_spk_)') - goto 9999 - end if - end if - - - if (trans_ == 'C') then - ww(1:nrow) = x(1:nrow)*conjg(prec%d(1:nrow)) - else - ww(1:nrow) = x(1:nrow)*prec%d(1:nrow) - endif - call psb_geaxpby(alpha,ww,beta,y,desc_data,info) - - if (size(work) < size(x)) then - deallocate(ww,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') - goto 9999 - end if - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psb_c_diag_apply - subroutine psb_c_diag_precinit(prec,info) - - use psb_base_mod Implicit None class(psb_c_diag_prec_type),intent(inout) :: prec @@ -233,83 +99,7 @@ contains end subroutine psb_c_diag_precinit - subroutine psb_c_diag_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - - use psb_base_mod - Implicit None - - type(psb_cspmat_type), intent(in), target :: a - type(psb_desc_type), intent(in), target :: desc_a - class(psb_c_diag_prec_type),intent(inout) :: prec - integer, 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 :: err_act, nrow,i - character(len=20) :: name='c_diag_precbld' - - call psb_erractionsave(err_act) - - info = psb_success_ - nrow = desc_a%get_local_cols() - if (allocated(prec%d)) then - if (size(prec%d) < nrow) then - deallocate(prec%d,stat=info) - end if - end if - if ((info == psb_success_).and.(.not.allocated(prec%d))) then - allocate(prec%d(nrow), stat=info) - end if - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - call a%get_diag(prec%d,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='get_diag') - goto 9999 - end if - - do i=1,nrow - if (prec%d(i) == dzero) then - prec%d(i) = done - else - prec%d(i) = done/prec%d(i) - endif - end do - allocate(prec%dv,stat=info) - if (info == 0) then - if (present(vmold)) then - allocate(prec%dv%v,mold=vmold,stat=info) - else - allocate(psb_c_base_vect_type :: prec%dv%v,stat=info) - end if - end if - if (info == 0) then - call prec%dv%bld(prec%d) - else - write(0,*) 'Error on precbld ',info - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_c_diag_precbld - subroutine psb_c_diag_precseti(prec,what,val,info) - - use psb_base_mod Implicit None class(psb_c_diag_prec_type),intent(inout) :: prec @@ -337,7 +127,6 @@ contains subroutine psb_c_diag_precsetr(prec,what,val,info) - use psb_base_mod Implicit None class(psb_c_diag_prec_type),intent(inout) :: prec @@ -364,8 +153,6 @@ contains end subroutine psb_c_diag_precsetr subroutine psb_c_diag_precsetc(prec,what,val,info) - - use psb_base_mod Implicit None class(psb_c_diag_prec_type),intent(inout) :: prec @@ -393,7 +180,6 @@ contains subroutine psb_c_diag_precfree(prec,info) - use psb_base_mod Implicit None class(psb_c_diag_prec_type), intent(inout) :: prec @@ -423,8 +209,6 @@ contains subroutine psb_c_diag_precdescr(prec,iout) - - use psb_base_mod Implicit None class(psb_c_diag_prec_type), intent(in) :: prec @@ -465,17 +249,14 @@ contains end subroutine psb_c_diag_precdescr function psb_c_diag_sizeof(prec) result(val) - use psb_base_mod, only : psb_long_int_k_ class(psb_c_diag_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: val - val = 0 - val = val + 2*psb_sizeof_sp * size(prec%d) + val = (2*psb_sizeof_sp) * prec%get_nzeros() return end function psb_c_diag_sizeof function psb_c_diag_get_nzeros(prec) result(val) - use psb_base_mod, only: psb_long_int_k_ class(psb_c_diag_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: val diff --git a/prec/psb_c_nullprec.f90 b/prec/psb_c_nullprec.f90 index bce35858..0aeefff8 100644 --- a/prec/psb_c_nullprec.f90 +++ b/prec/psb_c_nullprec.f90 @@ -16,122 +16,46 @@ module psb_c_nullprec procedure, pass(prec) :: sizeof => psb_c_null_sizeof end type psb_c_null_prec_type - private :: psb_c_null_apply, psb_c_null_precbld, psb_c_null_precseti,& + private :: psb_c_null_precbld, psb_c_null_precseti,& & psb_c_null_precsetr, psb_c_null_precsetc, psb_c_null_sizeof,& - & psb_c_null_precinit, psb_c_null_precfree, psb_c_null_precdescr, & - & psb_c_null_apply_vect + & psb_c_null_precinit, psb_c_null_precfree, psb_c_null_precdescr + + + interface psb_c_null_apply_vect + subroutine psb_c_null_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_c_null_prec_type, psb_c_vect_type, psb_spk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_c_null_prec_type), intent(inout) :: prec + type(psb_c_vect_type),intent(inout) :: x + complex(psb_spk_),intent(in) :: alpha, beta + type(psb_c_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + + end subroutine psb_c_null_apply_vect + end interface psb_c_null_apply_vect + + interface psb_c_null_apply + subroutine psb_c_null_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_c_null_prec_type, psb_spk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_c_null_prec_type), intent(in) :: prec + complex(psb_spk_),intent(inout) :: x(:) + complex(psb_spk_),intent(in) :: alpha, beta + complex(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + end subroutine psb_c_null_apply + end interface psb_c_null_apply + contains - subroutine psb_c_null_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_c_null_prec_type), intent(inout) :: prec - type(psb_c_vect_type),intent(inout) :: x - complex(psb_spk_),intent(in) :: alpha, beta - type(psb_c_vect_type),intent(inout) :: y - integer, intent(out) :: info - character(len=1), optional :: trans - complex(psb_spk_),intent(inout), optional, target :: work(:) - Integer :: err_act, nrow - character(len=20) :: name='c_null_prec_apply' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preonditioner??? - ! - info = psb_success_ - - nrow = desc_data%get_local_rows() - if (x%get_nrows() < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) - goto 9999 - end if - if (y%get_nrows() < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) - goto 9999 - end if - - call psb_geaxpby(alpha,x,beta,y,desc_data,info) - if (info /= psb_success_ ) then - info = psb_err_from_subroutine_ - call psb_errpush(infoi,name,a_err="psb_geaxpby") - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psb_c_null_apply_vect - - subroutine psb_c_null_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_c_null_prec_type), intent(in) :: prec - complex(psb_spk_),intent(inout) :: x(:) - complex(psb_spk_),intent(in) :: alpha, beta - complex(psb_spk_),intent(inout) :: y(:) - integer, intent(out) :: info - character(len=1), optional :: trans - complex(psb_spk_),intent(inout), optional, target :: work(:) - Integer :: err_act, nrow - character(len=20) :: name='c_null_prec_apply' - - call psb_erractionsave(err_act) - - ! - ! - info = psb_success_ - - nrow = desc_data%get_local_rows() - if (size(x) < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) - goto 9999 - end if - if (size(y) < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) - goto 9999 - end if - - call psb_geaxpby(alpha,x,beta,y,desc_data,info) - if (info /= psb_success_ ) then - info = psb_err_from_subroutine_ - call psb_errpush(infoi,name,a_err="psb_geaxpby") - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psb_c_null_apply - - subroutine psb_c_null_precinit(prec,info) - use psb_base_mod Implicit None class(psb_c_null_prec_type),intent(inout) :: prec @@ -158,7 +82,6 @@ contains subroutine psb_c_null_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - use psb_base_mod Implicit None type(psb_cspmat_type), intent(in), target :: a @@ -191,7 +114,6 @@ contains subroutine psb_c_null_precseti(prec,what,val,info) - use psb_base_mod Implicit None class(psb_c_null_prec_type),intent(inout) :: prec @@ -219,7 +141,6 @@ contains subroutine psb_c_null_precsetr(prec,what,val,info) - use psb_base_mod Implicit None class(psb_c_null_prec_type),intent(inout) :: prec @@ -247,7 +168,6 @@ contains subroutine psb_c_null_precsetc(prec,what,val,info) - use psb_base_mod Implicit None class(psb_c_null_prec_type),intent(inout) :: prec @@ -275,7 +195,6 @@ contains subroutine psb_c_null_precfree(prec,info) - use psb_base_mod Implicit None class(psb_c_null_prec_type), intent(inout) :: prec @@ -304,7 +223,6 @@ contains subroutine psb_c_null_precdescr(prec,iout) - use psb_base_mod Implicit None class(psb_c_null_prec_type), intent(in) :: prec @@ -340,7 +258,7 @@ contains end subroutine psb_c_null_precdescr function psb_c_null_sizeof(prec) result(val) - use psb_base_mod + class(psb_c_null_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: val diff --git a/prec/psb_d_base_prec_mod.f90 b/prec/psb_d_base_prec_mod.f90 index 1957216b..d36759dd 100644 --- a/prec/psb_d_base_prec_mod.f90 +++ b/prec/psb_d_base_prec_mod.f90 @@ -38,7 +38,7 @@ module psb_d_base_prec_mod ! Reduces size of .mod file. use psb_base_mod, only : psb_dpk_, psb_long_int_k_,& & psb_desc_type, psb_sizeof, psb_free, psb_cdfree, psb_errpush, psb_act_abort_,& - & psb_erractionsave, psb_erractionrestore, psb_error, psb_get_errstatus,& + & psb_erractionsave, psb_erractionrestore, psb_error, psb_get_errstatus, psb_success_,& & psb_d_base_sparse_mat, psb_dspmat_type, psb_d_csr_sparse_mat,& & psb_d_base_vect_type, psb_d_vect_type diff --git a/prec/psb_d_bjacprec.f90 b/prec/psb_d_bjacprec.f90 index 1a14c8f6..2de60b24 100644 --- a/prec/psb_d_bjacprec.f90 +++ b/prec/psb_d_bjacprec.f90 @@ -1,11 +1,12 @@ module psb_d_bjacprec + use psb_d_base_prec_mod - type, extends(psb_d_base_prec_type) :: psb_d_bjac_prec_type - integer, allocatable :: iprcparm(:) - type(psb_dspmat_type), allocatable :: av(:) - real(psb_dpk_), allocatable :: d(:) - type(psb_d_vect_type), allocatable :: dv + type, extends(psb_d_base_prec_type) :: psb_d_bjac_prec_type + integer, allocatable :: iprcparm(:) + type(psb_dspmat_type), allocatable :: av(:) + real(psb_dpk_), allocatable :: d(:) + type(psb_d_vect_type), allocatable :: dv contains procedure, pass(prec) :: d_apply_v => psb_d_bjac_apply_vect procedure, pass(prec) :: d_apply => psb_d_bjac_apply @@ -21,567 +22,195 @@ module psb_d_bjacprec procedure, pass(prec) :: get_nzeros => psb_d_bjac_get_nzeros end type psb_d_bjac_prec_type - private :: psb_d_bjac_apply, psb_d_bjac_precbld, psb_d_bjac_precseti,& - & psb_d_bjac_precsetr, psb_d_bjac_precsetc, psb_d_bjac_sizeof,& - & psb_d_bjac_precinit, psb_d_bjac_precfree, psb_d_bjac_precdescr,& - & psb_d_bjac_dump, psb_d_bjac_apply_vect, psb_d_bjac_get_nzeros - + private :: psb_d_bjac_sizeof, psb_d_bjac_precdescr, psb_d_bjac_get_nzeros + character(len=15), parameter, private :: & & fact_names(0:2)=(/'None ','ILU(n) ',& & 'ILU(eps) '/) -contains + interface psb_d_bjac_dump + subroutine psb_d_bjac_dump(prec,info,prefix,head) + import :: psb_desc_type, psb_d_bjac_prec_type, psb_d_vect_type, psb_dpk_ + class(psb_d_bjac_prec_type), intent(in) :: prec + integer, intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + end subroutine psb_d_bjac_dump + end interface psb_d_bjac_dump + + interface psb_d_bjac_apply_vect + subroutine psb_d_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_d_bjac_prec_type, psb_d_vect_type, psb_dpk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_d_bjac_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, intent(out) :: info + character(len=1), optional :: trans + real(psb_dpk_),intent(inout), optional, target :: work(:) + end subroutine psb_d_bjac_apply_vect + end interface psb_d_bjac_apply_vect + + interface psb_d_bjac_apply + subroutine psb_d_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_d_bjac_prec_type, psb_d_vect_type, psb_dpk_ + + type(psb_desc_type),intent(in) :: desc_data + class(psb_d_bjac_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, intent(out) :: info + character(len=1), optional :: trans + real(psb_dpk_),intent(inout), optional, target :: work(:) + end subroutine psb_d_bjac_apply + end interface psb_d_bjac_apply + + interface psb_d_bjac_precinit + subroutine psb_d_bjac_precinit(prec,info) + import :: psb_desc_type, psb_d_bjac_prec_type, psb_d_vect_type, psb_dpk_ + class(psb_d_bjac_prec_type),intent(inout) :: prec + integer, intent(out) :: info + end subroutine psb_d_bjac_precinit + end interface psb_d_bjac_precinit + + interface psb_d_bjac_precbld + subroutine psb_d_bjac_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) + import :: psb_desc_type, psb_d_bjac_prec_type, psb_d_vect_type, psb_dpk_, & + & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type + type(psb_dspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_d_bjac_prec_type),intent(inout) :: prec + integer, 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_bjac_precbld + end interface psb_d_bjac_precbld + + interface psb_d_bjac_precseti + subroutine psb_d_bjac_precseti(prec,what,val,info) + import :: psb_desc_type, psb_d_bjac_prec_type, psb_d_vect_type, psb_dpk_ + class(psb_d_bjac_prec_type),intent(inout) :: prec + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + end subroutine psb_d_bjac_precseti + end interface psb_d_bjac_precseti + +!!$ interface psb_d_bjac_precsetr +!!$ subroutine psb_d_bjac_precsetr(prec,what,val,info) +!!$ import :: psb_desc_type, psb_d_bjac_prec_type, psb_d_vect_type, psb_dpk_ +!!$ class(psb_d_bjac_prec_type),intent(inout) :: prec +!!$ integer, intent(in) :: what +!!$ real(psb_dpk_), intent(in) :: val +!!$ integer, intent(out) :: info +!!$ end subroutine psb_d_bjac_precsetr +!!$ end interface psb_d_bjac_precsetr +!!$ +!!$ interface psb_d_bjac_precsetc +!!$ subroutine psb_d_bjac_precsetc(prec,what,val,info) +!!$ import :: psb_desc_type, psb_d_bjac_prec_type, psb_d_vect_type, psb_dpk_ +!!$ class(psb_d_bjac_prec_type),intent(inout) :: prec +!!$ integer, intent(in) :: what +!!$ character(len=*), intent(in) :: val +!!$ integer, intent(out) :: info +!!$ end subroutine psb_d_bjac_precsetc +!!$ end interface psb_d_bjac_precsetc +!!$ +!!$ interface psb_d_bjac_precfree +!!$ subroutine psb_d_bjac_precfree(prec,info) +!!$ import :: psb_desc_type, psb_d_bjac_prec_type, psb_d_vect_type, psb_dpk_ +!!$ class(psb_d_bjac_prec_type), intent(inout) :: prec +!!$ integer, intent(out) :: info +!!$ end subroutine psb_d_bjac_precfree +!!$ end interface psb_d_bjac_precfree - subroutine psb_d_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_d_bjac_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, intent(out) :: info - character(len=1), optional :: trans - real(psb_dpk_),intent(inout), optional, target :: work(:) - - ! Local variables - integer :: n_row,n_col - real(psb_dpk_), pointer :: ww(:), aux(:) - type(psb_d_vect_type) :: wv - integer :: ictxt,np,me, err_act, int_err(5) - integer :: debug_level, debug_unit - character :: trans_ - character(len=20) :: name='d_bjac_prec_apply' - character(len=20) :: ch_err - - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) - - - trans_ = psb_toupper(trans) - select case(trans_) - case('N','T','C') - ! Ok - case default - call psb_errpush(psb_err_iarg_invalid_i_,name) - goto 9999 - end select - - - n_row = desc_data%get_local_rows() - n_col = desc_data%get_local_cols() - - if (x%get_nrows() < n_row) then - info = 36 - call psb_errpush(info,name,i_err=(/2,n_row,0,0,0/)) - goto 9999 - end if - if (y%get_nrows() < n_row) then - info = 36 - call psb_errpush(info,name,i_err=(/3,n_row,0,0,0/)) - goto 9999 - end if - if (.not.allocated(prec%d)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - if (size(prec%d) < n_row) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - - - if (n_col <= size(work)) then - ww => work(1:n_col) - if ((4*n_col+n_col) <= size(work)) then - aux => work(n_col+1:) - else - allocate(aux(4*n_col),stat=info) - - endif - else - allocate(ww(n_col),aux(4*n_col),stat=info) - endif - if (info == psb_success_) allocate(wv%v,mold=x%v) +contains - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - call wv%bld(n_col,mold=x%v) - - select case(prec%iprcparm(psb_f_type_)) - case(psb_f_ilu_n_) - - select case(trans_) - case('N') - call psb_spsm(done,prec%av(psb_l_pr_),x,dzero,wv,desc_data,info,& - & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_,work=aux) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),wv,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_, work=aux) - - case('T') - call psb_spsm(done,prec%av(psb_u_pr_),x,dzero,wv,desc_data,info,& - & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_, work=aux) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) - - case('C') - call psb_spsm(done,prec%av(psb_u_pr_),x,dzero,wv,desc_data,info,& - & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_, work=aux) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) - - end select - if (info /= psb_success_) then - ch_err="psb_spsm" - goto 9999 - end if - - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Invalid factorization') - goto 9999 - end select - - call psb_halo(y,desc_data,info,data=psb_comm_mov_) - - call wv%free(info) - if (n_col <= size(work)) then - if ((4*n_col+n_col) <= size(work)) then - else - deallocate(aux) - endif - else - deallocate(ww,aux) - endif - - - call psb_erractionrestore(err_act) - return + subroutine psb_d_bjac_precdescr(prec,iout) -9999 continue - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return + Implicit None + class(psb_d_bjac_prec_type), intent(in) :: prec + integer, intent(in), optional :: iout - end subroutine psb_d_bjac_apply_vect - - subroutine psb_d_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_d_bjac_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, intent(out) :: info - character(len=1), optional :: trans - real(psb_dpk_),intent(inout), optional, target :: work(:) - - ! Local variables - integer :: n_row,n_col - real(psb_dpk_), pointer :: ww(:), aux(:) - integer :: ictxt,np,me, err_act, int_err(5) - integer :: debug_level, debug_unit - character :: trans_ - character(len=20) :: name='d_bjac_prec_apply' - character(len=20) :: ch_err + Integer :: err_act, nrow, info + character(len=20) :: name='d_bjac_precdescr' + integer :: iout_ - info = psb_success_ call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) - - - trans_ = psb_toupper(trans) - select case(trans_) - case('N','T','C') - ! Ok - case default - call psb_errpush(psb_err_iarg_invalid_i_,name) - goto 9999 - end select - - - n_row = desc_data%get_local_rows() - n_col = desc_data%get_local_cols() - if (size(x) < n_row) then - info = 36 - call psb_errpush(info,name,i_err=(/2,n_row,0,0,0/)) - goto 9999 - end if - if (size(y) < n_row) then - info = 36 - call psb_errpush(info,name,i_err=(/3,n_row,0,0,0/)) - goto 9999 + info = psb_success_ + + if (present(iout)) then + iout_ = iout + else + iout_ = 6 end if -!!$ if (.not.allocated(prec%d)) then -!!$ info = 1124 -!!$ call psb_errpush(info,name,a_err="preconditioner: D") -!!$ goto 9999 -!!$ end if -!!$ if (size(prec%d) < n_row) then -!!$ info = 1124 -!!$ call psb_errpush(info,name,a_err="preconditioner: D") -!!$ goto 9999 -!!$ end if - - if (n_col <= size(work)) then - ww => work(1:n_col) - if ((4*n_col+n_col) <= size(work)) then - aux => work(n_col+1:) - else - allocate(aux(4*n_col),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - - endif - else - allocate(ww(n_col),aux(4*n_col),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - endif - - - select case(prec%iprcparm(psb_f_type_)) - case(psb_f_ilu_n_) - - select case(trans_) - case('N') - call psb_spsm(done,prec%av(psb_l_pr_),x,dzero,ww,desc_data,info,& - & trans=trans_,scale='L',diag=prec%dv%v%v,choice=psb_none_,work=aux) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),ww,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_, work=aux) - - case('T','C') - call psb_spsm(done,prec%av(psb_u_pr_),x,dzero,ww,desc_data,info,& - & trans=trans_,scale='L',diag=prec%dv%v%v,choice=psb_none_, work=aux) - if (info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) - - end select - if (info /= psb_success_) then - ch_err="psb_spsm" - goto 9999 - end if - - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Invalid factorization') + if (.not.allocated(prec%iprcparm)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") goto 9999 - end select - - call psb_halo(y,desc_data,info,data=psb_comm_mov_) - - if (n_col <= size(work)) then - if ((4*n_col+n_col) <= size(work)) then - else - deallocate(aux) - endif - else - deallocate(ww,aux) - endif + end if + write(iout_,*) 'Block Jacobi with: ',& + & fact_names(prec%iprcparm(psb_f_type_)) call psb_erractionrestore(err_act) return - + 9999 continue - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then call psb_error() return end if return - - - end subroutine psb_d_bjac_apply - - subroutine psb_d_bjac_precinit(prec,info) - - use psb_base_mod - Implicit None - class(psb_d_bjac_prec_type),intent(inout) :: prec - integer, intent(out) :: info - Integer :: err_act, nrow - character(len=20) :: name='d_null_precinit' + end subroutine psb_d_bjac_precdescr - call psb_erractionsave(err_act) - info = psb_success_ - call psb_realloc(psb_ifpsz,prec%iprcparm,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_Errpush(info,name) - goto 9999 - end if + function psb_d_bjac_sizeof(prec) result(val) + class(psb_d_bjac_prec_type), intent(in) :: prec + integer(psb_long_int_k_) :: val - prec%iprcparm(:) = 0 - prec%iprcparm(psb_p_type_) = psb_bjac_ - prec%iprcparm(psb_f_type_) = psb_f_ilu_n_ - prec%iprcparm(psb_ilu_fill_in_) = 0 - - - 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 + val = 0 + if (allocated(prec%dv)) then + val = val + psb_sizeof_dp * prec%dv%get_nrows() + endif + if (allocated(prec%av)) then + val = val + prec%av(psb_l_pr_)%sizeof() + val = val + prec%av(psb_u_pr_)%sizeof() + endif return - end subroutine psb_d_bjac_precinit - - - subroutine psb_d_bjac_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - - use psb_base_mod - use psb_prec_mod, only : psb_ilu_fct - Implicit None - - type(psb_dspmat_type), intent(in), target :: a - type(psb_desc_type), intent(in), target :: desc_a - class(psb_d_bjac_prec_type),intent(inout) :: prec - integer, 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 - - ! .. Local Scalars .. - integer :: i, m - integer :: int_err(5) - character :: trans, unitd - type(psb_d_csr_sparse_mat), allocatable :: lf, uf - real(psb_dpk_), allocatable :: dd(:) - integer nztota, err_act, n_row, nrow_a,n_col, nhalo - integer :: ictxt,np,me - character(len=20) :: name='d_bjac_precbld' - character(len=20) :: ch_err - - - if(psb_get_errstatus() /= 0) return - info = psb_success_ - - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + end function psb_d_bjac_sizeof - call prec%set_ctxt(ictxt) + function psb_d_bjac_get_nzeros(prec) result(val) - m = a%get_nrows() - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,i_err=int_err) - goto 9999 + class(psb_d_bjac_prec_type), intent(in) :: prec + integer(psb_long_int_k_) :: val + + val = 0 + if (allocated(prec%dv)) then + val = val + prec%dv%get_nrows() + endif + if (allocated(prec%av)) then + val = val + prec%av(psb_l_pr_)%get_nzeros() + val = val + prec%av(psb_u_pr_)%get_nzeros() endif - trans = 'N' - unitd = 'U' - - select case(prec%iprcparm(psb_f_type_)) - - case(psb_f_ilu_n_) - - if (allocated(prec%av)) then - if (size(prec%av) < psb_bp_ilu_avsz) then - do i=1,size(prec%av) - call prec%av(i)%free() - enddo - deallocate(prec%av,stat=info) - endif - end if - if (.not.allocated(prec%av)) then - allocate(prec%av(psb_max_avsz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - endif - - nrow_a = desc_a%get_local_rows() - nztota = a%get_nzeros() - - n_col = desc_a%get_local_cols() - nhalo = n_col-nrow_a - n_row = nrow_a - - allocate(lf,uf,stat=info) - if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) - if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) - - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - allocate(dd(n_row),stat=info) - if (info == psb_success_) then - allocate(prec%dv, stat=info) - if (info == 0) then - if (present(vmold)) then - allocate(prec%dv%v,mold=vmold,stat=info) - else - allocate(psb_d_base_vect_type :: prec%dv%v,stat=info) - end if - end if - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - endif - ! This is where we have no renumbering, thus no need - call psb_ilu_fct(a,lf,uf,dd,info) - - if(info == psb_success_) then - call prec%av(psb_l_pr_)%mv_from(lf) - call prec%av(psb_u_pr_)%mv_from(uf) - call prec%av(psb_l_pr_)%set_asb() - call prec%av(psb_u_pr_)%set_asb() - call prec%av(psb_l_pr_)%trim() - call prec%av(psb_u_pr_)%trim() - call prec%dv%bld(dd) - call move_alloc(dd,prec%d) - else - info=psb_err_from_subroutine_ - ch_err='psb_ilu_fct' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case(psb_f_none_) - info=psb_err_from_subroutine_ - ch_err='Inconsistent prec psb_f_none_' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - - case default - info=psb_err_from_subroutine_ - ch_err='Unknown psb_f_type_' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - - if (present(amold)) then - call prec%av(psb_l_pr_)%cscnv(info,mold=amold) - call prec%av(psb_u_pr_)%cscnv(info,mold=amold) - else if (present(afmt)) then - call prec%av(psb_l_pr_)%cscnv(info,type=afmt) - call prec%av(psb_u_pr_)%cscnv(info,type=afmt) - end if - - call psb_erractionrestore(err_act) return + end function psb_d_bjac_get_nzeros -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_bjac_precbld + subroutine psb_d_bjac_precsetr(prec,what,val,info) - subroutine psb_d_bjac_precseti(prec,what,val,info) - - use psb_base_mod Implicit None - - class(psb_d_bjac_prec_type),intent(inout) :: prec - integer, intent(in) :: what - integer, intent(in) :: val - integer, intent(out) :: info - Integer :: err_act, nrow - character(len=20) :: name='d_bjac_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - if (.not.allocated(prec%iprcparm)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - - select case(what) - case (psb_f_type_) - if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then - write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& - & prec%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif - prec%iprcparm(psb_f_type_) = val - - case (psb_ilu_fill_in_) - if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.& - & (prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then - write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& - & prec%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif - prec%iprcparm(psb_ilu_fill_in_) = val - - case default - write(psb_err_unit,*) 'WHAT is invalid, ignoring user specification' - - end select - - 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_bjac_precseti - subroutine psb_d_bjac_precsetr(prec,what,val,info) - - use psb_base_mod - Implicit None - class(psb_d_bjac_prec_type),intent(inout) :: prec integer, intent(in) :: what real(psb_dpk_), intent(in) :: val @@ -592,7 +221,7 @@ contains call psb_erractionsave(err_act) info = psb_success_ - + call psb_erractionrestore(err_act) return @@ -606,10 +235,9 @@ contains end subroutine psb_d_bjac_precsetr subroutine psb_d_bjac_precsetc(prec,what,val,info) - - use psb_base_mod + Implicit None - + class(psb_d_bjac_prec_type),intent(inout) :: prec integer, intent(in) :: what character(len=*), intent(in) :: val @@ -620,7 +248,7 @@ contains call psb_erractionsave(err_act) info = psb_success_ - + call psb_erractionrestore(err_act) return @@ -634,18 +262,17 @@ contains end subroutine psb_d_bjac_precsetc subroutine psb_d_bjac_precfree(prec,info) - - use psb_base_mod + Implicit None class(psb_d_bjac_prec_type), intent(inout) :: prec integer, intent(out) :: info - + Integer :: err_act, i character(len=20) :: name='d_bjac_precfree' - + call psb_erractionsave(err_act) - + info = psb_success_ if (allocated(prec%av)) then do i=1,size(prec%av) @@ -670,128 +297,7 @@ contains return end if return - - end subroutine psb_d_bjac_precfree - - - subroutine psb_d_bjac_precdescr(prec,iout) - - use psb_base_mod - Implicit None - - class(psb_d_bjac_prec_type), intent(in) :: prec - integer, intent(in), optional :: iout - - Integer :: err_act, nrow, info - character(len=20) :: name='d_bjac_precdescr' - integer :: iout_ - - call psb_erractionsave(err_act) - - info = psb_success_ - - if (present(iout)) then - iout_ = iout - else - iout_ = 6 - end if - - if (.not.allocated(prec%iprcparm)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - - write(iout_,*) 'Block Jacobi with: ',& - & fact_names(prec%iprcparm(psb_f_type_)) - - 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_bjac_precdescr - - - subroutine psb_d_bjac_dump(prec,info,prefix,head) - use psb_base_mod - implicit none - class(psb_d_bjac_prec_type), intent(in) :: prec - integer, intent(out) :: info - character(len=*), intent(in), optional :: prefix,head - integer :: i, j, il1, iln, lname, lev - integer :: 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_fact_d" - end if - - lname = len_trim(prefix_) - fname = trim(prefix_) - write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam - lname = lname + 5 - write(fname(lname+1:),'(a)')'_lower.mtx' - if (prec%av(psb_l_pr_)%is_asb()) & - & call prec%av(psb_l_pr_)%print(fname,head=head) - write(fname(lname+1:),'(a,a)')'_diag.mtx' - if (allocated(prec%d)) & - & call psb_geprt(fname,prec%d,head=head) - write(fname(lname+1:),'(a)')'_upper.mtx' - if (prec%av(psb_u_pr_)%is_asb()) & - & call prec%av(psb_u_pr_)%print(fname,head=head) - - end subroutine psb_d_bjac_dump - - function psb_d_bjac_sizeof(prec) result(val) - use psb_base_mod, only : psb_long_int_k_ - class(psb_d_bjac_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val - - val = 0 - if (allocated(prec%d)) then - val = val + psb_sizeof_dp * size(prec%d) - endif - if (allocated(prec%av)) then - val = val + psb_sizeof(prec%av(psb_l_pr_)) - val = val + psb_sizeof(prec%av(psb_u_pr_)) - endif - return - end function psb_d_bjac_sizeof - function psb_d_bjac_get_nzeros(prec) result(val) - use psb_base_mod, only : psb_long_int_k_ - class(psb_d_bjac_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val - - val = 0 - if (allocated(prec%dv)) then - val = val + prec%dv%get_nrows() - endif - if (allocated(prec%av)) then - val = val + prec%av(psb_l_pr_)%get_nzeros() - val = val + prec%av(psb_u_pr_)%get_nzeros() - endif - return - end function psb_d_bjac_get_nzeros + end subroutine psb_d_bjac_precfree end module psb_d_bjacprec diff --git a/prec/psb_d_diagprec.f90 b/prec/psb_d_diagprec.f90 index 30158ce1..b163f6b2 100644 --- a/prec/psb_d_diagprec.f90 +++ b/prec/psb_d_diagprec.f90 @@ -2,9 +2,8 @@ module psb_d_diagprec use psb_d_base_prec_mod - type, extends(psb_d_base_prec_type) :: psb_d_diag_prec_type - real(psb_dpk_), allocatable :: d(:) + real(psb_dpk_), allocatable :: d(:) type(psb_d_vect_type), allocatable :: dv contains procedure, pass(prec) :: d_apply_v => psb_d_diag_apply_vect @@ -20,196 +19,61 @@ module psb_d_diagprec procedure, pass(prec) :: get_nzeros => psb_d_diag_get_nzeros end type psb_d_diag_prec_type - private :: psb_d_diag_apply, psb_d_diag_precbld, psb_d_diag_precseti,& + private :: psb_d_diag_precseti,& & psb_d_diag_precsetr, psb_d_diag_precsetc, psb_d_diag_sizeof,& & psb_d_diag_precinit, psb_d_diag_precfree, psb_d_diag_precdescr,& - & psb_d_diag_apply_vect, psb_d_diag_get_nzeros + & psb_d_diag_get_nzeros + + + + interface psb_d_diag_apply_vect + subroutine psb_d_diag_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_d_diag_prec_type, psb_d_vect_type, psb_dpk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_d_diag_prec_type), intent(inout) :: prec + type(psb_d_vect_type),intent(inout) :: x + real(psb_dpk_),intent(in) :: alpha, beta + type(psb_d_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_dpk_),intent(inout), optional, target :: work(:) + end subroutine psb_d_diag_apply_vect + end interface psb_d_diag_apply_vect + + interface psb_d_diag_apply + subroutine psb_d_diag_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_d_diag_prec_type, psb_d_vect_type, psb_dpk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_d_diag_prec_type), intent(in) :: prec + real(psb_dpk_),intent(inout) :: x(:) + real(psb_dpk_),intent(in) :: alpha, beta + real(psb_dpk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_dpk_),intent(inout), optional, target :: work(:) + end subroutine psb_d_diag_apply + end interface psb_d_diag_apply + + interface psb_d_diag_precbld + subroutine psb_d_diag_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) + import :: psb_desc_type, psb_d_diag_prec_type, psb_d_vect_type, psb_dpk_, & + & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type + type(psb_dspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_d_diag_prec_type),intent(inout) :: prec + integer, 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_diag_precbld + end interface psb_d_diag_precbld contains - subroutine psb_d_diag_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_d_diag_prec_type), intent(inout) :: prec - type(psb_d_vect_type),intent(inout) :: x - real(psb_dpk_),intent(in) :: alpha, beta - type(psb_d_vect_type),intent(inout) :: y - integer, intent(out) :: info - character(len=1), optional :: trans - real(psb_dpk_),intent(inout), optional, target :: work(:) - Integer :: err_act, nrow - character(len=20) :: name='d_diag_prec_apply' - real(psb_dpk_), pointer :: ww(:) - class(psb_d_base_vect_type), allocatable :: dw - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the DIAG preonditioner??? - ! - info = psb_success_ - - nrow = desc_data%get_local_rows() - if (x%get_nrows() < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) - goto 9999 - end if - if (y%get_nrows() < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) - goto 9999 - end if - if (.not.allocated(prec%d)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - if (size(prec%d) < nrow) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - - if (size(work) >= x%get_nrows()) then - ww => work - else - allocate(ww(x%get_nrows()),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,& - & i_err=(/x%get_nrows(),0,0,0,0/),a_err='real(psb_dpk_)') - goto 9999 - end if - end if - -!!$ allocate(dw, mold=x, stat=info) -!!$ call dw%bld(x%get_nrows()) -!!$ if (.true.) then -!!$ if (info == 0) call dw%mlt(prec%dv,x,info) -!!$ else -!!$ if (info == 0) call dw%axpby(nrow,done,x,dzero,info) -!!$ if (info == 0) call dw%mlt(prec%dv,info) -!!$ end if -!!$ if (info == 0) call y%axpby(nrow,alpha,dw,beta,info) - - call y%mlt(alpha,prec%dv,x,beta,info) - -!!$ call x%mlt(ww,prec%d(1:nrow),info) -!!$ if (info == 0) call psb_geaxpby(alpha,ww,beta,y,desc_data,info) - -!!$ call dw%free(info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') -!!$ goto 9999 -!!$ end if - - if (size(work) < x%get_nrows()) then - deallocate(ww,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') - goto 9999 - end if - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psb_d_diag_apply_vect - - - subroutine psb_d_diag_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_d_diag_prec_type), intent(in) :: prec - real(psb_dpk_),intent(inout) :: x(:) - real(psb_dpk_),intent(in) :: alpha, beta - real(psb_dpk_),intent(inout) :: y(:) - integer, intent(out) :: info - character(len=1), optional :: trans - real(psb_dpk_),intent(inout), optional, target :: work(:) - Integer :: err_act, nrow - character(len=20) :: name='d_diag_prec_apply' - real(psb_dpk_), pointer :: ww(:) - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the DIAG preonditioner??? - ! - info = psb_success_ - - nrow = desc_data%get_local_rows() - if (size(x) < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) - goto 9999 - end if - if (size(y) < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) - goto 9999 - end if - if (.not.allocated(prec%d)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - if (size(prec%d) < nrow) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - - if (size(work) >= size(x)) then - ww => work - else - allocate(ww(size(x)),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,& - & i_err=(/size(x),0,0,0,0/),a_err='real(psb_dpk_)') - goto 9999 - end if - end if - - ww(1:nrow) = x(1:nrow)*prec%d(1:nrow) - call psb_geaxpby(alpha,ww,beta,y,desc_data,info) - - if (size(work) < size(x)) then - deallocate(ww,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') - goto 9999 - end if - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psb_d_diag_apply - subroutine psb_d_diag_precinit(prec,info) - - use psb_base_mod Implicit None class(psb_d_diag_prec_type),intent(inout) :: prec @@ -235,83 +99,7 @@ contains end subroutine psb_d_diag_precinit - subroutine psb_d_diag_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - - use psb_base_mod - Implicit None - - type(psb_dspmat_type), intent(in), target :: a - type(psb_desc_type), intent(in), target :: desc_a - class(psb_d_diag_prec_type),intent(inout) :: prec - integer, 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 :: err_act, nrow,i - character(len=20) :: name='d_diag_precbld' - - call psb_erractionsave(err_act) - - info = psb_success_ - nrow = desc_a%get_local_cols() - if (allocated(prec%d)) then - if (size(prec%d) < nrow) then - deallocate(prec%d,stat=info) - end if - end if - if ((info == psb_success_).and.(.not.allocated(prec%d))) then - allocate(prec%d(nrow), stat=info) - end if - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - call a%get_diag(prec%d,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='get_diag') - goto 9999 - end if - - do i=1,nrow - if (prec%d(i) == dzero) then - prec%d(i) = done - else - prec%d(i) = done/prec%d(i) - endif - end do - allocate(prec%dv,stat=info) - if (info == 0) then - if (present(vmold)) then - allocate(prec%dv%v,mold=vmold,stat=info) - else - allocate(psb_d_base_vect_type :: prec%dv%v,stat=info) - end if - end if - if (info == 0) then - call prec%dv%bld(prec%d) - else - write(0,*) 'Error on precbld ',info - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_d_diag_precbld - subroutine psb_d_diag_precseti(prec,what,val,info) - - use psb_base_mod Implicit None class(psb_d_diag_prec_type),intent(inout) :: prec @@ -339,7 +127,6 @@ contains subroutine psb_d_diag_precsetr(prec,what,val,info) - use psb_base_mod Implicit None class(psb_d_diag_prec_type),intent(inout) :: prec @@ -366,8 +153,6 @@ contains end subroutine psb_d_diag_precsetr subroutine psb_d_diag_precsetc(prec,what,val,info) - - use psb_base_mod Implicit None class(psb_d_diag_prec_type),intent(inout) :: prec @@ -395,7 +180,6 @@ contains subroutine psb_d_diag_precfree(prec,info) - use psb_base_mod Implicit None class(psb_d_diag_prec_type), intent(inout) :: prec @@ -407,6 +191,8 @@ contains call psb_erractionsave(err_act) info = psb_success_ + + if (allocated(prec%dv)) call prec%dv%free(info) call psb_erractionrestore(err_act) return @@ -423,8 +209,6 @@ contains subroutine psb_d_diag_precdescr(prec,iout) - - use psb_base_mod Implicit None class(psb_d_diag_prec_type), intent(in) :: prec @@ -465,23 +249,21 @@ contains end subroutine psb_d_diag_precdescr function psb_d_diag_sizeof(prec) result(val) - use psb_base_mod, only: psb_long_int_k_ class(psb_d_diag_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: val - val = 0 - val = val + psb_sizeof_dp * size(prec%d) + val = psb_sizeof_dp * prec%get_nzeros() return end function psb_d_diag_sizeof function psb_d_diag_get_nzeros(prec) result(val) - use psb_base_mod, only: psb_long_int_k_ class(psb_d_diag_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: val - + val = 0 if (allocated(prec%dv)) val = val + prec%dv%get_nrows() return end function psb_d_diag_get_nzeros + end module psb_d_diagprec diff --git a/prec/psb_d_nullprec.f90 b/prec/psb_d_nullprec.f90 index dca62adc..dcf743c9 100644 --- a/prec/psb_d_nullprec.f90 +++ b/prec/psb_d_nullprec.f90 @@ -4,8 +4,8 @@ module psb_d_nullprec type, extends(psb_d_base_prec_type) :: psb_d_null_prec_type contains - procedure, pass(prec) :: d_apply_v => psb_d_null_apply_vect - procedure, pass(prec) :: d_apply => psb_d_null_apply + procedure, pass(prec) :: c_apply_v => psb_d_null_apply_vect + procedure, pass(prec) :: c_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 @@ -16,124 +16,46 @@ module psb_d_nullprec procedure, pass(prec) :: sizeof => psb_d_null_sizeof end type psb_d_null_prec_type - private :: psb_d_null_apply, psb_d_null_precbld, psb_d_null_precseti,& + private :: psb_d_null_precbld, psb_d_null_precseti,& & psb_d_null_precsetr, psb_d_null_precsetc, psb_d_null_sizeof,& - & psb_d_null_precinit, psb_d_null_precfree, psb_d_null_precdescr, & - & psb_d_null_apply_vect + & psb_d_null_precinit, psb_d_null_precfree, psb_d_null_precdescr + + + interface psb_d_null_apply_vect + subroutine psb_d_null_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_d_null_prec_type, psb_d_vect_type, psb_dpk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_d_null_prec_type), intent(inout) :: prec + type(psb_d_vect_type),intent(inout) :: x + real(psb_dpk_),intent(in) :: alpha, beta + type(psb_d_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_dpk_),intent(inout), optional, target :: work(:) + + end subroutine psb_d_null_apply_vect + end interface psb_d_null_apply_vect + + interface psb_d_null_apply + subroutine psb_d_null_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_d_null_prec_type, psb_dpk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_d_null_prec_type), intent(in) :: prec + real(psb_dpk_),intent(inout) :: x(:) + real(psb_dpk_),intent(in) :: alpha, beta + real(psb_dpk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_dpk_),intent(inout), optional, target :: work(:) + end subroutine psb_d_null_apply + end interface psb_d_null_apply + contains - subroutine psb_d_null_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_d_null_prec_type), intent(inout) :: prec - type(psb_d_vect_type),intent(inout) :: x - real(psb_dpk_),intent(in) :: alpha, beta - type(psb_d_vect_type),intent(inout) :: y - integer, intent(out) :: info - character(len=1), optional :: trans - real(psb_dpk_),intent(inout), optional, target :: work(:) - Integer :: err_act, nrow - character(len=20) :: name='d_null_prec_apply' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preonditioner??? - ! - info = psb_success_ - - nrow = desc_data%get_local_rows() - if (x%get_nrows() < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) - goto 9999 - end if - if (y%get_nrows() < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) - goto 9999 - end if - - call psb_geaxpby(alpha,x,beta,y,desc_data,info) - if (info /= psb_success_ ) then - info = psb_err_from_subroutine_ - call psb_errpush(infoi,name,a_err="psb_geaxpby") - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psb_d_null_apply_vect - - subroutine psb_d_null_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_d_null_prec_type), intent(in) :: prec - real(psb_dpk_),intent(inout) :: x(:) - real(psb_dpk_),intent(in) :: alpha, beta - real(psb_dpk_),intent(inout) :: y(:) - integer, intent(out) :: info - character(len=1), optional :: trans - real(psb_dpk_),intent(inout), optional, target :: work(:) - Integer :: err_act, nrow - character(len=20) :: name='d_null_prec_apply' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preonditioner??? - ! - info = psb_success_ - - nrow = desc_data%get_local_rows() - if (size(x) < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) - goto 9999 - end if - if (size(y) < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) - goto 9999 - end if - - call psb_geaxpby(alpha,x,beta,y,desc_data,info) - if (info /= psb_success_ ) then - info = psb_err_from_subroutine_ - call psb_errpush(infoi,name,a_err="psb_geaxpby") - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psb_d_null_apply - - subroutine psb_d_null_precinit(prec,info) - use psb_base_mod Implicit None class(psb_d_null_prec_type),intent(inout) :: prec @@ -160,7 +82,6 @@ contains subroutine psb_d_null_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - use psb_base_mod Implicit None type(psb_dspmat_type), intent(in), target :: a @@ -193,7 +114,6 @@ contains subroutine psb_d_null_precseti(prec,what,val,info) - use psb_base_mod Implicit None class(psb_d_null_prec_type),intent(inout) :: prec @@ -221,7 +141,6 @@ contains subroutine psb_d_null_precsetr(prec,what,val,info) - use psb_base_mod Implicit None class(psb_d_null_prec_type),intent(inout) :: prec @@ -249,7 +168,6 @@ contains subroutine psb_d_null_precsetc(prec,what,val,info) - use psb_base_mod Implicit None class(psb_d_null_prec_type),intent(inout) :: prec @@ -277,7 +195,6 @@ contains subroutine psb_d_null_precfree(prec,info) - use psb_base_mod Implicit None class(psb_d_null_prec_type), intent(inout) :: prec @@ -306,7 +223,6 @@ contains subroutine psb_d_null_precdescr(prec,iout) - use psb_base_mod Implicit None class(psb_d_null_prec_type), intent(in) :: prec @@ -342,7 +258,7 @@ contains end subroutine psb_d_null_precdescr function psb_d_null_sizeof(prec) result(val) - use psb_base_mod + class(psb_d_null_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: val diff --git a/prec/psb_s_base_prec_mod.f90 b/prec/psb_s_base_prec_mod.f90 index 178ceccb..6e494d95 100644 --- a/prec/psb_s_base_prec_mod.f90 +++ b/prec/psb_s_base_prec_mod.f90 @@ -38,7 +38,7 @@ module psb_s_base_prec_mod ! Reduces size of .mod file. use psb_base_mod, only : psb_spk_, psb_long_int_k_,& & psb_desc_type, psb_sizeof, psb_free, psb_cdfree, psb_errpush, psb_act_abort_,& - & psb_erractionsave, psb_erractionrestore, psb_error, psb_get_errstatus,& + & psb_erractionsave, psb_erractionrestore, psb_error, psb_get_errstatus, psb_success_,& & psb_s_base_sparse_mat, psb_sspmat_type, psb_s_csr_sparse_mat,& & psb_s_base_vect_type, psb_s_vect_type diff --git a/prec/psb_s_bjacprec.f90 b/prec/psb_s_bjacprec.f90 index aee62bd5..8f8bcf7a 100644 --- a/prec/psb_s_bjacprec.f90 +++ b/prec/psb_s_bjacprec.f90 @@ -2,10 +2,10 @@ module psb_s_bjacprec use psb_s_base_prec_mod - type, extends(psb_s_base_prec_type) :: psb_s_bjac_prec_type + type, extends(psb_s_base_prec_type) :: psb_s_bjac_prec_type integer, allocatable :: iprcparm(:) type(psb_sspmat_type), allocatable :: av(:) - real(psb_spk_), allocatable :: d(:) + real(psb_spk_), allocatable :: d(:) type(psb_s_vect_type), allocatable :: dv contains procedure, pass(prec) :: s_apply_v => psb_s_bjac_apply_vect @@ -22,575 +22,195 @@ module psb_s_bjacprec procedure, pass(prec) :: get_nzeros => psb_s_bjac_get_nzeros end type psb_s_bjac_prec_type - private :: psb_s_bjac_apply, psb_s_bjac_precbld, psb_s_bjac_precseti,& - & psb_s_bjac_precsetr, psb_s_bjac_precsetc, psb_s_bjac_sizeof,& - & psb_s_bjac_precinit, psb_s_bjac_precfree, psb_s_bjac_precdescr,& - & psb_s_bjac_dump, psb_s_bjac_apply_vect, psb_s_bjac_get_nzeros + private :: psb_s_bjac_sizeof, psb_s_bjac_precdescr, psb_s_bjac_get_nzeros character(len=15), parameter, private :: & & fact_names(0:2)=(/'None ','ILU(n) ',& & 'ILU(eps) '/) -contains + interface psb_s_bjac_dump + subroutine psb_s_bjac_dump(prec,info,prefix,head) + import :: psb_desc_type, psb_s_bjac_prec_type, psb_s_vect_type, psb_spk_ + class(psb_s_bjac_prec_type), intent(in) :: prec + integer, intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + end subroutine psb_s_bjac_dump + end interface psb_s_bjac_dump + + interface psb_s_bjac_apply_vect + subroutine psb_s_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_s_bjac_prec_type, psb_s_vect_type, psb_spk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_s_bjac_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, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + end subroutine psb_s_bjac_apply_vect + end interface psb_s_bjac_apply_vect + + interface psb_s_bjac_apply + subroutine psb_s_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_s_bjac_prec_type, psb_s_vect_type, psb_spk_ + + type(psb_desc_type),intent(in) :: desc_data + class(psb_s_bjac_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, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + end subroutine psb_s_bjac_apply + end interface psb_s_bjac_apply + + interface psb_s_bjac_precinit + subroutine psb_s_bjac_precinit(prec,info) + import :: psb_desc_type, psb_s_bjac_prec_type, psb_s_vect_type, psb_spk_ + class(psb_s_bjac_prec_type),intent(inout) :: prec + integer, intent(out) :: info + end subroutine psb_s_bjac_precinit + end interface psb_s_bjac_precinit + + interface psb_s_bjac_precbld + subroutine psb_s_bjac_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) + import :: psb_desc_type, psb_s_bjac_prec_type, psb_s_vect_type, psb_spk_, & + & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type + type(psb_sspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_s_bjac_prec_type),intent(inout) :: prec + integer, 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_bjac_precbld + end interface psb_s_bjac_precbld + + interface psb_s_bjac_precseti + subroutine psb_s_bjac_precseti(prec,what,val,info) + import :: psb_desc_type, psb_s_bjac_prec_type, psb_s_vect_type, psb_spk_ + class(psb_s_bjac_prec_type),intent(inout) :: prec + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + end subroutine psb_s_bjac_precseti + end interface psb_s_bjac_precseti + +!!$ interface psb_s_bjac_precsetr +!!$ subroutine psb_s_bjac_precsetr(prec,what,val,info) +!!$ import :: psb_desc_type, psb_s_bjac_prec_type, psb_s_vect_type, psb_spk_ +!!$ class(psb_s_bjac_prec_type),intent(inout) :: prec +!!$ integer, intent(in) :: what +!!$ real(psb_spk_), intent(in) :: val +!!$ integer, intent(out) :: info +!!$ end subroutine psb_s_bjac_precsetr +!!$ end interface psb_s_bjac_precsetr +!!$ +!!$ interface psb_s_bjac_precsetc +!!$ subroutine psb_s_bjac_precsetc(prec,what,val,info) +!!$ import :: psb_desc_type, psb_s_bjac_prec_type, psb_s_vect_type, psb_spk_ +!!$ class(psb_s_bjac_prec_type),intent(inout) :: prec +!!$ integer, intent(in) :: what +!!$ character(len=*), intent(in) :: val +!!$ integer, intent(out) :: info +!!$ end subroutine psb_s_bjac_precsetc +!!$ end interface psb_s_bjac_precsetc +!!$ +!!$ interface psb_s_bjac_precfree +!!$ subroutine psb_s_bjac_precfree(prec,info) +!!$ import :: psb_desc_type, psb_s_bjac_prec_type, psb_s_vect_type, psb_spk_ +!!$ class(psb_s_bjac_prec_type), intent(inout) :: prec +!!$ integer, intent(out) :: info +!!$ end subroutine psb_s_bjac_precfree +!!$ end interface psb_s_bjac_precfree - subroutine psb_s_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_s_bjac_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, intent(out) :: info - character(len=1), optional :: trans - real(psb_spk_),intent(inout), optional, target :: work(:) - - ! Local variables - integer :: n_row,n_col - real(psb_spk_), pointer :: ww(:), aux(:) - type(psb_s_vect_type) :: wv - integer :: ictxt,np,me, err_act, int_err(5) - integer :: debug_level, debug_unit - character :: trans_ - character(len=20) :: name='d_bjac_prec_apply' - character(len=20) :: ch_err - - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) - - - trans_ = psb_toupper(trans) - select case(trans_) - case('N','T','C') - ! Ok - case default - call psb_errpush(psb_err_iarg_invalid_i_,name) - goto 9999 - end select - - - n_row = desc_data%get_local_rows() - n_col = desc_data%get_local_cols() - - if (x%get_nrows() < n_row) then - info = 36 - call psb_errpush(info,name,i_err=(/2,n_row,0,0,0/)) - goto 9999 - end if - if (y%get_nrows() < n_row) then - info = 36 - call psb_errpush(info,name,i_err=(/3,n_row,0,0,0/)) - goto 9999 - end if - if (.not.allocated(prec%d)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - if (size(prec%d) < n_row) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - - - if (n_col <= size(work)) then - ww => work(1:n_col) - if ((4*n_col+n_col) <= size(work)) then - aux => work(n_col+1:) - else - allocate(aux(4*n_col),stat=info) - - endif - else - allocate(ww(n_col),aux(4*n_col),stat=info) - endif - if (info == psb_success_) allocate(wv%v,mold=x%v) +contains - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - call wv%bld(n_col,mold=x%v) - - select case(prec%iprcparm(psb_f_type_)) - case(psb_f_ilu_n_) - - select case(trans_) - case('N') - call psb_spsm(sone,prec%av(psb_l_pr_),x,szero,wv,desc_data,info,& - & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_,work=aux) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),wv,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_, work=aux) - - case('T') - call psb_spsm(sone,prec%av(psb_u_pr_),x,szero,wv,desc_data,info,& - & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_, work=aux) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) - - case('C') - call psb_spsm(sone,prec%av(psb_u_pr_),x,szero,wv,desc_data,info,& - & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_, work=aux) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) - - end select - - if (info /= psb_success_) then - ch_err="psb_spsm" - goto 9999 - end if - - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Invalid factorization') - goto 9999 - end select - - call psb_halo(y,desc_data,info,data=psb_comm_mov_) - - call wv%free(info) - if (n_col <= size(work)) then - if ((4*n_col+n_col) <= size(work)) then - else - deallocate(aux) - endif - else - deallocate(ww,aux) - endif - - - call psb_erractionrestore(err_act) - return + subroutine psb_s_bjac_precdescr(prec,iout) -9999 continue - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return + Implicit None + class(psb_s_bjac_prec_type), intent(in) :: prec + integer, intent(in), optional :: iout - end subroutine psb_s_bjac_apply_vect - - subroutine psb_s_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_s_bjac_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, intent(out) :: info - character(len=1), optional :: trans - real(psb_spk_),intent(inout), optional, target :: work(:) - - ! Local variables - integer :: n_row,n_col - real(psb_spk_), pointer :: ww(:), aux(:) - integer :: ictxt,np,me, err_act, int_err(5) - integer :: debug_level, debug_unit - character :: trans_ - character(len=20) :: name='s_bjac_prec_apply' - character(len=20) :: ch_err + Integer :: err_act, nrow, info + character(len=20) :: name='s_bjac_precdescr' + integer :: iout_ - info = psb_success_ call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) - - - trans_ = psb_toupper(trans) - select case(trans_) - case('N','T','C') - ! Ok - case default - call psb_errpush(psb_err_iarg_invalid_i_,name) - goto 9999 - end select - - - n_row = desc_data%get_local_rows() - n_col = desc_data%get_local_cols() - if (size(x) < n_row) then - info = 36 - call psb_errpush(info,name,i_err=(/2,n_row,0,0,0/)) - goto 9999 - end if - if (size(y) < n_row) then - info = 36 - call psb_errpush(info,name,i_err=(/3,n_row,0,0,0/)) - goto 9999 + info = psb_success_ + + if (present(iout)) then + iout_ = iout + else + iout_ = 6 end if -!!$ if (.not.allocated(prec%d)) then -!!$ info = 1124 -!!$ call psb_errpush(info,name,a_err="preconditioner: D") -!!$ goto 9999 -!!$ end if -!!$ if (size(prec%d) < n_row) then -!!$ info = 1124 -!!$ call psb_errpush(info,name,a_err="preconditioner: D") -!!$ goto 9999 -!!$ end if - - if (n_col <= size(work)) then - ww => work(1:n_col) - if ((4*n_col+n_col) <= size(work)) then - aux => work(n_col+1:) - else - allocate(aux(4*n_col),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - - endif - else - allocate(ww(n_col),aux(4*n_col),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - endif - - - select case(prec%iprcparm(psb_f_type_)) - case(psb_f_ilu_n_) - - select case(trans_) - case('N') - call psb_spsm(sone,prec%av(psb_l_pr_),x,szero,ww,desc_data,info,& - & trans=trans_,scale='L',diag=prec%dv%v%v,choice=psb_none_,work=aux) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),ww,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_, work=aux) - - case('T') - call psb_spsm(sone,prec%av(psb_u_pr_),x,szero,ww,desc_data,info,& - & trans=trans_,scale='L',diag=prec%dv%v%v,choice=psb_none_, work=aux) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) - - case('C') - call psb_spsm(sone,prec%av(psb_u_pr_),x,szero,ww,desc_data,info,& - & trans=trans_,scale='L',diag=prec%dv%v%v,choice=psb_none_, work=aux) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) - - end select - if (info /= psb_success_) then - ch_err="psb_spsm" - goto 9999 - end if - - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Invalid factorization') + if (.not.allocated(prec%iprcparm)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") goto 9999 - end select - - call psb_halo(y,desc_data,info,data=psb_comm_mov_) - - if (n_col <= size(work)) then - if ((4*n_col+n_col) <= size(work)) then - else - deallocate(aux) - endif - else - deallocate(ww,aux) - endif + end if + write(iout_,*) 'Block Jacobi with: ',& + & fact_names(prec%iprcparm(psb_f_type_)) call psb_erractionrestore(err_act) return - + 9999 continue - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then call psb_error() return end if return - - - end subroutine psb_s_bjac_apply - - subroutine psb_s_bjac_precinit(prec,info) - - use psb_base_mod - Implicit None - class(psb_s_bjac_prec_type),intent(inout) :: prec - integer, intent(out) :: info - Integer :: err_act, nrow - character(len=20) :: name='s_null_precinit' + end subroutine psb_s_bjac_precdescr - call psb_erractionsave(err_act) - info = psb_success_ - call psb_realloc(psb_ifpsz,prec%iprcparm,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_Errpush(info,name) - goto 9999 - end if + function psb_s_bjac_sizeof(prec) result(val) + class(psb_s_bjac_prec_type), intent(in) :: prec + integer(psb_long_int_k_) :: val - prec%iprcparm(:) = 0 - prec%iprcparm(psb_p_type_) = psb_bjac_ - prec%iprcparm(psb_f_type_) = psb_f_ilu_n_ - prec%iprcparm(psb_ilu_fill_in_) = 0 - - - 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 + val = 0 + if (allocated(prec%dv)) then + val = val + psb_sizeof_sp * prec%dv%get_nrows() + endif + if (allocated(prec%av)) then + val = val + prec%av(psb_l_pr_)%sizeof() + val = val + prec%av(psb_u_pr_)%sizeof() + endif return - end subroutine psb_s_bjac_precinit - - - subroutine psb_s_bjac_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - - use psb_base_mod - use psb_prec_mod, only : psb_ilu_fct - Implicit None - - type(psb_sspmat_type), intent(in), target :: a - type(psb_desc_type), intent(in), target :: desc_a - class(psb_s_bjac_prec_type),intent(inout) :: prec - integer, 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 - - ! .. Local Scalars .. - integer :: i, m - integer :: int_err(5) - character :: trans, unitd - type(psb_s_csr_sparse_mat), allocatable :: lf, uf - real(psb_spk_), allocatable :: dd(:) - integer nztota, err_act, n_row, nrow_a,n_col, nhalo - integer :: ictxt,np,me - character(len=20) :: name='s_bjac_precbld' - character(len=20) :: ch_err - - - if(psb_get_errstatus() /= 0) return - info = psb_success_ - - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + end function psb_s_bjac_sizeof - call prec%set_ctxt(ictxt) + function psb_s_bjac_get_nzeros(prec) result(val) - m = a%get_nrows() - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,i_err=int_err) - goto 9999 + class(psb_s_bjac_prec_type), intent(in) :: prec + integer(psb_long_int_k_) :: val + + val = 0 + if (allocated(prec%dv)) then + val = val + prec%dv%get_nrows() + endif + if (allocated(prec%av)) then + val = val + prec%av(psb_l_pr_)%get_nzeros() + val = val + prec%av(psb_u_pr_)%get_nzeros() endif - trans = 'N' - unitd = 'U' - - select case(prec%iprcparm(psb_f_type_)) - - case(psb_f_ilu_n_) - - if (allocated(prec%av)) then - if (size(prec%av) < psb_bp_ilu_avsz) then - do i=1,size(prec%av) - call prec%av(i)%free() - enddo - deallocate(prec%av,stat=info) - endif - end if - if (.not.allocated(prec%av)) then - allocate(prec%av(psb_max_avsz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - endif - - nrow_a = desc_a%get_local_rows() - nztota = a%get_nzeros() - - n_col = desc_a%get_local_cols() - nhalo = n_col-nrow_a - n_row = nrow_a - - allocate(lf,uf,stat=info) - if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) - if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) - - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - allocate(dd(n_row),stat=info) - if (info == psb_success_) then - allocate(prec%dv, stat=info) - if (info == 0) then - if (present(vmold)) then - allocate(prec%dv%v,mold=vmold,stat=info) - else - allocate(psb_s_base_vect_type :: prec%dv%v,stat=info) - end if - end if - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - endif - ! This is where we have no renumbering, thus no need - call psb_ilu_fct(a,lf,uf,dd,info) - - if(info == psb_success_) then - call prec%av(psb_l_pr_)%mv_from(lf) - call prec%av(psb_u_pr_)%mv_from(uf) - call prec%av(psb_l_pr_)%set_asb() - call prec%av(psb_u_pr_)%set_asb() - call prec%av(psb_l_pr_)%trim() - call prec%av(psb_u_pr_)%trim() - call prec%dv%bld(dd) - call move_alloc(dd,prec%d) - else - info=psb_err_from_subroutine_ - ch_err='psb_ilu_fct' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case(psb_f_none_) - info=psb_err_from_subroutine_ - ch_err='Inconsistent prec psb_f_none_' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - - case default - info=psb_err_from_subroutine_ - ch_err='Unknown psb_f_type_' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - - if (present(amold)) then - call prec%av(psb_l_pr_)%cscnv(info,mold=amold) - call prec%av(psb_u_pr_)%cscnv(info,mold=amold) - else if (present(afmt)) then - call prec%av(psb_l_pr_)%cscnv(info,type=afmt) - call prec%av(psb_u_pr_)%cscnv(info,type=afmt) - end if - - call psb_erractionrestore(err_act) return + end function psb_s_bjac_get_nzeros -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_bjac_precbld + subroutine psb_s_bjac_precsetr(prec,what,val,info) - subroutine psb_s_bjac_precseti(prec,what,val,info) - - use psb_base_mod Implicit None - - class(psb_s_bjac_prec_type),intent(inout) :: prec - integer, intent(in) :: what - integer, intent(in) :: val - integer, intent(out) :: info - Integer :: err_act, nrow - character(len=20) :: name='s_bjac_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - if (.not.allocated(prec%iprcparm)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - - select case(what) - case (psb_f_type_) - if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then - write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& - & prec%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif - prec%iprcparm(psb_f_type_) = val - - case (psb_ilu_fill_in_) - if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.& - & (prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then - write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& - & prec%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif - prec%iprcparm(psb_ilu_fill_in_) = val - - case default - write(psb_err_unit,*) 'WHAT is invalid, ignoring user specification' - - end select - - 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_bjac_precseti - subroutine psb_s_bjac_precsetr(prec,what,val,info) - - use psb_base_mod - Implicit None - class(psb_s_bjac_prec_type),intent(inout) :: prec integer, intent(in) :: what real(psb_spk_), intent(in) :: val @@ -601,7 +221,7 @@ contains call psb_erractionsave(err_act) info = psb_success_ - + call psb_erractionrestore(err_act) return @@ -615,10 +235,9 @@ contains end subroutine psb_s_bjac_precsetr subroutine psb_s_bjac_precsetc(prec,what,val,info) - - use psb_base_mod + Implicit None - + class(psb_s_bjac_prec_type),intent(inout) :: prec integer, intent(in) :: what character(len=*), intent(in) :: val @@ -629,7 +248,7 @@ contains call psb_erractionsave(err_act) info = psb_success_ - + call psb_erractionrestore(err_act) return @@ -643,18 +262,17 @@ contains end subroutine psb_s_bjac_precsetc subroutine psb_s_bjac_precfree(prec,info) - - use psb_base_mod + Implicit None class(psb_s_bjac_prec_type), intent(inout) :: prec integer, intent(out) :: info - + Integer :: err_act, i character(len=20) :: name='s_bjac_precfree' - + call psb_erractionsave(err_act) - + info = psb_success_ if (allocated(prec%av)) then do i=1,size(prec%av) @@ -679,128 +297,7 @@ contains return end if return - - end subroutine psb_s_bjac_precfree - - subroutine psb_s_bjac_precdescr(prec,iout) - - use psb_base_mod - Implicit None - - class(psb_s_bjac_prec_type), intent(in) :: prec - integer, intent(in), optional :: iout - - Integer :: err_act, nrow, info - character(len=20) :: name='s_bjac_precdescr' - integer :: iout_ - - call psb_erractionsave(err_act) - - info = psb_success_ - - if (present(iout)) then - iout_ = iout - else - iout_ = 6 - end if - - if (.not.allocated(prec%iprcparm)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - - write(iout_,*) 'Block Jacobi with: ',& - & fact_names(prec%iprcparm(psb_f_type_)) - - 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_bjac_precdescr - - - subroutine psb_s_bjac_dump(prec,info,prefix,head) - use psb_base_mod - implicit none - class(psb_s_bjac_prec_type), intent(in) :: prec - integer, intent(out) :: info - character(len=*), intent(in), optional :: prefix,head - integer :: i, j, il1, iln, lname, lev - integer :: 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_fact_d" - end if - - lname = len_trim(prefix_) - fname = trim(prefix_) - write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam - lname = lname + 5 - write(fname(lname+1:),'(a)')'_lower.mtx' - if (prec%av(psb_l_pr_)%is_asb()) & - & call prec%av(psb_l_pr_)%print(fname,head=head) - write(fname(lname+1:),'(a,a)')'_diag.mtx' - if (allocated(prec%d)) & - & call psb_geprt(fname,prec%d,head=head) - write(fname(lname+1:),'(a)')'_upper.mtx' - if (prec%av(psb_u_pr_)%is_asb()) & - & call prec%av(psb_u_pr_)%print(fname,head=head) - - end subroutine psb_s_bjac_dump - - function psb_s_bjac_sizeof(prec) result(val) - use psb_base_mod, only : psb_long_int_k_ - class(psb_s_bjac_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val - - val = 0 - if (allocated(prec%d)) then - val = val + psb_sizeof_sp * size(prec%d) - endif - if (allocated(prec%av)) then - val = val + psb_sizeof(prec%av(psb_l_pr_)) - val = val + psb_sizeof(prec%av(psb_u_pr_)) - endif - return - end function psb_s_bjac_sizeof - - function psb_s_bjac_get_nzeros(prec) result(val) - use psb_base_mod, only : psb_long_int_k_ - class(psb_s_bjac_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val - - val = 0 - if (allocated(prec%dv)) then - val = val + prec%dv%get_nrows() - endif - if (allocated(prec%av)) then - val = val + prec%av(psb_l_pr_)%get_nzeros() - val = val + prec%av(psb_u_pr_)%get_nzeros() - endif - return - end function psb_s_bjac_get_nzeros + end subroutine psb_s_bjac_precfree end module psb_s_bjacprec diff --git a/prec/psb_s_diagprec.f90 b/prec/psb_s_diagprec.f90 index 2fb89dcd..8dd977cb 100644 --- a/prec/psb_s_diagprec.f90 +++ b/prec/psb_s_diagprec.f90 @@ -3,7 +3,7 @@ module psb_s_diagprec use psb_s_base_prec_mod type, extends(psb_s_base_prec_type) :: psb_s_diag_prec_type - real(psb_spk_), allocatable :: d(:) + real(psb_spk_), allocatable :: d(:) type(psb_s_vect_type), allocatable :: dv contains procedure, pass(prec) :: s_apply_v => psb_s_diag_apply_vect @@ -19,212 +19,61 @@ module psb_s_diagprec procedure, pass(prec) :: get_nzeros => psb_s_diag_get_nzeros end type psb_s_diag_prec_type - private :: psb_s_diag_apply, psb_s_diag_precbld, psb_s_diag_precseti,& + private :: psb_s_diag_precseti,& & psb_s_diag_precsetr, psb_s_diag_precsetc, psb_s_diag_sizeof,& & psb_s_diag_precinit, psb_s_diag_precfree, psb_s_diag_precdescr,& - & psb_s_diag_apply_vect, psb_s_diag_get_nzeros + & psb_s_diag_get_nzeros + + + + interface psb_s_diag_apply_vect + subroutine psb_s_diag_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_s_diag_prec_type, psb_s_vect_type, psb_spk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_s_diag_prec_type), intent(inout) :: prec + type(psb_s_vect_type),intent(inout) :: x + real(psb_spk_),intent(in) :: alpha, beta + type(psb_s_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + end subroutine psb_s_diag_apply_vect + end interface psb_s_diag_apply_vect + + interface psb_s_diag_apply + subroutine psb_s_diag_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_s_diag_prec_type, psb_s_vect_type, psb_spk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_s_diag_prec_type), intent(in) :: prec + real(psb_spk_),intent(inout) :: x(:) + real(psb_spk_),intent(in) :: alpha, beta + real(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + end subroutine psb_s_diag_apply + end interface psb_s_diag_apply + + interface psb_s_diag_precbld + subroutine psb_s_diag_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) + import :: psb_desc_type, psb_s_diag_prec_type, psb_s_vect_type, psb_spk_, & + & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type + type(psb_sspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_s_diag_prec_type),intent(inout) :: prec + integer, 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_diag_precbld + end interface psb_s_diag_precbld contains - subroutine psb_s_diag_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_s_diag_prec_type), intent(inout) :: prec - type(psb_s_vect_type),intent(inout) :: x - real(psb_spk_),intent(in) :: alpha, beta - type(psb_s_vect_type),intent(inout) :: y - integer, intent(out) :: info - character(len=1), optional :: trans - real(psb_spk_),intent(inout), optional, target :: work(:) - Integer :: err_act, nrow - character(len=20) :: name='d_diag_prec_apply' - real(psb_spk_), pointer :: ww(:) - class(psb_s_base_vect_type), allocatable :: dw - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the DIAG preonditioner??? - ! - info = psb_success_ - - nrow = desc_data%get_local_rows() - if (x%get_nrows() < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) - goto 9999 - end if - if (y%get_nrows() < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) - goto 9999 - end if - if (.not.allocated(prec%d)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - if (size(prec%d) < nrow) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - - if (size(work) >= x%get_nrows()) then - ww => work - else - allocate(ww(x%get_nrows()),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,& - & i_err=(/x%get_nrows(),0,0,0,0/),a_err='real(psb_spk_)') - goto 9999 - end if - end if - -!!$ allocate(dw, mold=x, stat=info) -!!$ call dw%bld(x%get_nrows()) -!!$ if (.true.) then -!!$ if (info == 0) call dw%mlt(prec%dv,x,info) -!!$ else -!!$ if (info == 0) call dw%axpby(nrow,done,x,dzero,info) -!!$ if (info == 0) call dw%mlt(prec%dv,info) -!!$ end if -!!$ if (info == 0) call y%axpby(nrow,alpha,dw,beta,info) - - call y%mlt(alpha,prec%dv,x,beta,info) - -!!$ call x%mlt(ww,prec%d(1:nrow),info) -!!$ if (info == 0) call psb_geaxpby(alpha,ww,beta,y,desc_data,info) - -!!$ call dw%free(info) -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') -!!$ goto 9999 -!!$ end if - - if (size(work) < x%get_nrows()) then - deallocate(ww,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') - goto 9999 - end if - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psb_s_diag_apply_vect - - - subroutine psb_s_diag_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_s_diag_prec_type), intent(in) :: prec - real(psb_spk_),intent(inout) :: x(:) - real(psb_spk_),intent(in) :: alpha, beta - real(psb_spk_),intent(inout) :: y(:) - integer, intent(out) :: info - character(len=1), optional :: trans - real(psb_spk_),intent(inout), optional, target :: work(:) - Integer :: err_act, nrow - character :: trans_ - character(len=20) :: name='s_diag_prec_apply' - real(psb_spk_), pointer :: ww(:) - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the DIAG preonditioner??? - ! - info = psb_success_ - - nrow = desc_data%get_local_rows() - if (size(x) < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) - goto 9999 - end if - if (size(y) < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) - goto 9999 - end if - if (.not.allocated(prec%d)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - if (size(prec%d) < nrow) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - if (present(trans)) then - trans_ = psb_toupper(trans) - else - trans_='N' - end if - - select case(trans_) - case('N') - case('T','C') - case default - info=psb_err_iarg_invalid_i_ - call psb_errpush(info,name,& - & i_err=(/6,0,0,0,0/),a_err=trans_) - goto 9999 - end select - - if (size(work) >= size(x)) then - ww => work - else - allocate(ww(size(x)),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,& - & i_err=(/size(x),0,0,0,0/),a_err='real(psb_spk_)') - goto 9999 - end if - end if - - ww(1:nrow) = x(1:nrow)*prec%d(1:nrow) - call psb_geaxpby(alpha,ww,beta,y,desc_data,info) - - if (size(work) < size(x)) then - deallocate(ww,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') - goto 9999 - end if - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psb_s_diag_apply - subroutine psb_s_diag_precinit(prec,info) - - use psb_base_mod Implicit None class(psb_s_diag_prec_type),intent(inout) :: prec @@ -250,83 +99,7 @@ contains end subroutine psb_s_diag_precinit - subroutine psb_s_diag_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - - use psb_base_mod - Implicit None - - type(psb_sspmat_type), intent(in), target :: a - type(psb_desc_type), intent(in), target :: desc_a - class(psb_s_diag_prec_type),intent(inout) :: prec - integer, 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 :: err_act, nrow,i - character(len=20) :: name='s_diag_precbld' - - call psb_erractionsave(err_act) - - info = psb_success_ - nrow = desc_a%get_local_cols() - if (allocated(prec%d)) then - if (size(prec%d) < nrow) then - deallocate(prec%d,stat=info) - end if - end if - if ((info == psb_success_).and.(.not.allocated(prec%d))) then - allocate(prec%d(nrow), stat=info) - end if - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - call a%get_diag(prec%d,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='get_diag') - goto 9999 - end if - - do i=1,nrow - if (prec%d(i) == dzero) then - prec%d(i) = done - else - prec%d(i) = done/prec%d(i) - endif - end do - allocate(prec%dv,stat=info) - if (info == 0) then - if (present(vmold)) then - allocate(prec%dv%v,mold=vmold,stat=info) - else - allocate(psb_s_base_vect_type :: prec%dv%v,stat=info) - end if - end if - if (info == 0) then - call prec%dv%bld(prec%d) - else - write(0,*) 'Error on precbld ',info - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_s_diag_precbld - subroutine psb_s_diag_precseti(prec,what,val,info) - - use psb_base_mod Implicit None class(psb_s_diag_prec_type),intent(inout) :: prec @@ -354,7 +127,6 @@ contains subroutine psb_s_diag_precsetr(prec,what,val,info) - use psb_base_mod Implicit None class(psb_s_diag_prec_type),intent(inout) :: prec @@ -381,8 +153,6 @@ contains end subroutine psb_s_diag_precsetr subroutine psb_s_diag_precsetc(prec,what,val,info) - - use psb_base_mod Implicit None class(psb_s_diag_prec_type),intent(inout) :: prec @@ -410,7 +180,6 @@ contains subroutine psb_s_diag_precfree(prec,info) - use psb_base_mod Implicit None class(psb_s_diag_prec_type), intent(inout) :: prec @@ -424,7 +193,7 @@ contains info = psb_success_ if (allocated(prec%dv)) call prec%dv%free(info) - + call psb_erractionrestore(err_act) return @@ -440,8 +209,6 @@ contains subroutine psb_s_diag_precdescr(prec,iout) - - use psb_base_mod Implicit None class(psb_s_diag_prec_type), intent(in) :: prec @@ -482,17 +249,14 @@ contains end subroutine psb_s_diag_precdescr function psb_s_diag_sizeof(prec) result(val) - use psb_base_mod, only : psb_long_int_k_ class(psb_s_diag_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: val - val = 0 - val = val + psb_sizeof_sp * size(prec%d) + val = psb_sizeof_sp * prec%get_nzeros() return end function psb_s_diag_sizeof function psb_s_diag_get_nzeros(prec) result(val) - use psb_base_mod, only: psb_long_int_k_ class(psb_s_diag_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: val @@ -501,4 +265,5 @@ contains return end function psb_s_diag_get_nzeros + end module psb_s_diagprec diff --git a/prec/psb_s_nullprec.f90 b/prec/psb_s_nullprec.f90 index aa5d4028..aab6b9bd 100644 --- a/prec/psb_s_nullprec.f90 +++ b/prec/psb_s_nullprec.f90 @@ -4,8 +4,8 @@ module psb_s_nullprec type, extends(psb_s_base_prec_type) :: psb_s_null_prec_type contains - procedure, pass(prec) :: s_apply_v => psb_s_null_apply_vect - procedure, pass(prec) :: s_apply => psb_s_null_apply + procedure, pass(prec) :: c_apply_v => psb_s_null_apply_vect + procedure, pass(prec) :: c_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 @@ -16,122 +16,46 @@ module psb_s_nullprec procedure, pass(prec) :: sizeof => psb_s_null_sizeof end type psb_s_null_prec_type - private :: psb_s_null_apply, psb_s_null_precbld, psb_s_null_precseti,& + private :: psb_s_null_precbld, psb_s_null_precseti,& & psb_s_null_precsetr, psb_s_null_precsetc, psb_s_null_sizeof,& - & psb_s_null_precinit, psb_s_null_precfree, psb_s_null_precdescr, & - & psb_s_null_apply_vect + & psb_s_null_precinit, psb_s_null_precfree, psb_s_null_precdescr + + + interface psb_s_null_apply_vect + subroutine psb_s_null_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_s_null_prec_type, psb_s_vect_type, psb_spk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_s_null_prec_type), intent(inout) :: prec + type(psb_s_vect_type),intent(inout) :: x + real(psb_spk_),intent(in) :: alpha, beta + type(psb_s_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + + end subroutine psb_s_null_apply_vect + end interface psb_s_null_apply_vect + + interface psb_s_null_apply + subroutine psb_s_null_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_s_null_prec_type, psb_spk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_s_null_prec_type), intent(in) :: prec + real(psb_spk_),intent(inout) :: x(:) + real(psb_spk_),intent(in) :: alpha, beta + real(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + end subroutine psb_s_null_apply + end interface psb_s_null_apply + contains - subroutine psb_s_null_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_s_null_prec_type), intent(inout) :: prec - type(psb_s_vect_type),intent(inout) :: x - real(psb_spk_),intent(in) :: alpha, beta - type(psb_s_vect_type),intent(inout) :: y - integer, intent(out) :: info - character(len=1), optional :: trans - real(psb_spk_),intent(inout), optional, target :: work(:) - Integer :: err_act, nrow - character(len=20) :: name='d_null_prec_apply' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preonditioner??? - ! - info = psb_success_ - - nrow = desc_data%get_local_rows() - if (x%get_nrows() < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) - goto 9999 - end if - if (y%get_nrows() < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) - goto 9999 - end if - - call psb_geaxpby(alpha,x,beta,y,desc_data,info) - if (info /= psb_success_ ) then - info = psb_err_from_subroutine_ - call psb_errpush(infoi,name,a_err="psb_geaxpby") - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psb_s_null_apply_vect - - subroutine psb_s_null_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_s_null_prec_type), intent(in) :: prec - real(psb_spk_),intent(inout) :: x(:) - real(psb_spk_),intent(in) :: alpha, beta - real(psb_spk_),intent(inout) :: y(:) - integer, intent(out) :: info - character(len=1), optional :: trans - real(psb_spk_),intent(inout), optional, target :: work(:) - Integer :: err_act, nrow - character(len=20) :: name='s_null_prec_apply' - - call psb_erractionsave(err_act) - - ! - ! - info = psb_success_ - - nrow = desc_data%get_local_rows() - if (size(x) < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) - goto 9999 - end if - if (size(y) < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) - goto 9999 - end if - - call psb_geaxpby(alpha,x,beta,y,desc_data,info) - if (info /= psb_success_ ) then - info = psb_err_from_subroutine_ - call psb_errpush(infoi,name,a_err="psb_geaxpby") - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psb_s_null_apply - - subroutine psb_s_null_precinit(prec,info) - use psb_base_mod Implicit None class(psb_s_null_prec_type),intent(inout) :: prec @@ -158,7 +82,6 @@ contains subroutine psb_s_null_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - use psb_base_mod Implicit None type(psb_sspmat_type), intent(in), target :: a @@ -191,7 +114,6 @@ contains subroutine psb_s_null_precseti(prec,what,val,info) - use psb_base_mod Implicit None class(psb_s_null_prec_type),intent(inout) :: prec @@ -219,7 +141,6 @@ contains subroutine psb_s_null_precsetr(prec,what,val,info) - use psb_base_mod Implicit None class(psb_s_null_prec_type),intent(inout) :: prec @@ -247,7 +168,6 @@ contains subroutine psb_s_null_precsetc(prec,what,val,info) - use psb_base_mod Implicit None class(psb_s_null_prec_type),intent(inout) :: prec @@ -275,7 +195,6 @@ contains subroutine psb_s_null_precfree(prec,info) - use psb_base_mod Implicit None class(psb_s_null_prec_type), intent(inout) :: prec @@ -304,7 +223,6 @@ contains subroutine psb_s_null_precdescr(prec,iout) - use psb_base_mod Implicit None class(psb_s_null_prec_type), intent(in) :: prec @@ -340,7 +258,7 @@ contains end subroutine psb_s_null_precdescr function psb_s_null_sizeof(prec) result(val) - use psb_base_mod + class(psb_s_null_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: val diff --git a/prec/psb_z_base_prec_mod.f90 b/prec/psb_z_base_prec_mod.f90 index 2986ea4d..00c8e3ee 100644 --- a/prec/psb_z_base_prec_mod.f90 +++ b/prec/psb_z_base_prec_mod.f90 @@ -38,7 +38,7 @@ module psb_z_base_prec_mod ! Reduces size of .mod file. use psb_base_mod, only : psb_dpk_, psb_long_int_k_,& & psb_desc_type, psb_sizeof, psb_free, psb_cdfree, psb_errpush, psb_act_abort_,& - & psb_erractionsave, psb_erractionrestore, psb_error, psb_get_errstatus,& + & psb_erractionsave, psb_erractionrestore, psb_error, psb_get_errstatus, psb_success_,& & psb_z_base_sparse_mat, psb_zspmat_type, psb_z_csr_sparse_mat,& & psb_z_base_vect_type, psb_z_vect_type diff --git a/prec/psb_z_bjacprec.f90 b/prec/psb_z_bjacprec.f90 index d4885f20..673628aa 100644 --- a/prec/psb_z_bjacprec.f90 +++ b/prec/psb_z_bjacprec.f90 @@ -2,7 +2,7 @@ module psb_z_bjacprec use psb_z_base_prec_mod - type, extends(psb_z_base_prec_type) :: psb_z_bjac_prec_type + type, extends(psb_z_base_prec_type) :: psb_z_bjac_prec_type integer, allocatable :: iprcparm(:) type(psb_zspmat_type), allocatable :: av(:) complex(psb_dpk_), allocatable :: d(:) @@ -22,567 +22,195 @@ module psb_z_bjacprec procedure, pass(prec) :: get_nzeros => psb_z_bjac_get_nzeros end type psb_z_bjac_prec_type - private :: psb_z_bjac_apply, psb_z_bjac_precbld, psb_z_bjac_precseti,& - & psb_z_bjac_precsetr, psb_z_bjac_precsetc, psb_z_bjac_sizeof,& - & psb_z_bjac_precinit, psb_z_bjac_precfree, psb_z_bjac_precdescr,& - & psb_z_bjac_dump, psb_z_bjac_apply_vect, psb_z_bjac_get_nzeros + private :: psb_z_bjac_sizeof, psb_z_bjac_precdescr, psb_z_bjac_get_nzeros character(len=15), parameter, private :: & & fact_names(0:2)=(/'None ','ILU(n) ',& & 'ILU(eps) '/) -contains - subroutine psb_z_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_z_bjac_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, intent(out) :: info - character(len=1), optional :: trans - complex(psb_dpk_),intent(inout), optional, target :: work(:) - - ! Local variables - integer :: n_row,n_col - complex(psb_dpk_), pointer :: ww(:), aux(:) - type(psb_z_vect_type) :: wv - integer :: ictxt,np,me, err_act, int_err(5) - integer :: debug_level, debug_unit - character :: trans_ - character(len=20) :: name='d_bjac_prec_apply' - character(len=20) :: ch_err - - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) - - - trans_ = psb_toupper(trans) - select case(trans_) - case('N','T','C') - ! Ok - case default - call psb_errpush(psb_err_iarg_invalid_i_,name) - goto 9999 - end select - - - n_row = desc_data%get_local_rows() - n_col = desc_data%get_local_cols() - - if (x%get_nrows() < n_row) then - info = 36 - call psb_errpush(info,name,i_err=(/2,n_row,0,0,0/)) - goto 9999 - end if - if (y%get_nrows() < n_row) then - info = 36 - call psb_errpush(info,name,i_err=(/3,n_row,0,0,0/)) - goto 9999 - end if - if (.not.allocated(prec%d)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - if (size(prec%d) < n_row) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if + interface psb_z_bjac_dump + subroutine psb_z_bjac_dump(prec,info,prefix,head) + import :: psb_desc_type, psb_z_bjac_prec_type, psb_z_vect_type, psb_dpk_ + class(psb_z_bjac_prec_type), intent(in) :: prec + integer, intent(out) :: info + character(len=*), intent(in), optional :: prefix,head + end subroutine psb_z_bjac_dump + end interface psb_z_bjac_dump + + interface psb_z_bjac_apply_vect + subroutine psb_z_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_z_bjac_prec_type, psb_z_vect_type, psb_dpk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_z_bjac_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, intent(out) :: info + character(len=1), optional :: trans + complex(psb_dpk_),intent(inout), optional, target :: work(:) + end subroutine psb_z_bjac_apply_vect + end interface psb_z_bjac_apply_vect + + interface psb_z_bjac_apply + subroutine psb_z_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_z_bjac_prec_type, psb_z_vect_type, psb_dpk_ + + type(psb_desc_type),intent(in) :: desc_data + class(psb_z_bjac_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, intent(out) :: info + character(len=1), optional :: trans + complex(psb_dpk_),intent(inout), optional, target :: work(:) + end subroutine psb_z_bjac_apply + end interface psb_z_bjac_apply + + interface psb_z_bjac_precinit + subroutine psb_z_bjac_precinit(prec,info) + import :: psb_desc_type, psb_z_bjac_prec_type, psb_z_vect_type, psb_dpk_ + class(psb_z_bjac_prec_type),intent(inout) :: prec + integer, intent(out) :: info + end subroutine psb_z_bjac_precinit + end interface psb_z_bjac_precinit + + interface psb_z_bjac_precbld + subroutine psb_z_bjac_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) + import :: psb_desc_type, psb_z_bjac_prec_type, psb_z_vect_type, psb_dpk_, & + & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type + type(psb_zspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_z_bjac_prec_type),intent(inout) :: prec + integer, 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_bjac_precbld + end interface psb_z_bjac_precbld + + interface psb_z_bjac_precseti + subroutine psb_z_bjac_precseti(prec,what,val,info) + import :: psb_desc_type, psb_z_bjac_prec_type, psb_z_vect_type, psb_dpk_ + class(psb_z_bjac_prec_type),intent(inout) :: prec + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + end subroutine psb_z_bjac_precseti + end interface psb_z_bjac_precseti + +!!$ interface psb_z_bjac_precsetr +!!$ subroutine psb_z_bjac_precsetr(prec,what,val,info) +!!$ import :: psb_desc_type, psb_z_bjac_prec_type, psb_z_vect_type, psb_dpk_ +!!$ class(psb_z_bjac_prec_type),intent(inout) :: prec +!!$ integer, intent(in) :: what +!!$ real(psb_dpk_), intent(in) :: val +!!$ integer, intent(out) :: info +!!$ end subroutine psb_z_bjac_precsetr +!!$ end interface psb_z_bjac_precsetr +!!$ +!!$ interface psb_z_bjac_precsetc +!!$ subroutine psb_z_bjac_precsetc(prec,what,val,info) +!!$ import :: psb_desc_type, psb_z_bjac_prec_type, psb_z_vect_type, psb_dpk_ +!!$ class(psb_z_bjac_prec_type),intent(inout) :: prec +!!$ integer, intent(in) :: what +!!$ character(len=*), intent(in) :: val +!!$ integer, intent(out) :: info +!!$ end subroutine psb_z_bjac_precsetc +!!$ end interface psb_z_bjac_precsetc +!!$ +!!$ interface psb_z_bjac_precfree +!!$ subroutine psb_z_bjac_precfree(prec,info) +!!$ import :: psb_desc_type, psb_z_bjac_prec_type, psb_z_vect_type, psb_dpk_ +!!$ class(psb_z_bjac_prec_type), intent(inout) :: prec +!!$ integer, intent(out) :: info +!!$ end subroutine psb_z_bjac_precfree +!!$ end interface psb_z_bjac_precfree - - if (n_col <= size(work)) then - ww => work(1:n_col) - if ((4*n_col+n_col) <= size(work)) then - aux => work(n_col+1:) - else - allocate(aux(4*n_col),stat=info) - - endif - else - allocate(ww(n_col),aux(4*n_col),stat=info) - endif - if (info == psb_success_) allocate(wv%v,mold=x%v) +contains - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - call wv%bld(n_col,mold=x%v) - - select case(prec%iprcparm(psb_f_type_)) - case(psb_f_ilu_n_) - - select case(trans_) - case('N') - call psb_spsm(zone,prec%av(psb_l_pr_),x,zzero,wv,desc_data,info,& - & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_,work=aux) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),wv,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_, work=aux) - - case('T') - call psb_spsm(zone,prec%av(psb_u_pr_),x,zzero,wv,desc_data,info,& - & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_, work=aux) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) - - case('C') - write(0,*) 'WARNING: Conjguate case not fixed yet' - call psb_spsm(zone,prec%av(psb_u_pr_),x,zzero,wv,desc_data,info,& - & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_, work=aux) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) - - end select - if (info /= psb_success_) then - ch_err="psb_spsm" - goto 9999 - end if - - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Invalid factorization') - goto 9999 - end select - - call psb_halo(y,desc_data,info,data=psb_comm_mov_) - - call wv%free(info) - if (n_col <= size(work)) then - if ((4*n_col+n_col) <= size(work)) then - else - deallocate(aux) - endif - else - deallocate(ww,aux) - endif - - - call psb_erractionrestore(err_act) - return + subroutine psb_z_bjac_precdescr(prec,iout) -9999 continue - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return + Implicit None + class(psb_z_bjac_prec_type), intent(in) :: prec + integer, intent(in), optional :: iout - end subroutine psb_z_bjac_apply_vect - - subroutine psb_z_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_z_bjac_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, intent(out) :: info - character(len=1), optional :: trans - complex(psb_dpk_),intent(inout), optional, target :: work(:) - - ! Local variables - integer :: n_row,n_col - complex(psb_dpk_), pointer :: ww(:), aux(:) - integer :: ictxt,np,me, err_act, int_err(5) - integer :: debug_level, debug_unit - character :: trans_ - character(len=20) :: name='c_bjac_prec_apply' - character(len=20) :: ch_err + Integer :: err_act, nrow, info + character(len=20) :: name='z_bjac_precdescr' + integer :: iout_ - info = psb_success_ call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) - - - trans_ = psb_toupper(trans) - select case(trans_) - case('N','T','C') - ! Ok - case default - call psb_errpush(psb_err_iarg_invalid_i_,name) - goto 9999 - end select - - - n_row = desc_data%get_local_rows() - n_col = desc_data%get_local_cols() - if (size(x) < n_row) then - info = 36 - call psb_errpush(info,name,i_err=(/2,n_row,0,0,0/)) - goto 9999 - end if - if (size(y) < n_row) then - info = 36 - call psb_errpush(info,name,i_err=(/3,n_row,0,0,0/)) - goto 9999 + info = psb_success_ + + if (present(iout)) then + iout_ = iout + else + iout_ = 6 end if - - if (n_col <= size(work)) then - ww => work(1:n_col) - if ((4*n_col+n_col) <= size(work)) then - aux => work(n_col+1:) - else - allocate(aux(4*n_col),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - - endif - else - allocate(ww(n_col),aux(4*n_col),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - endif - - - select case(prec%iprcparm(psb_f_type_)) - case(psb_f_ilu_n_) - - select case(trans_) - case('N') - call psb_spsm(zone,prec%av(psb_l_pr_),x,zzero,ww,desc_data,info,& - & trans=trans_,scale='L',diag=prec%dv%v%v,choice=psb_none_,work=aux) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),ww,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_, work=aux) - - case('T') - call psb_spsm(zone,prec%av(psb_u_pr_),x,zzero,ww,desc_data,info,& - & trans=trans_,scale='L',diag=prec%dv%v%v,choice=psb_none_, work=aux) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) - - case('C') -!!$ call psb_spsm(zone,prec%av(psb_u_pr_),x,zzero,ww,desc_data,info,& -!!$ & trans=trans_,scale='L',diag=conjg(prec%dv%v%v),choice=psb_none_, work=aux) - call psb_spsm(zone,prec%av(psb_u_pr_),x,zzero,ww,desc_data,info,& - & trans=trans_,scale='L',choice=psb_none_, work=aux) - ww(1:n_row) = ww(1:n_row)*conjg(prec%dv%v%v(1:n_row)) - if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,& - & beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) - - end select - if (info /= psb_success_) then - ch_err="psb_spsm" - goto 9999 - end if - - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Invalid factorization') + if (.not.allocated(prec%iprcparm)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") goto 9999 - end select - - call psb_halo(y,desc_data,info,data=psb_comm_mov_) - - if (n_col <= size(work)) then - if ((4*n_col+n_col) <= size(work)) then - else - deallocate(aux) - endif - else - deallocate(ww,aux) - endif + end if + write(iout_,*) 'Block Jacobi with: ',& + & fact_names(prec%iprcparm(psb_f_type_)) call psb_erractionrestore(err_act) return - + 9999 continue - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then call psb_error() return end if return - - - end subroutine psb_z_bjac_apply - - subroutine psb_z_bjac_precinit(prec,info) - use psb_base_mod - Implicit None - - class(psb_z_bjac_prec_type),intent(inout) :: prec - integer, intent(out) :: info - Integer :: err_act, nrow - character(len=20) :: name='z_bjac_precinit' + end subroutine psb_z_bjac_precdescr - call psb_erractionsave(err_act) - info = psb_success_ - call psb_realloc(psb_ifpsz,prec%iprcparm,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_Errpush(info,name) - goto 9999 - end if + function psb_z_bjac_sizeof(prec) result(val) + class(psb_z_bjac_prec_type), intent(in) :: prec + integer(psb_long_int_k_) :: val - prec%iprcparm(:) = 0 - prec%iprcparm(psb_p_type_) = psb_bjac_ - prec%iprcparm(psb_f_type_) = psb_f_ilu_n_ - prec%iprcparm(psb_ilu_fill_in_) = 0 - - - 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 + val = 0 + if (allocated(prec%dv)) then + val = val + (2*psb_sizeof_dp) * prec%dv%get_nrows() + endif + if (allocated(prec%av)) then + val = val + prec%av(psb_l_pr_)%sizeof() + val = val + prec%av(psb_u_pr_)%sizeof() + endif return - end subroutine psb_z_bjac_precinit - - - subroutine psb_z_bjac_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - - use psb_base_mod - use psb_prec_mod, only : psb_ilu_fct - Implicit None - - type(psb_zspmat_type), intent(in), target :: a - type(psb_desc_type), intent(in), target :: desc_a - class(psb_z_bjac_prec_type),intent(inout) :: prec - integer, 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 - - ! .. Local Scalars .. - integer :: i, m - integer :: int_err(5) - character :: trans, unitd - type(psb_z_csr_sparse_mat), allocatable :: lf, uf - complex(psb_dpk_), allocatable :: dd(:) - integer nztota, err_act, n_row, nrow_a,n_col, nhalo - integer :: ictxt,np,me - character(len=20) :: name='z_bjac_precbld' - character(len=20) :: ch_err - - - if(psb_get_errstatus() /= 0) return - info = psb_success_ - - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + end function psb_z_bjac_sizeof - call prec%set_ctxt(ictxt) + function psb_z_bjac_get_nzeros(prec) result(val) - m = a%get_nrows() - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,i_err=int_err) - goto 9999 + class(psb_z_bjac_prec_type), intent(in) :: prec + integer(psb_long_int_k_) :: val + + val = 0 + if (allocated(prec%dv)) then + val = val + prec%dv%get_nrows() + endif + if (allocated(prec%av)) then + val = val + prec%av(psb_l_pr_)%get_nzeros() + val = val + prec%av(psb_u_pr_)%get_nzeros() endif - trans = 'N' - unitd = 'U' - - select case(prec%iprcparm(psb_f_type_)) - - case(psb_f_ilu_n_) - - if (allocated(prec%av)) then - if (size(prec%av) < psb_bp_ilu_avsz) then - do i=1,size(prec%av) - call prec%av(i)%free() - enddo - deallocate(prec%av,stat=info) - endif - end if - if (.not.allocated(prec%av)) then - allocate(prec%av(psb_max_avsz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - endif - - nrow_a = desc_a%get_local_rows() - nztota = a%get_nzeros() - - n_col = desc_a%get_local_cols() - nhalo = n_col-nrow_a - n_row = nrow_a - - allocate(lf,uf,stat=info) - if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) - if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) - - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - allocate(dd(n_row),stat=info) - if (info == psb_success_) then - allocate(prec%dv, stat=info) - if (info == 0) then - if (present(vmold)) then - allocate(prec%dv%v,mold=vmold,stat=info) - else - allocate(psb_z_base_vect_type :: prec%dv%v,stat=info) - end if - end if - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - endif - ! This is where we have no renumbering, thus no need - call psb_ilu_fct(a,lf,uf,dd,info) - - if(info == psb_success_) then - call prec%av(psb_l_pr_)%mv_from(lf) - call prec%av(psb_u_pr_)%mv_from(uf) - call prec%av(psb_l_pr_)%set_asb() - call prec%av(psb_u_pr_)%set_asb() - call prec%av(psb_l_pr_)%trim() - call prec%av(psb_u_pr_)%trim() - call prec%dv%bld(dd) - call move_alloc(dd,prec%d) - else - info=psb_err_from_subroutine_ - ch_err='psb_ilu_fct' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case(psb_f_none_) - info=psb_err_from_subroutine_ - ch_err='Inconsistent prec psb_f_none_' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - - case default - info=psb_err_from_subroutine_ - ch_err='Unknown psb_f_type_' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - - if (present(amold)) then - call prec%av(psb_l_pr_)%cscnv(info,mold=amold) - call prec%av(psb_u_pr_)%cscnv(info,mold=amold) - else if (present(afmt)) then - call prec%av(psb_l_pr_)%cscnv(info,type=afmt) - call prec%av(psb_u_pr_)%cscnv(info,type=afmt) - end if - - call psb_erractionrestore(err_act) return + end function psb_z_bjac_get_nzeros -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_bjac_precbld + subroutine psb_z_bjac_precsetr(prec,what,val,info) - subroutine psb_z_bjac_precseti(prec,what,val,info) - - use psb_base_mod Implicit None - - class(psb_z_bjac_prec_type),intent(inout) :: prec - integer, intent(in) :: what - integer, intent(in) :: val - integer, intent(out) :: info - Integer :: err_act, nrow - character(len=20) :: name='z_bjac_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - if (.not.allocated(prec%iprcparm)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - - select case(what) - case (psb_f_type_) - if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then - write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& - & prec%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif - prec%iprcparm(psb_f_type_) = val - - case (psb_ilu_fill_in_) - if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.& - & (prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then - write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& - & prec%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif - prec%iprcparm(psb_ilu_fill_in_) = val - - case default - write(psb_err_unit,*) 'WHAT is invalid, ignoring user specification' - - end select - - 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_bjac_precseti - subroutine psb_z_bjac_precsetr(prec,what,val,info) - - use psb_base_mod - Implicit None - class(psb_z_bjac_prec_type),intent(inout) :: prec integer, intent(in) :: what real(psb_dpk_), intent(in) :: val @@ -593,7 +221,7 @@ contains call psb_erractionsave(err_act) info = psb_success_ - + call psb_erractionrestore(err_act) return @@ -607,21 +235,20 @@ contains end subroutine psb_z_bjac_precsetr subroutine psb_z_bjac_precsetc(prec,what,val,info) - - use psb_base_mod + Implicit None - + class(psb_z_bjac_prec_type),intent(inout) :: prec integer, intent(in) :: what character(len=*), intent(in) :: val integer, intent(out) :: info Integer :: err_act, nrow - character(len=20) :: name='c_bjac_precset' + character(len=20) :: name='z_bjac_precset' call psb_erractionsave(err_act) info = psb_success_ - + call psb_erractionrestore(err_act) return @@ -635,18 +262,17 @@ contains end subroutine psb_z_bjac_precsetc subroutine psb_z_bjac_precfree(prec,info) - - use psb_base_mod + Implicit None class(psb_z_bjac_prec_type), intent(inout) :: prec integer, intent(out) :: info - + Integer :: err_act, i character(len=20) :: name='z_bjac_precfree' - + call psb_erractionsave(err_act) - + info = psb_success_ if (allocated(prec%av)) then do i=1,size(prec%av) @@ -671,128 +297,7 @@ contains return end if return - - end subroutine psb_z_bjac_precfree - - subroutine psb_z_bjac_precdescr(prec,iout) - - use psb_base_mod - Implicit None - - class(psb_z_bjac_prec_type), intent(in) :: prec - integer, intent(in), optional :: iout - - Integer :: err_act, nrow, info - character(len=20) :: name='z_bjac_precdescr' - integer :: iout_ - - call psb_erractionsave(err_act) - - info = psb_success_ - - if (present(iout)) then - iout_ = iout - else - iout_ = 6 - end if - - if (.not.allocated(prec%iprcparm)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - - write(iout_,*) 'Block Jacobi with: ',& - & fact_names(prec%iprcparm(psb_f_type_)) - - 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_bjac_precdescr - - - subroutine psb_z_bjac_dump(prec,info,prefix,head) - use psb_base_mod - implicit none - class(psb_z_bjac_prec_type), intent(in) :: prec - integer, intent(out) :: info - character(len=*), intent(in), optional :: prefix,head - integer :: i, j, il1, iln, lname, lev - integer :: 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_fact_d" - end if - - lname = len_trim(prefix_) - fname = trim(prefix_) - write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam - lname = lname + 5 - write(fname(lname+1:),'(a)')'_lower.mtx' - if (prec%av(psb_l_pr_)%is_asb()) & - & call prec%av(psb_l_pr_)%print(fname,head=head) - write(fname(lname+1:),'(a,a)')'_diag.mtx' - if (allocated(prec%d)) & - & call psb_geprt(fname,prec%d,head=head) - write(fname(lname+1:),'(a)')'_upper.mtx' - if (prec%av(psb_u_pr_)%is_asb()) & - & call prec%av(psb_u_pr_)%print(fname,head=head) - - end subroutine psb_z_bjac_dump - - function psb_z_bjac_sizeof(prec) result(val) - use psb_base_mod, only : psb_long_int_k_ - class(psb_z_bjac_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val - - val = 0 - if (allocated(prec%d)) then - val = val + 2*psb_sizeof_dp * size(prec%d) - endif - if (allocated(prec%av)) then - val = val + psb_sizeof(prec%av(psb_l_pr_)) - val = val + psb_sizeof(prec%av(psb_u_pr_)) - endif - return - end function psb_z_bjac_sizeof - - function psb_z_bjac_get_nzeros(prec) result(val) - use psb_base_mod, only : psb_long_int_k_ - class(psb_z_bjac_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val - - val = 0 - if (allocated(prec%dv)) then - val = val + prec%dv%get_nrows() - endif - if (allocated(prec%av)) then - val = val + prec%av(psb_l_pr_)%get_nzeros() - val = val + prec%av(psb_u_pr_)%get_nzeros() - endif - return - end function psb_z_bjac_get_nzeros + end subroutine psb_z_bjac_precfree end module psb_z_bjacprec diff --git a/prec/psb_z_diagprec.f90 b/prec/psb_z_diagprec.f90 index c892994b..4486fe15 100644 --- a/prec/psb_z_diagprec.f90 +++ b/prec/psb_z_diagprec.f90 @@ -19,195 +19,61 @@ module psb_z_diagprec procedure, pass(prec) :: get_nzeros => psb_z_diag_get_nzeros end type psb_z_diag_prec_type - private :: psb_z_diag_apply, psb_z_diag_precbld, psb_z_diag_precseti,& + private :: psb_z_diag_precseti,& & psb_z_diag_precsetr, psb_z_diag_precsetc, psb_z_diag_sizeof,& & psb_z_diag_precinit, psb_z_diag_precfree, psb_z_diag_precdescr,& - & psb_z_diag_apply_vect, psb_z_diag_get_nzeros + & psb_z_diag_get_nzeros + + + + interface psb_z_diag_apply_vect + subroutine psb_z_diag_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_z_diag_prec_type, psb_z_vect_type, psb_dpk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_z_diag_prec_type), intent(inout) :: prec + type(psb_z_vect_type),intent(inout) :: x + complex(psb_dpk_),intent(in) :: alpha, beta + type(psb_z_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_dpk_),intent(inout), optional, target :: work(:) + end subroutine psb_z_diag_apply_vect + end interface psb_z_diag_apply_vect + + interface psb_z_diag_apply + subroutine psb_z_diag_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_z_diag_prec_type, psb_z_vect_type, psb_dpk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_z_diag_prec_type), intent(in) :: prec + complex(psb_dpk_),intent(inout) :: x(:) + complex(psb_dpk_),intent(in) :: alpha, beta + complex(psb_dpk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_dpk_),intent(inout), optional, target :: work(:) + end subroutine psb_z_diag_apply + end interface psb_z_diag_apply + + interface psb_z_diag_precbld + subroutine psb_z_diag_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) + import :: psb_desc_type, psb_z_diag_prec_type, psb_z_vect_type, psb_dpk_, & + & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type + type(psb_zspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_z_diag_prec_type),intent(inout) :: prec + integer, 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_diag_precbld + end interface psb_z_diag_precbld contains - subroutine psb_z_diag_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_z_diag_prec_type), intent(inout) :: prec - type(psb_z_vect_type),intent(inout) :: x - complex(psb_dpk_),intent(in) :: alpha, beta - type(psb_z_vect_type),intent(inout) :: y - integer, intent(out) :: info - character(len=1), optional :: trans - complex(psb_dpk_),intent(inout), optional, target :: work(:) - Integer :: err_act, nrow - character(len=20) :: name='d_diag_prec_apply' - complex(psb_dpk_), pointer :: ww(:) - class(psb_z_base_vect_type), allocatable :: dw - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the DIAG preonditioner??? - ! - info = psb_success_ - - nrow = desc_data%get_local_rows() - if (x%get_nrows() < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) - goto 9999 - end if - if (y%get_nrows() < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) - goto 9999 - end if - if (.not.allocated(prec%d)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - if (size(prec%d) < nrow) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - - if (size(work) >= x%get_nrows()) then - ww => work - else - allocate(ww(x%get_nrows()),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,& - & i_err=(/x%get_nrows(),0,0,0,0/),a_err='complex(psb_dpk_)') - goto 9999 - end if - end if - - - call y%mlt(alpha,prec%dv,x,beta,info,conjgx=trans) - - if (size(work) < x%get_nrows()) then - deallocate(ww,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') - goto 9999 - end if - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psb_z_diag_apply_vect - - - subroutine psb_z_diag_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_z_diag_prec_type), intent(in) :: prec - complex(psb_dpk_),intent(inout) :: x(:) - complex(psb_dpk_),intent(in) :: alpha, beta - complex(psb_dpk_),intent(inout) :: y(:) - integer, intent(out) :: info - character(len=1), optional :: trans - complex(psb_dpk_),intent(inout), optional, target :: work(:) - Integer :: err_act, nrow - character :: trans_ - character(len=20) :: name='c_diag_prec_apply' - complex(psb_dpk_), pointer :: ww(:) - - call psb_erractionsave(err_act) - - info = psb_success_ - - nrow = desc_data%get_local_rows() - if (size(x) < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) - goto 9999 - end if - if (size(y) < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) - goto 9999 - end if - if (.not.allocated(prec%d)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - if (size(prec%d) < nrow) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner: D") - goto 9999 - end if - if (present(trans)) then - trans_ = psb_toupper(trans) - else - trans_='N' - end if - - select case(trans_) - case('N') - case('T','C') - case default - info=psb_err_iarg_invalid_i_ - call psb_errpush(info,name,& - & i_err=(/6,0,0,0,0/),a_err=trans_) - goto 9999 - end select - - if (size(work) >= size(x)) then - ww => work - else - allocate(ww(size(x)),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,& - & i_err=(/size(x),0,0,0,0/),a_err='complex(psb_dpk_)') - goto 9999 - end if - end if - - - if (trans_ == 'C') then - ww(1:nrow) = x(1:nrow)*conjg(prec%d(1:nrow)) - else - ww(1:nrow) = x(1:nrow)*prec%d(1:nrow) - endif - call psb_geaxpby(alpha,ww,beta,y,desc_data,info) - - if (size(work) < size(x)) then - deallocate(ww,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') - goto 9999 - end if - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psb_z_diag_apply - subroutine psb_z_diag_precinit(prec,info) - - use psb_base_mod Implicit None class(psb_z_diag_prec_type),intent(inout) :: prec @@ -233,83 +99,7 @@ contains end subroutine psb_z_diag_precinit - subroutine psb_z_diag_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - - use psb_base_mod - Implicit None - - type(psb_zspmat_type), intent(in), target :: a - type(psb_desc_type), intent(in), target :: desc_a - class(psb_z_diag_prec_type),intent(inout) :: prec - integer, 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 :: err_act, nrow,i - character(len=20) :: name='z_diag_precbld' - - call psb_erractionsave(err_act) - - info = psb_success_ - nrow = desc_a%get_local_cols() - if (allocated(prec%d)) then - if (size(prec%d) < nrow) then - deallocate(prec%d,stat=info) - end if - end if - if ((info == psb_success_).and.(.not.allocated(prec%d))) then - allocate(prec%d(nrow), stat=info) - end if - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - call a%get_diag(prec%d,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='get_diag') - goto 9999 - end if - - do i=1,nrow - if (prec%d(i) == dzero) then - prec%d(i) = done - else - prec%d(i) = done/prec%d(i) - endif - end do - allocate(prec%dv,stat=info) - if (info == 0) then - if (present(vmold)) then - allocate(prec%dv%v,mold=vmold,stat=info) - else - allocate(psb_z_base_vect_type :: prec%dv%v,stat=info) - end if - end if - if (info == 0) then - call prec%dv%bld(prec%d) - else - write(0,*) 'Error on precbld ',info - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psb_z_diag_precbld - subroutine psb_z_diag_precseti(prec,what,val,info) - - use psb_base_mod Implicit None class(psb_z_diag_prec_type),intent(inout) :: prec @@ -337,7 +127,6 @@ contains subroutine psb_z_diag_precsetr(prec,what,val,info) - use psb_base_mod Implicit None class(psb_z_diag_prec_type),intent(inout) :: prec @@ -364,8 +153,6 @@ contains end subroutine psb_z_diag_precsetr subroutine psb_z_diag_precsetc(prec,what,val,info) - - use psb_base_mod Implicit None class(psb_z_diag_prec_type),intent(inout) :: prec @@ -393,7 +180,6 @@ contains subroutine psb_z_diag_precfree(prec,info) - use psb_base_mod Implicit None class(psb_z_diag_prec_type), intent(inout) :: prec @@ -423,8 +209,6 @@ contains subroutine psb_z_diag_precdescr(prec,iout) - - use psb_base_mod Implicit None class(psb_z_diag_prec_type), intent(in) :: prec @@ -465,23 +249,21 @@ contains end subroutine psb_z_diag_precdescr function psb_z_diag_sizeof(prec) result(val) - use psb_base_mod, only : psb_long_int_k_ class(psb_z_diag_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: val - val = 0 - val = val + 2*psb_sizeof_dp * size(prec%d) + val = (2*psb_sizeof_dp) * prec%get_nzeros() return end function psb_z_diag_sizeof function psb_z_diag_get_nzeros(prec) result(val) - use psb_base_mod, only: psb_long_int_k_ class(psb_z_diag_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: val - + val = 0 if (allocated(prec%dv)) val = val + prec%dv%get_nrows() return end function psb_z_diag_get_nzeros + end module psb_z_diagprec diff --git a/prec/psb_z_nullprec.f90 b/prec/psb_z_nullprec.f90 index 975aa522..3217eae3 100644 --- a/prec/psb_z_nullprec.f90 +++ b/prec/psb_z_nullprec.f90 @@ -4,8 +4,8 @@ module psb_z_nullprec type, extends(psb_z_base_prec_type) :: psb_z_null_prec_type contains - procedure, pass(prec) :: z_apply_v => psb_z_null_apply_vect - procedure, pass(prec) :: z_apply => psb_z_null_apply + procedure, pass(prec) :: c_apply_v => psb_z_null_apply_vect + procedure, pass(prec) :: c_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 @@ -16,123 +16,46 @@ module psb_z_nullprec procedure, pass(prec) :: sizeof => psb_z_null_sizeof end type psb_z_null_prec_type - private :: psb_z_null_apply, psb_z_null_precbld, psb_z_null_precseti,& + private :: psb_z_null_precbld, psb_z_null_precseti,& & psb_z_null_precsetr, psb_z_null_precsetc, psb_z_null_sizeof,& - & psb_z_null_precinit, psb_z_null_precfree, psb_z_null_precdescr, & - & psb_z_null_apply_vect + & psb_z_null_precinit, psb_z_null_precfree, psb_z_null_precdescr + interface psb_z_null_apply_vect + subroutine psb_z_null_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_z_null_prec_type, psb_z_vect_type, psb_dpk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_z_null_prec_type), intent(inout) :: prec + type(psb_z_vect_type),intent(inout) :: x + complex(psb_dpk_),intent(in) :: alpha, beta + type(psb_z_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_dpk_),intent(inout), optional, target :: work(:) + + end subroutine psb_z_null_apply_vect + end interface psb_z_null_apply_vect + + interface psb_z_null_apply + subroutine psb_z_null_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_z_null_prec_type, psb_dpk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_z_null_prec_type), intent(in) :: prec + complex(psb_dpk_),intent(inout) :: x(:) + complex(psb_dpk_),intent(in) :: alpha, beta + complex(psb_dpk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_dpk_),intent(inout), optional, target :: work(:) + end subroutine psb_z_null_apply + end interface psb_z_null_apply + + contains - subroutine psb_z_null_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_z_null_prec_type), intent(inout) :: prec - type(psb_z_vect_type),intent(inout) :: x - complex(psb_dpk_),intent(in) :: alpha, beta - type(psb_z_vect_type),intent(inout) :: y - integer, intent(out) :: info - character(len=1), optional :: trans - complex(psb_dpk_),intent(inout), optional, target :: work(:) - Integer :: err_act, nrow - character(len=20) :: name='z_null_prec_apply' - - call psb_erractionsave(err_act) - - ! - ! This is the base version and we should throw an error. - ! Or should it be the NULL preonditioner??? - ! - info = psb_success_ - - nrow = desc_data%get_local_rows() - if (x%get_nrows() < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) - goto 9999 - end if - if (y%get_nrows() < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) - goto 9999 - end if - - call psb_geaxpby(alpha,x,beta,y,desc_data,info) - if (info /= psb_success_ ) then - info = psb_err_from_subroutine_ - call psb_errpush(infoi,name,a_err="psb_geaxpby") - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psb_z_null_apply_vect - - subroutine psb_z_null_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_z_null_prec_type), intent(in) :: prec - complex(psb_dpk_),intent(inout) :: x(:) - complex(psb_dpk_),intent(in) :: alpha, beta - complex(psb_dpk_),intent(inout) :: y(:) - integer, intent(out) :: info - character(len=1), optional :: trans - complex(psb_dpk_),intent(inout), optional, target :: work(:) - Integer :: err_act, nrow - character(len=20) :: name='z_null_prec_apply' - - call psb_erractionsave(err_act) - - ! - ! - info = psb_success_ - - nrow = desc_data%get_local_rows() - if (size(x) < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/)) - goto 9999 - end if - if (size(y) < nrow) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/)) - goto 9999 - end if - - call psb_geaxpby(alpha,x,beta,y,desc_data,info) - if (info /= psb_success_ ) then - info = psb_err_from_subroutine_ - call psb_errpush(infoi,name,a_err="psb_geaxpby") - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psb_z_null_apply - - subroutine psb_z_null_precinit(prec,info) - use psb_base_mod Implicit None class(psb_z_null_prec_type),intent(inout) :: prec @@ -159,7 +82,6 @@ contains subroutine psb_z_null_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - use psb_base_mod Implicit None type(psb_zspmat_type), intent(in), target :: a @@ -192,7 +114,6 @@ contains subroutine psb_z_null_precseti(prec,what,val,info) - use psb_base_mod Implicit None class(psb_z_null_prec_type),intent(inout) :: prec @@ -220,7 +141,6 @@ contains subroutine psb_z_null_precsetr(prec,what,val,info) - use psb_base_mod Implicit None class(psb_z_null_prec_type),intent(inout) :: prec @@ -248,7 +168,6 @@ contains subroutine psb_z_null_precsetc(prec,what,val,info) - use psb_base_mod Implicit None class(psb_z_null_prec_type),intent(inout) :: prec @@ -276,7 +195,6 @@ contains subroutine psb_z_null_precfree(prec,info) - use psb_base_mod Implicit None class(psb_z_null_prec_type), intent(inout) :: prec @@ -305,7 +223,6 @@ contains subroutine psb_z_null_precdescr(prec,iout) - use psb_base_mod Implicit None class(psb_z_null_prec_type), intent(in) :: prec @@ -341,7 +258,7 @@ contains end subroutine psb_z_null_precdescr function psb_z_null_sizeof(prec) result(val) - use psb_base_mod + class(psb_z_null_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: val