diff --git a/base/modules/psb_c_mat_mod.f03 b/base/modules/psb_c_mat_mod.f03 index 6773c194..4719fe9e 100644 --- a/base/modules/psb_c_mat_mod.f03 +++ b/base/modules/psb_c_mat_mod.f03 @@ -1426,6 +1426,7 @@ contains call a%set_dupl(psb_dupl_def_) end if + write(0,*)name,' ', present(mold), present(type),count( (/present(mold),present(type) /)) if (count( (/present(mold),present(type) /)) > 1) then info = 583 call psb_errpush(info,name,a_err='TYPE, MOLD') diff --git a/base/modules/psb_d_base_mat_mod.f03 b/base/modules/psb_d_base_mat_mod.f03 index de3190d5..7c617b13 100644 --- a/base/modules/psb_d_base_mat_mod.f03 +++ b/base/modules/psb_d_base_mat_mod.f03 @@ -1258,7 +1258,7 @@ contains allocate(tmp(nac),stat=info) if (info /= 0) info = 4000 - if (info == 0) tmp(1:nac) = d(1:nac)*x(1:nac) + if (info == 0) call inner_vscal(nac,d,x,tmp) if (info == 0)& & call a%base_cssm(alpha,tmp,beta,y,info,trans) @@ -1273,19 +1273,23 @@ contains call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) goto 9999 end if - - allocate(tmp(nar),stat=info) - if (info /= 0) info = 4000 - if (info == 0)& - & call a%base_cssm(done,x,dzero,tmp,info,trans) - if (info == 0) tmp(1:nar) = d(1:nar)*tmp(1:nar) - if (info == 0)& - & call psb_geaxpby(nar,alpha,tmp,beta,y,info) - - if (info == 0) then - deallocate(tmp,stat=info) - if (info /= 0) info = 4000 + if (beta == dzero) then + call a%base_cssm(alpha,x,dzero,y,info,trans) + if (info == 0) call inner_vscal1(nar,d,y) + else + allocate(tmp(nar),stat=info) + if (info /= 0) info = 4000 + if (info == 0)& + & call a%base_cssm(alpha,x,dzero,tmp,info,trans) + + if (info == 0) call inner_vscal1(nar,d,tmp) + if (info == 0)& + & call psb_geaxpby(nar,done,tmp,beta,y,info) + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if end if else @@ -1318,8 +1322,31 @@ contains return end if return - - + contains + subroutine inner_vscal(n,d,x,y) + implicit none + integer, intent(in) :: n + real(psb_dpk_), intent(in) :: d(*),x(*) + real(psb_dpk_), intent(out) :: y(*) + integer :: i + + do i=1,n + y(i) = d(i)*x(i) + end do + end subroutine inner_vscal + + subroutine inner_vscal1(n,d,x) + implicit none + integer, intent(in) :: n + real(psb_dpk_), intent(in) :: d(*) + real(psb_dpk_), intent(inout) :: x(*) + integer :: i + + do i=1,n + x(i) = d(i)*x(i) + end do + end subroutine inner_vscal1 + end subroutine d_cssv diff --git a/base/modules/psb_d_mat_mod.f03 b/base/modules/psb_d_mat_mod.f03 index d1810ea0..19759343 100644 --- a/base/modules/psb_d_mat_mod.f03 +++ b/base/modules/psb_d_mat_mod.f03 @@ -1485,6 +1485,7 @@ contains call a%set_dupl(psb_dupl_def_) end if + write(0,*)name,' ', present(mold), present(type),count( (/present(mold),present(type) /)) if (count( (/present(mold),present(type) /)) > 1) then info = 583 call psb_errpush(info,name,a_err='TYPE, MOLD') diff --git a/base/modules/psb_error_mod.F90 b/base/modules/psb_error_mod.F90 index ee7e015a..15bae8ff 100644 --- a/base/modules/psb_error_mod.F90 +++ b/base/modules/psb_error_mod.F90 @@ -490,7 +490,9 @@ contains write (0,'("Invalid state for communication descriptor")') case (1123) write (0,'("Invalid combined state for A and DESC_A")') - case(1124:1999) + case (1124) + write (0,'("Invalid state for object:",a)') trim(a_e_d) + case(1125:1999) write (0,'("computational error. code: ",i0)')err_c case(2010) write (0,'("BLACS error. Number of processes=-1")') diff --git a/base/serial/f03/psb_d_csr_impl.f03 b/base/serial/f03/psb_d_csr_impl.f03 index 9e2b110f..7e01c7a1 100644 --- a/base/serial/f03/psb_d_csr_impl.f03 +++ b/base/serial/f03/psb_d_csr_impl.f03 @@ -117,9 +117,9 @@ contains do i=1,m acc = dzero do j=irp(i), irp(i+1)-1 - acc = acc + val(j) * x(ja(j)) + acc = acc - val(j) * x(ja(j)) enddo - y(i) = -acc + y(i) = acc end do else @@ -149,11 +149,11 @@ contains else if (alpha == -done) then do i=1,m - acc = dzero + acc = y(i) do j=irp(i), irp(i+1)-1 - acc = acc + val(j) * x(ja(j)) + acc = acc - val(j) * x(ja(j)) enddo - y(i) = y(i) -acc + y(i) = acc end do else @@ -172,21 +172,21 @@ contains if (alpha == done) then do i=1,m - acc = dzero + acc = -y(i) do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo - y(i) = -y(i) + acc + y(i) = acc end do else if (alpha == -done) then do i=1,m - acc = dzero + acc = y(i) do j=irp(i), irp(i+1)-1 - acc = acc + val(j) * x(ja(j)) + acc = acc - val(j) * x(ja(j)) enddo - y(i) = -y(i) -acc + y(i) = acc end do else @@ -408,9 +408,9 @@ contains do i=1,m acc(1:nc) = dzero do j=irp(i), irp(i+1)-1 - acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + acc(1:nc) = acc(1:nc) - val(j) * x(ja(j),1:nc) enddo - y(i,1:nc) = -acc(1:nc) + y(i,1:nc) = acc(1:nc) end do else @@ -430,21 +430,21 @@ contains if (alpha == done) then do i=1,m - acc(1:nc) = dzero + acc(1:nc) = y(i,1:nc) do j=irp(i), irp(i+1)-1 acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) enddo - y(i,1:nc) = y(i,1:nc) + acc(1:nc) + y(i,1:nc) = acc(1:nc) end do else if (alpha == -done) then - do i=1,m - acc(1:nc) = dzero + do i=1,m + acc(1:nc) = y(i,1:nc) do j=irp(i), irp(i+1)-1 - acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + acc(1:nc) = acc(1:nc) - val(j) * x(ja(j),1:nc) enddo - y(i,1:nc) = y(i,1:nc) -acc(1:nc) + y(i,1:nc) = acc(1:nc) end do else @@ -629,6 +629,17 @@ subroutine d_csr_cssv_impl(alpha,a,x,beta,y,info,trans) goto 9999 end if + if (size(x) c_bjac_apply + procedure, pass(prec) :: precbld => c_bjac_precbld + procedure, pass(prec) :: precinit => c_bjac_precinit + procedure, pass(prec) :: c_base_precseti => c_bjac_precseti + procedure, pass(prec) :: c_base_precsetr => c_bjac_precsetr + procedure, pass(prec) :: c_base_precsetc => c_bjac_precsetc + procedure, pass(prec) :: precfree => c_bjac_precfree + procedure, pass(prec) :: precdescr => c_bjac_precdescr + procedure, pass(prec) :: sizeof => c_bjac_sizeof + end type psb_c_bjac_prec_type + + + character(len=15), parameter, private :: & + & fact_names(0:2)=(/'None ','ILU(n) ',& + & 'ILU(eps) '/) + +contains + + + subroutine 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(in) :: 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 = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + + trans_ = psb_toupper(trans) + select case(trans_) + case('N','T','C') + ! Ok + case default + call psb_errpush(40,name) + goto 9999 + end select + + + n_row = psb_cd_get_local_rows(desc_data) + n_col = psb_cd_get_local_cols(desc_data) + + 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%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 /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + if (info /= 0) then + call psb_errpush(4010,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%d,choice=psb_none_,work=aux) + if(info ==0) 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%d,choice=psb_none_, work=aux) + if(info ==0) 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%d),choice=psb_none_, work=aux) + if(info ==0) 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 /=0) then + ch_err="psb_spsm" + goto 9999 + end if + + + case default + info = 4001 + 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 c_bjac_apply + + subroutine 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' + + call psb_erractionsave(err_act) + + info = 0 + call psb_realloc(psb_ifpsz,prec%iprcparm,info) + if (info /= 0) then + info = 4000 + 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 c_bjac_precinit + + + subroutine c_bjac_precbld(a,desc_a,prec,info,upd) + + use psb_base_mod + use psb_prec_mod + Implicit None + + type(psb_c_sparse_mat), 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 + + ! .. Local Scalars .. + integer :: i, m + integer :: int_err(5) + character :: trans, unitd + type(psb_c_csr_sparse_mat), allocatable :: lf, uf + 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 = 0 + + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + + m = a%get_nrows() + if (m < 0) then + info = 10 + 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 /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + endif + + nrow_a = psb_cd_get_local_rows(desc_a) + nztota = a%get_nzeros() + + n_col = psb_cd_get_local_cols(desc_a) + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == 0) call lf%allocate(n_row,n_row,nztota) + if (info == 0) call uf%allocate(n_row,n_row,nztota) + + if(info/=0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (allocated(prec%d)) then + if (size(prec%d) < n_row) then + deallocate(prec%d) + endif + endif + if (.not.allocated(prec%d)) then + allocate(prec%d(n_row),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + endif + ! This is where we have no renumbering, thus no need + call psb_ilu_fct(a,lf,uf,prec%d,info) + + if(info==0) 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() + else + info=4010 + ch_err='psb_ilu_fct' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + +!!$ call prec%av(psb_l_pr_)%print(30+me) +!!$ call prec%av(psb_u_pr_)%print(40+me) +!!$ do i=1,n_row +!!$ write(50+me,*) i,prec%d(i) +!!$ end do + + case(psb_f_none_) + info=4010 + ch_err='Inconsistent prec psb_f_none_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + + case default + info=4010 + ch_err='Unknown psb_f_type_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + 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 c_bjac_precbld + + subroutine 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 = 0 + 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(0,*) '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(0,*) '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(0,*) '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 c_bjac_precseti + + subroutine 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 + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='c_bjac_precset' + + call psb_erractionsave(err_act) + + info = 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 c_bjac_precsetr + + subroutine 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 + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='c_bjac_precset' + + call psb_erractionsave(err_act) + + info = 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 c_bjac_precsetc + + subroutine 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 = 0 + if (allocated(prec%av)) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + end if + if (allocated(prec%d)) then + deallocate(prec%d,stat=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 c_bjac_precfree + + + subroutine 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 = 0 + + 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 = 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 c_bjac_precdescr + + function c_bjac_sizeof(prec) result(val) + use psb_base_mod + 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 c_bjac_sizeof + +end module psb_c_bjacprec diff --git a/prec/psb_c_diagprec.f03 b/prec/psb_c_diagprec.f03 new file mode 100644 index 00000000..b63b4665 --- /dev/null +++ b/prec/psb_c_diagprec.f03 @@ -0,0 +1,375 @@ +module psb_c_diagprec + use psb_prec_type + + + type, extends(psb_c_base_prec_type) :: psb_c_diag_prec_type + complex(psb_spk_), allocatable :: d(:) + contains + procedure, pass(prec) :: apply => c_diag_apply + procedure, pass(prec) :: precbld => c_diag_precbld + procedure, pass(prec) :: precinit => c_diag_precinit + procedure, pass(prec) :: c_base_precseti => c_diag_precseti + procedure, pass(prec) :: c_base_precsetr => c_diag_precsetr + procedure, pass(prec) :: c_base_precsetc => c_diag_precsetc + procedure, pass(prec) :: precfree => c_diag_precfree + procedure, pass(prec) :: precdescr => c_diag_precdescr + procedure, pass(prec) :: sizeof => c_diag_sizeof + end type psb_c_diag_prec_type + + +contains + + + subroutine 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(in) :: 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) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the DIAG preonditioner??? + ! + info = 0 + + + nrow = psb_cd_get_local_rows(desc_data) + 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=40 + 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 /= 0) then + call psb_errpush(4025,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 /= 0) then + call psb_errpush(4010,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 c_diag_apply + + subroutine c_diag_precinit(prec,info) + + use psb_base_mod + Implicit None + + class(psb_c_diag_prec_type),intent(inout) :: prec + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='c_diag_precinit' + + call psb_erractionsave(err_act) + + info = 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 c_diag_precinit + + + subroutine c_diag_precbld(a,desc_a,prec,info,upd) + + use psb_base_mod + Implicit None + + type(psb_c_sparse_mat), 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 + Integer :: err_act, nrow,i + character(len=20) :: name='c_diag_precbld' + + call psb_erractionsave(err_act) + + info = 0 + nrow = psb_cd_get_local_cols(desc_a) + if (allocated(prec%d)) then + if (size(prec%d) < nrow) then + deallocate(prec%d,stat=info) + end if + end if + if ((info == 0).and.(.not.allocated(prec%d))) then + allocate(prec%d(nrow), stat=info) + end if + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + call a%get_diag(prec%d,info) + if (info /= 0) then + info = 4010 + 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 + + 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 c_diag_precbld + + subroutine c_diag_precseti(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_c_diag_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_diag_precset' + + call psb_erractionsave(err_act) + + info = 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 c_diag_precseti + + subroutine c_diag_precsetr(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_c_diag_prec_type),intent(inout) :: prec + integer, intent(in) :: what + real(psb_spk_), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='c_diag_precset' + + call psb_erractionsave(err_act) + + info = 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 c_diag_precsetr + + subroutine c_diag_precsetc(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_c_diag_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_diag_precset' + + call psb_erractionsave(err_act) + + info = 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 c_diag_precsetc + + subroutine c_diag_precfree(prec,info) + + use psb_base_mod + Implicit None + + class(psb_c_diag_prec_type), intent(inout) :: prec + integer, intent(out) :: info + + Integer :: err_act, nrow + character(len=20) :: name='c_diag_precset' + + call psb_erractionsave(err_act) + + info = 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 c_diag_precfree + + + subroutine c_diag_precdescr(prec,iout) + + use psb_base_mod + Implicit None + + class(psb_c_diag_prec_type), intent(in) :: prec + integer, intent(in), optional :: iout + + Integer :: err_act, nrow, info + character(len=20) :: name='c_diag_precdescr' + + integer :: iout_ + + call psb_erractionsave(err_act) + + info = 0 + + if (present(iout)) then + iout_ = iout + else + iout_ = 6 + end if + + write(iout_,*) 'Diagonal scaling' + + call psb_erractionsave(err_act) + + info = 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 c_diag_precdescr + + function c_diag_sizeof(prec) result(val) + use psb_base_mod + 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) + return + end function c_diag_sizeof + +end module psb_c_diagprec diff --git a/prec/psb_c_nullprec.f03 b/prec/psb_c_nullprec.f03 new file mode 100644 index 00000000..bb6f77c4 --- /dev/null +++ b/prec/psb_c_nullprec.f03 @@ -0,0 +1,293 @@ +module psb_c_nullprec + use psb_prec_type + + + type, extends(psb_c_base_prec_type) :: psb_c_null_prec_type + contains + procedure, pass(prec) :: apply => c_null_apply + procedure, pass(prec) :: precbld => c_null_precbld + procedure, pass(prec) :: precinit => c_null_precinit + procedure, pass(prec) :: c_base_precseti => c_null_precseti + procedure, pass(prec) :: c_base_precsetr => c_null_precsetr + procedure, pass(prec) :: c_base_precsetc => c_null_precsetc + procedure, pass(prec) :: precfree => c_null_precfree + procedure, pass(prec) :: precdescr => c_null_precdescr + procedure, pass(prec) :: sizeof => c_null_sizeof + end type psb_c_null_prec_type + + +contains + + + subroutine 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(in) :: 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) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 0 + + nrow = psb_cd_get_local_rows(desc_data) + 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 /= 0 ) then + info = 4010 + 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 c_null_apply + + + subroutine c_null_precinit(prec,info) + + use psb_base_mod + Implicit None + + class(psb_c_null_prec_type),intent(inout) :: prec + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='c_null_precinit' + + call psb_erractionsave(err_act) + + info = 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 c_null_precinit + + subroutine c_null_precbld(a,desc_a,prec,info,upd) + + use psb_base_mod + Implicit None + + type(psb_c_sparse_mat), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_c_null_prec_type),intent(inout) :: prec + integer, intent(out) :: info + character, intent(in), optional :: upd + Integer :: err_act, nrow + character(len=20) :: name='c_null_precbld' + + call psb_erractionsave(err_act) + + info = 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 c_null_precbld + + subroutine c_null_precseti(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_c_null_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_null_precset' + + call psb_erractionsave(err_act) + + info = 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 c_null_precseti + + subroutine c_null_precsetr(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_c_null_prec_type),intent(inout) :: prec + integer, intent(in) :: what + real(psb_spk_), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='c_null_precset' + + call psb_erractionsave(err_act) + + info = 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 c_null_precsetr + + subroutine c_null_precsetc(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_c_null_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_null_precset' + + call psb_erractionsave(err_act) + + info = 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 c_null_precsetc + + subroutine c_null_precfree(prec,info) + + use psb_base_mod + Implicit None + + class(psb_c_null_prec_type), intent(inout) :: prec + integer, intent(out) :: info + + Integer :: err_act, nrow + character(len=20) :: name='c_null_precset' + + call psb_erractionsave(err_act) + + info = 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 c_null_precfree + + + subroutine c_null_precdescr(prec,iout) + + use psb_base_mod + Implicit None + + class(psb_c_null_prec_type), intent(in) :: prec + integer, intent(in), optional :: iout + + Integer :: err_act, nrow, info + character(len=20) :: name='c_null_precset' + integer :: iout_ + + call psb_erractionsave(err_act) + + info = 0 + + if (present(iout)) then + iout_ = iout + else + iout_ = 6 + end if + + write(iout_,*) 'No preconditioning' + + 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 c_null_precdescr + + function 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 + + val = 0 + + return + end function c_null_sizeof + +end module psb_c_nullprec diff --git a/prec/psb_cbjac_aply.f90 b/prec/psb_cbjac_aply.f90 deleted file mode 100644 index c283a02f..00000000 --- a/prec/psb_cbjac_aply.f90 +++ /dev/null @@ -1,166 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psb_cbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) - ! - ! Compute Y <- beta*Y + alpha*K^-1 X - ! where K is a a Block Jacobi preconditioner stored in prec - ! Note that desc_data may or may not be the same as prec%desc_data, - ! but since both are INTENT(IN) this should be legal. - ! - - use psb_base_mod - use psb_prec_mod, psb_protect_name => psb_cbjac_aply - implicit none - - type(psb_desc_type), intent(in) :: desc_data - type(psb_cprec_type), intent(in) :: prec - complex(psb_spk_),intent(in) :: x(:) - complex(psb_spk_),intent(inout) :: y(:) - complex(psb_spk_),intent(in) :: alpha,beta - character(len=1) :: trans - complex(psb_spk_),target :: work(:) - integer, intent(out) :: info - - ! 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, ch_err - - name='psb_bjac_aply' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = psb_cd_get_context(desc_data) - call psb_info(ictxt, me, np) - - - trans_ = psb_toupper(trans) - select case(trans_) - case('N','T','C') - ! Ok - case default - call psb_errpush(40,name) - goto 9999 - end select - - - n_row=desc_data%matrix_data(psb_n_row_) - n_col=desc_data%matrix_data(psb_n_col_) - - 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 /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - - endif - else - allocate(ww(n_col),aux(4*n_col),stat=info) - if (info /= 0) then - call psb_errpush(4010,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%d,choice=psb_none_,work=aux) - if(info /=0) goto 9999 - call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_, work=aux) - if(info /=0) goto 9999 - - case('T') - call psb_spsm(cone,prec%av(psb_u_pr_),x,czero,ww,desc_data,info,& - & trans=trans_,scale='L',diag=prec%d,choice=psb_none_, work=aux) - if(info /=0) goto 9999 - call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) - if(info /=0) goto 9999 - - case('C') - call psb_spsm(cone,prec%av(psb_u_pr_),x,czero,ww,desc_data,info,& - & trans=trans_,scale='L',diag=conjg(prec%d),choice=psb_none_, work=aux) - if(info /=0) goto 9999 - call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) - if(info /=0) goto 9999 - - end select - - - case default - info = 4001 - 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_cbjac_aply diff --git a/prec/psb_cbjac_bld.f90 b/prec/psb_cbjac_bld.f90 deleted file mode 100644 index dae56048..00000000 --- a/prec/psb_cbjac_bld.f90 +++ /dev/null @@ -1,181 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psb_cbjac_bld(a,desc_a,p,upd,info) - use psb_base_mod - use psb_prec_mod, psb_protect_name => psb_cbjac_bld - implicit none - ! - ! .. Scalar Arguments .. - integer, intent(out) :: info - ! .. array Arguments .. - type(psb_c_sparse_mat), intent(in), target :: a - type(psb_cprec_type), intent(inout) :: p - type(psb_desc_type), intent(in) :: desc_a - character, intent(in) :: upd - - ! .. Local Scalars .. - integer :: i, m - integer :: int_err(5) - character :: trans, unitd - type(psb_c_csr_sparse_mat), allocatable :: lf, uf - real(psb_dpk_) :: t1,t2,t3,t4,t5,t6, t7, t8 - integer nztota, err_act, n_row, nrow_a,n_col, nhalo - integer :: ictxt,np,me - character(len=20) :: name, ch_err - - - if(psb_get_errstatus() /= 0) return - info=0 - name='psb_cbjac_bld' - call psb_erractionsave(err_act) - - ictxt=psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - - m = a%get_nrows() - if (m < 0) then - info = 10 - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - trans = 'N' - unitd = 'U' - - call psb_cdcpy(desc_a,p%desc_data,info) - if(info /= 0) then - info=4010 - ch_err='psb_cdcpy' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - - select case(p%iprcparm(psb_f_type_)) - - case(psb_f_ilu_n_) - - if (allocated(p%av)) then - if (size(p%av) < psb_bp_ilu_avsz) then - do i=1,size(p%av) - call p%av(i)%free() - enddo - deallocate(p%av,stat=info) - endif - end if - if (.not.allocated(p%av)) then - allocate(p%av(psb_max_avsz),stat=info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - endif - - nrow_a = psb_cd_get_local_rows(desc_a) - nztota = a%get_nzeros() - - n_col = psb_cd_get_local_cols(desc_a) - nhalo = n_col-nrow_a - n_row = p%desc_data%matrix_data(psb_n_row_) - - allocate(lf,uf,stat=info) - if (info == 0) call lf%allocate(n_row,n_row,nztota) - if (info == 0) call uf%allocate(n_row,n_row,nztota) - - if(info/=0) then - info=4010 - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if (allocated(p%d)) then - if (size(p%d) < n_row) then - deallocate(p%d) - endif - endif - if (.not.allocated(p%d)) then - allocate(p%d(n_row),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - - endif - t3 = psb_wtime() - ! This is where we have no renumbering, thus no need - call psb_ilu_fct(a,lf,uf,p%d,info) - - if(info==0) then - call p%av(psb_l_pr_)%mv_from(lf) - call p%av(psb_u_pr_)%mv_from(uf) - call p%av(psb_l_pr_)%set_asb() - call p%av(psb_u_pr_)%set_asb() - call p%av(psb_l_pr_)%trim() - call p%av(psb_u_pr_)%trim() - else - info=4010 - ch_err='psb_ilu_fct' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case(psb_f_none_) - info=4010 - ch_err='Inconsistent prec psb_f_none_' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - - case default - info=4010 - ch_err='Unknown psb_f_type_' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - 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_cbjac_bld - - diff --git a/prec/psb_cdiagsc_bld.f90 b/prec/psb_cdiagsc_bld.f90 deleted file mode 100644 index 33ad2e7c..00000000 --- a/prec/psb_cdiagsc_bld.f90 +++ /dev/null @@ -1,120 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psb_cdiagsc_bld(a,desc_a,p,upd,info) - - use psb_base_mod - use psb_prec_mod, psb_protect_name => psb_cdiagsc_bld - Implicit None - - type(psb_c_sparse_mat), intent(in), target :: a - type(psb_desc_type), intent(in) :: desc_a - type(psb_cprec_type),intent(inout) :: p - character, intent(in) :: upd - integer, intent(out) :: info - - - ! Local scalars - Integer :: err, n_row, n_col,I,ictxt,& - & me,np,mglob,err_act - integer :: int_err(5) - - integer,parameter :: iroot=psb_root_,iout=60,ilout=40 - character(len=20) :: name, ch_err - - if(psb_get_errstatus() /= 0) return - info=0 - err=0 - call psb_erractionsave(err_act) - name = 'psb_diagsc_bld' - - info = 0 - int_err(1) = 0 - ictxt = psb_cd_get_context(desc_a) - n_row = psb_cd_get_local_rows(desc_a) - n_col = psb_cd_get_local_cols(desc_a) - mglob = psb_cd_get_global_rows(desc_a) - - call psb_info(ictxt, me, np) - - ! diagonal scaling - - call psb_realloc(n_col,p%d,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_realloc') - goto 9999 - end if - - ! - ! Retrieve the diagonal entries of the matrix A - ! - call a%get_diag(p%d,info) - if(info /= 0) then - info=4010 - ch_err='psb_sp_getdiag' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ! - ! Copy into p%desc_data the descriptor associated to A - ! - call psb_cdcpy(desc_a,p%desc_Data,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_cdcpy') - goto 9999 - end if - - ! - ! The i-th diagonal entry of the preconditioner is set to one if the - ! corresponding entry a_ii of the sparse matrix A is zero; otherwise - ! it is set to one/a_ii - ! - do i=1,n_row - if (p%d(i) == czero) then - p%d(i) = cone - else - p%d(i) = cone/p%d(i) - endif - end do - - 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_cdiagsc_bld - diff --git a/prec/psb_cgprec_aply.f90 b/prec/psb_cgprec_aply.f90 deleted file mode 100644 index e4f204fb..00000000 --- a/prec/psb_cgprec_aply.f90 +++ /dev/null @@ -1,140 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psb_cgprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) - ! - ! Compute Y <- beta*Y + alpha*K^-1 X - ! where K is a a basic preconditioner stored in prec - ! - - use psb_base_mod - use psb_prec_mod, psb_protect_name => psb_cgprec_aply - implicit none - - type(psb_desc_type),intent(in) :: desc_data - type(psb_cprec_type), intent(in) :: prec - complex(psb_spk_),intent(in) :: x(:) - complex(psb_spk_),intent(inout) :: y(:) - complex(psb_spk_),intent(in) :: alpha,beta - character(len=1) :: trans - complex(psb_spk_),target :: work(:) - integer, intent(out) :: info - - ! Local variables - integer :: n_row,int_err(5) - complex(psb_spk_), pointer :: ww(:) - character :: trans_ - integer :: ictxt,np,me, err_act - character(len=20) :: name, ch_err - - - name='psb_cgprec_aply' - info = 0 - call psb_erractionsave(err_act) - - ictxt=desc_data%matrix_data(psb_ctxt_) - call psb_info(ictxt, me, np) - - trans_ = psb_toupper(trans) - - select case(trans_) - case('N') - case('T','C') - case default - info=40 - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - select case(prec%iprcparm(psb_p_type_)) - - case(psb_noprec_) - - call psb_geaxpby(alpha,x,beta,y,desc_data,info) - - case(psb_diag_) - - if (size(work) >= size(x)) then - ww => work - else - allocate(ww(size(x)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - end if - - n_row=desc_data%matrix_data(psb_n_row_) - if (trans_=='C') then - ww(1:n_row) = x(1:n_row)*conjg(prec%d(1:n_row)) - else - ww(1:n_row) = x(1:n_row)*prec%d(1:n_row) - endif - call psb_geaxpby(alpha,ww,beta,y,desc_data,info) - - if (size(work) < size(x)) then - deallocate(ww,stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Deallocate') - goto 9999 - end if - end if - - case(psb_bjac_) - - call psb_bjac_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info) - if(info /= 0) then - info=4010 - ch_err='psb_bjac_aply' - goto 9999 - end if - - case default - info = 4001 - call psb_errpush(info,name,a_err='Invalid prectype') - goto 9999 - end select - - 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_cgprec_aply - diff --git a/prec/psb_cilu_fct.f90 b/prec/psb_cilu_fct.f90 index 04f36b56..0b3e68ea 100644 --- a/prec/psb_cilu_fct.f90 +++ b/prec/psb_cilu_fct.f90 @@ -133,7 +133,7 @@ contains if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) - call trw%allocate(0,0,info) + call trw%allocate(0,0,1) if(info /= 0) then info=4010 ch_err='psb_sp_all' diff --git a/prec/psb_cprc_aply.f90 b/prec/psb_cprc_aply.f90 index f8563547..5476de0d 100644 --- a/prec/psb_cprc_aply.f90 +++ b/prec/psb_cprc_aply.f90 @@ -50,7 +50,7 @@ subroutine psb_cprc_aply(prec,x,y,desc_data,info,trans, work) integer :: ictxt,np,me,err_act character(len=20) :: name - name='psb_cprec_aply' + name='psb_prc_aply' info = 0 call psb_erractionsave(err_act) @@ -74,10 +74,12 @@ subroutine psb_cprc_aply(prec,x,y,desc_data,info,trans, work) end if - call psb_gprec_aply(cone,prec,x,czero,y,desc_data,trans_,work_,info) - - ! If the original distribution has an overlap we should fix that. - + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + call prec%prec%apply(cone,x,czero,y,desc_data,info,trans_,work=work_) if (present(work)) then else deallocate(work_) @@ -151,7 +153,7 @@ subroutine psb_cprc_aply1(prec,x,desc_data,info,trans) integer :: ictxt,np,me, err_act complex(psb_spk_), pointer :: WW(:), w1(:) character(len=20) :: name - name='psb_cprec1' + name='psb_prc_aply1' info = 0 call psb_erractionsave(err_act) @@ -164,12 +166,17 @@ subroutine psb_cprc_aply1(prec,x,desc_data,info,trans) trans_='N' end if + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if allocate(ww(size(x)),w1(size(x)),stat=info) if (info /= 0) then call psb_errpush(4010,name,a_err='Allocate') goto 9999 end if - call psb_cprc_aply(prec,x,ww,desc_data,info,trans_,work=w1) + call prec%prec%apply(cone,x,czero,ww,desc_data,info,trans_,work=w1) if(info /=0) goto 9999 x(:) = ww(:) deallocate(ww,W1) diff --git a/prec/psb_cprecbld.f90 b/prec/psb_cprecbld.f90 index ebd3a9ef..c2f65fc2 100644 --- a/prec/psb_cprecbld.f90 +++ b/prec/psb_cprecbld.f90 @@ -82,51 +82,14 @@ subroutine psb_cprecbld(a,desc_a,p,info,upd) ! ALso should define symbolic names for the preconditioners. ! - call psb_check_def(p%iprcparm(psb_p_type_),'base_prec',& - & psb_diag_,is_legal_prec) - - call psb_nullify_desc(p%desc_data) - - select case(p%iprcparm(psb_p_type_)) - case (psb_noprec_) - ! Do nothing. - call psb_cdcpy(desc_a,p%desc_data,info) - if(info /= 0) then - info=4010 - ch_err='psb_cdcpy' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case (psb_diag_) - - call psb_diagsc_bld(a,desc_a,p,upd_,info) - if(info /= 0) then - info=4010 - ch_err='psb_diagsc_bld' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case (psb_bjac_) - - call psb_check_def(p%iprcparm(psb_f_type_),'fact',& - & psb_f_ilu_n_,is_legal_ml_fact) - - call psb_bjac_bld(a,desc_a,p,upd_,info) - - if(info /= 0) then - call psb_errpush(4010,name,a_err='psb_bjac_bld') - goto 9999 - end if - - case default - info=4010 - ch_err='Unknown psb_p_type_' - call psb_errpush(info,name,a_err=ch_err) + if (.not.allocated(p%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") goto 9999 + end if - end select + call p%prec%precbld(a,desc_a,info,upd) + if (info /= 0) goto 9999 call psb_erractionrestore(err_act) return diff --git a/prec/psb_cprecinit.f90 b/prec/psb_cprecinit.f90 index dff9b3e6..a8b003f2 100644 --- a/prec/psb_cprecinit.f90 +++ b/prec/psb_cprecinit.f90 @@ -33,6 +33,9 @@ subroutine psb_cprecinit(p,ptype,info) use psb_base_mod use psb_prec_mod, psb_protect_name => psb_cprecinit + use psb_c_nullprec + use psb_c_diagprec + use psb_c_bjacprec implicit none type(psb_cprec_type), intent(inout) :: p @@ -40,35 +43,29 @@ subroutine psb_cprecinit(p,ptype,info) integer, intent(out) :: info info = 0 - - call psb_realloc(psb_ifpsz,p%iprcparm,info) - if (info == 0) call psb_realloc(psb_rfpsz,p%rprcparm,info) - if (info /= 0) return - p%iprcparm(:) = 0 + if (allocated(p%prec) ) then + call p%prec%precfree(info) + if (info == 0) deallocate(p%prec,stat=info) + if (info /= 0) return + end if + select case(psb_toupper(ptype(1:len_trim(ptype)))) case ('NONE','NOPREC') - p%iprcparm(:) = 0 - p%iprcparm(psb_p_type_) = psb_noprec_ - p%iprcparm(psb_f_type_) = psb_f_none_ - + + allocate(psb_c_null_prec_type :: p%prec, stat=info) + case ('DIAG') - p%iprcparm(:) = 0 - p%iprcparm(psb_p_type_) = psb_diag_ - p%iprcparm(psb_f_type_) = psb_f_none_ - + allocate(psb_c_diag_prec_type :: p%prec, stat=info) + case ('BJAC') - p%iprcparm(:) = 0 - p%iprcparm(psb_p_type_) = psb_bjac_ - p%iprcparm(psb_f_type_) = psb_f_ilu_n_ - p%iprcparm(psb_ilu_fill_in_) = 0 - + allocate(psb_c_bjac_prec_type :: p%prec, stat=info) + case default write(0,*) 'Unknown preconditioner type request "',ptype,'"' - info = 2 - + end select - - + if (info == 0) call p%prec%precinit(info) + end subroutine psb_cprecinit diff --git a/prec/psb_cprecset.f90 b/prec/psb_cprecset.f90 index 802ee9dc..fe203c49 100644 --- a/prec/psb_cprecset.f90 +++ b/prec/psb_cprecset.f90 @@ -37,30 +37,18 @@ subroutine psb_cprecseti(p,what,val,info) type(psb_cprec_type), intent(inout) :: p integer :: what, val integer, intent(out) :: info + character(len=20) :: name='precset' info = 0 + if (.not.allocated(p%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + return +!!$ goto 9999 + end if - select case(what) - case (psb_f_type_) - if (p%iprcparm(psb_p_type_) /= psb_bjac_) then - write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif - p%iprcparm(psb_f_type_) = val + call p%prec%precset(what,val,info) - case (psb_ilu_fill_in_) - if ((p%iprcparm(psb_p_type_) /= psb_bjac_).or.(p%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then - write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif - p%iprcparm(psb_ilu_fill_in_) = val - - case default - write(0,*) 'WHAT is invalid, ignoring user specification' - - end select return end subroutine psb_cprecseti @@ -75,32 +63,18 @@ subroutine psb_cprecsets(p,what,val,info) integer :: what real(psb_spk_) :: val integer, intent(out) :: info + character(len=20) :: name='precset' + + info = 0 + if (.not.allocated(p%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + return +!!$ goto 9999 + end if -! -! This will have to be changed if/when we put together an ILU(eps) -! factorization. -! - select case(what) -!!$ case (psb_f_type_) -!!$ if (p%iprcparm(psb_p_type_) /= psb_bjac_) then -!!$ write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& -!!$ & 'ignoring user specification' -!!$ return -!!$ endif -!!$ p%iprcparm(psb_f_type_) = val -!!$ -!!$ case (psb_ilu_fill_in_) -!!$ if ((p%iprcparm(psb_p_type_) /= psb_bjac_).or.(p%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then -!!$ write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& -!!$ & 'ignoring user specification' -!!$ return -!!$ endif -!!$ p%iprcparm(psb_ilu_fill_in_) = val - - case default - write(0,*) 'WHAT is invalid, ignoring user specification' + call p%prec%precset(what,val,info) - end select return end subroutine psb_cprecsets diff --git a/prec/psb_d_bjacprec.f03 b/prec/psb_d_bjacprec.f03 index 12db4dcf..3130f21b 100644 --- a/prec/psb_d_bjacprec.f03 +++ b/prec/psb_d_bjacprec.f03 @@ -222,7 +222,6 @@ contains integer :: int_err(5) character :: trans, unitd type(psb_d_csr_sparse_mat), allocatable :: lf, uf - real(psb_dpk_) :: t1,t2,t3,t4,t5,t6, t7, t8 integer nztota, err_act, n_row, nrow_a,n_col, nhalo integer :: ictxt,np,me character(len=20) :: name='d_bjac_precbld' @@ -299,7 +298,6 @@ contains end if endif - t3 = psb_wtime() ! This is where we have no renumbering, thus no need call psb_ilu_fct(a,lf,uf,prec%d,info) diff --git a/prec/psb_dbjac_aply.f90 b/prec/psb_dbjac_aply.f90 deleted file mode 100644 index b77fa231..00000000 --- a/prec/psb_dbjac_aply.f90 +++ /dev/null @@ -1,158 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) - ! - ! Compute Y <- beta*Y + alpha*K^-1 X - ! where K is a a Block Jacobi preconditioner stored in prec - ! Note that desc_data may or may not be the same as prec%desc_data, - ! but since both are INTENT(IN) this should be legal. - ! - - use psb_base_mod - use psb_prec_mod, psb_protect_name => psb_dbjac_aply - implicit none - - type(psb_desc_type), intent(in) :: desc_data - type(psb_dprec_type), intent(in) :: prec - real(psb_dpk_),intent(in) :: x(:) - real(psb_dpk_),intent(inout) :: y(:) - real(psb_dpk_),intent(in) :: alpha,beta - character(len=1) :: trans - real(psb_dpk_),target :: work(:) - integer, intent(out) :: info - - ! 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, ch_err - - name='psb_bjac_aply' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = psb_cd_get_context(desc_data) - call psb_info(ictxt, me, np) - - - trans_ = psb_toupper(trans) - select case(trans_) - case('N','T','C') - ! Ok - case default - call psb_errpush(40,name) - goto 9999 - end select - - - n_row=desc_data%matrix_data(psb_n_row_) - n_col=desc_data%matrix_data(psb_n_col_) - - 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 /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - - endif - else - allocate(ww(n_col),aux(4*n_col),stat=info) - if (info /= 0) then - call psb_errpush(4010,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%d,choice=psb_none_,work=aux) - if(info /=0) goto 9999 - call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_, work=aux) - if(info /=0) goto 9999 - - case('T','C') - call psb_spsm(done,prec%av(psb_u_pr_),x,dzero,ww,desc_data,info,& - & trans=trans_,scale='L',diag=prec%d,choice=psb_none_, work=aux) - if(info /=0) goto 9999 - call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) - if(info /=0) goto 9999 - - end select - - - case default - info = 4001 - 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_dbjac_aply diff --git a/prec/psb_dbjac_bld.f90 b/prec/psb_dbjac_bld.f90 deleted file mode 100644 index 898de8e2..00000000 --- a/prec/psb_dbjac_bld.f90 +++ /dev/null @@ -1,181 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psb_dbjac_bld(a,desc_a,p,upd,info) - use psb_base_mod - use psb_prec_mod, psb_protect_name => psb_dbjac_bld - implicit none - ! - ! .. Scalar Arguments .. - integer, intent(out) :: info - ! .. array Arguments .. - type(psb_d_sparse_mat), intent(in), target :: a - type(psb_dprec_type), intent(inout) :: p - type(psb_desc_type), intent(in) :: desc_a - character, intent(in) :: upd - - ! .. Local Scalars .. - integer :: i, m - integer :: int_err(5) - character :: trans, unitd - type(psb_d_csr_sparse_mat), allocatable :: lf, uf - real(psb_dpk_) :: t1,t2,t3,t4,t5,t6, t7, t8 - integer nztota, err_act, n_row, nrow_a,n_col, nhalo - integer :: ictxt,np,me - character(len=20) :: name, ch_err - - - if(psb_get_errstatus() /= 0) return - info=0 - name='psb_dbjac_bld' - call psb_erractionsave(err_act) - - ictxt=psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - - m = a%get_nrows() - if (m < 0) then - info = 10 - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - trans = 'N' - unitd = 'U' - - call psb_cdcpy(desc_a,p%desc_data,info) - if(info /= 0) then - info=4010 - ch_err='psb_cdcpy' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - - select case(p%iprcparm(psb_f_type_)) - - case(psb_f_ilu_n_) - - if (allocated(p%av)) then - if (size(p%av) < psb_bp_ilu_avsz) then - do i=1,size(p%av) - call p%av(i)%free() - enddo - deallocate(p%av,stat=info) - endif - end if - if (.not.allocated(p%av)) then - allocate(p%av(psb_max_avsz),stat=info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - endif - - nrow_a = psb_cd_get_local_rows(desc_a) - nztota = a%get_nzeros() - - n_col = psb_cd_get_local_cols(desc_a) - nhalo = n_col-nrow_a - n_row = p%desc_data%matrix_data(psb_n_row_) - - allocate(lf,uf,stat=info) - if (info == 0) call lf%allocate(n_row,n_row,nztota) - if (info == 0) call uf%allocate(n_row,n_row,nztota) - - if(info/=0) then - info=4010 - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if (allocated(p%d)) then - if (size(p%d) < n_row) then - deallocate(p%d) - endif - endif - if (.not.allocated(p%d)) then - allocate(p%d(n_row),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - - endif - t3 = psb_wtime() - ! This is where we have no renumbering, thus no need - call psb_ilu_fct(a,lf,uf,p%d,info) - - if(info==0) then - call p%av(psb_l_pr_)%mv_from(lf) - call p%av(psb_u_pr_)%mv_from(uf) - call p%av(psb_l_pr_)%set_asb() - call p%av(psb_u_pr_)%set_asb() - call p%av(psb_l_pr_)%trim() - call p%av(psb_u_pr_)%trim() - else - info=4010 - ch_err='psb_ilu_fct' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case(psb_f_none_) - info=4010 - ch_err='Inconsistent prec psb_f_none_' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - - case default - info=4010 - ch_err='Unknown psb_f_type_' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - 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_dbjac_bld - - diff --git a/prec/psb_ddiagsc_bld.f90 b/prec/psb_ddiagsc_bld.f90 deleted file mode 100644 index 81c21e22..00000000 --- a/prec/psb_ddiagsc_bld.f90 +++ /dev/null @@ -1,120 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psb_ddiagsc_bld(a,desc_a,p,upd,info) - - use psb_base_mod - use psb_prec_mod, psb_protect_name => psb_ddiagsc_bld - Implicit None - - type(psb_d_sparse_mat), intent(in), target :: a - type(psb_desc_type), intent(in) :: desc_a - type(psb_dprec_type),intent(inout) :: p - character, intent(in) :: upd - integer, intent(out) :: info - - - ! Local scalars - Integer :: err, n_row, n_col,I,ictxt,& - & me,np,mglob, err_act - integer :: int_err(5) - - integer,parameter :: iroot=psb_root_,iout=60,ilout=40 - character(len=20) :: name, ch_err - - if(psb_get_errstatus() /= 0) return - info=0 - err=0 - call psb_erractionsave(err_act) - name = 'psb_diagsc_bld' - - info = 0 - int_err(1) = 0 - ictxt = psb_cd_get_context(desc_a) - n_row = psb_cd_get_local_rows(desc_a) - n_col = psb_cd_get_local_cols(desc_a) - mglob = psb_cd_get_global_rows(desc_a) - - call psb_info(ictxt, me, np) - - ! diagonal scaling - - call psb_realloc(n_col,p%d,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_realloc') - goto 9999 - end if - - ! - ! Retrieve the diagonal entries of the matrix A - ! - call a%get_diag(p%d,info) - if(info /= 0) then - info=4010 - ch_err='psb_sp_getdiag' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ! - ! Copy into p%desc_data the descriptor associated to A - ! - call psb_cdcpy(desc_a,p%desc_Data,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_cdcpy') - goto 9999 - end if - - ! - ! The i-th diagonal entry of the preconditioner is set to one if the - ! corresponding entry a_ii of the sparse matrix A is zero; otherwise - ! it is set to one/a_ii - ! - do i=1,n_row - if (p%d(i) == dzero) then - p%d(i) = done - else - p%d(i) = done/p%d(i) - endif - end do - - 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_ddiagsc_bld - diff --git a/prec/psb_dgprec_aply.f90 b/prec/psb_dgprec_aply.f90 deleted file mode 100644 index 6d37a0eb..00000000 --- a/prec/psb_dgprec_aply.f90 +++ /dev/null @@ -1,135 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psb_dgprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) - ! - ! Compute Y <- beta*Y + alpha*K^-1 X - ! where K is a a basic preconditioner stored in prec - ! - - use psb_base_mod - use psb_prec_mod, psb_protect_name => psb_dgprec_aply - implicit none - - type(psb_desc_type),intent(in) :: desc_data - type(psb_dprec_type), intent(in) :: prec - real(psb_dpk_),intent(in) :: x(:) - real(psb_dpk_),intent(inout) :: y(:) - real(psb_dpk_),intent(in) :: alpha,beta - character(len=1) :: trans - real(psb_dpk_),target :: work(:) - integer, intent(out) :: info - - ! Local variables - integer :: n_row,int_err(5) - real(psb_dpk_), pointer :: ww(:) - character :: trans_ - integer :: ictxt,np,me, err_act - character(len=20) :: name, ch_err - - name='psb_dgprec_aply' - info = 0 - call psb_erractionsave(err_act) - - ictxt=desc_data%matrix_data(psb_ctxt_) - call psb_info(ictxt, me, np) - - trans_ = psb_toupper(trans) - - select case(trans_) - case('N') - case('T','C') - case default - info=40 - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - select case(prec%iprcparm(psb_p_type_)) - - case(psb_noprec_) - - call psb_geaxpby(alpha,x,beta,y,desc_data,info) - - case(psb_diag_) - - if (size(work) >= size(x)) then - ww => work - else - allocate(ww(size(x)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - end if - - n_row=desc_data%matrix_data(psb_n_row_) - ww(1:n_row) = x(1:n_row)*prec%d(1:n_row) - call psb_geaxpby(alpha,ww,beta,y,desc_data,info) - - if (size(work) < size(x)) then - deallocate(ww,stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Deallocate') - goto 9999 - end if - end if - - case(psb_bjac_) - - call psb_bjac_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info) - if(info /= 0) then - info=4010 - ch_err='psb_bjac_aply' - goto 9999 - end if - - case default - info = 4001 - call psb_errpush(info,name,a_err='Invalid prectype') - goto 9999 - end select - - 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_dgprec_aply - diff --git a/prec/psb_dprc_aply.f90 b/prec/psb_dprc_aply.f90 index cb3b1124..a3830b69 100644 --- a/prec/psb_dprc_aply.f90 +++ b/prec/psb_dprc_aply.f90 @@ -73,13 +73,12 @@ subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans, work) end if - if (.not.allocated(prec%dprec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 end if -!!$ call psb_gprec_aply(done,prec,x,dzero,y,desc_data,trans_,work_,info) - call prec%dprec%apply(done,x,dzero,y,desc_data,info,trans_,work=work_) + call prec%prec%apply(done,x,dzero,y,desc_data,info,trans_,work=work_) if (present(work)) then else deallocate(work_) @@ -153,7 +152,7 @@ subroutine psb_dprc_aply1(prec,x,desc_data,info,trans) integer :: ictxt,np,me, err_act real(psb_dpk_), pointer :: WW(:), w1(:) character(len=20) :: name - name='psb_dprec_aply1' + name='psb_prc_aply1' info = 0 call psb_erractionsave(err_act) @@ -166,7 +165,7 @@ subroutine psb_dprc_aply1(prec,x,desc_data,info,trans) trans_='N' end if - if (.not.allocated(prec%dprec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 @@ -176,7 +175,7 @@ subroutine psb_dprc_aply1(prec,x,desc_data,info,trans) call psb_errpush(4010,name,a_err='Allocate') goto 9999 end if - call prec%dprec%apply(done,x,dzero,ww,desc_data,info,trans_,work=w1) + call prec%prec%apply(done,x,dzero,ww,desc_data,info,trans_,work=w1) if(info /=0) goto 9999 x(:) = ww(:) deallocate(ww,W1) diff --git a/prec/psb_dprecbld.f90 b/prec/psb_dprecbld.f90 index 7e5bfe23..9268a1db 100644 --- a/prec/psb_dprecbld.f90 +++ b/prec/psb_dprecbld.f90 @@ -81,74 +81,26 @@ subroutine psb_dprecbld(a,desc_a,p,info,upd) ! ALso should define symbolic names for the preconditioners. ! - if (.false.) then -!!$ call psb_check_def(p%iprcparm(psb_p_type_),'base_prec',& -!!$ & psb_diag_,is_legal_prec) -!!$ -!!$ call psb_nullify_desc(p%desc_data) -!!$ -!!$ select case(p%iprcparm(psb_p_type_)) -!!$ case (psb_noprec_) -!!$ ! Do nothing. -!!$ call psb_cdcpy(desc_a,p%desc_data,info) -!!$ if(info /= 0) then -!!$ info=4010 -!!$ ch_err='psb_cdcpy' -!!$ call psb_errpush(info,name,a_err=ch_err) -!!$ goto 9999 -!!$ end if -!!$ -!!$ case (psb_diag_) -!!$ -!!$ call psb_diagsc_bld(a,desc_a,p,upd_,info) -!!$ if(info /= 0) then -!!$ info=4010 -!!$ ch_err='psb_diagsc_bld' -!!$ call psb_errpush(info,name,a_err=ch_err) -!!$ goto 9999 -!!$ end if -!!$ -!!$ case (psb_bjac_) -!!$ -!!$ call psb_check_def(p%iprcparm(psb_f_type_),'fact',& -!!$ & psb_f_ilu_n_,is_legal_ml_fact) -!!$ -!!$ call psb_bjac_bld(a,desc_a,p,upd_,info) -!!$ -!!$ if(info /= 0) then -!!$ call psb_errpush(4010,name,a_err='psb_bjac_bld') -!!$ goto 9999 -!!$ end if -!!$ -!!$ case default -!!$ info=4010 -!!$ ch_err='Unknown psb_p_type_' -!!$ call psb_errpush(info,name,a_err=ch_err) -!!$ goto 9999 -!!$ -!!$ end select - else - if (.not.allocated(p%dprec)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - - call p%dprec%precbld(a,desc_a,info,upd) - if (info /= 0) goto 9999 - + if (.not.allocated(p%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 end if + + call p%prec%precbld(a,desc_a,info,upd) + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) return 9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() return + end if + return - end subroutine psb_dprecbld +end subroutine psb_dprecbld diff --git a/prec/psb_dprecinit.f90 b/prec/psb_dprecinit.f90 index 381fec46..897154a1 100644 --- a/prec/psb_dprecinit.f90 +++ b/prec/psb_dprecinit.f90 @@ -43,57 +43,28 @@ subroutine psb_dprecinit(p,ptype,info) info = 0 - if (.false.) then -!!$ call psb_realloc(psb_ifpsz,p%iprcparm,info) -!!$ if (info == 0) call psb_realloc(psb_rfpsz,p%rprcparm,info) -!!$ if (info /= 0) return -!!$ -!!$ select case(psb_toupper(ptype(1:len_trim(ptype)))) -!!$ case ('NONE','NOPREC') -!!$ p%iprcparm(:) = 0 -!!$ p%iprcparm(psb_p_type_) = psb_noprec_ -!!$ p%iprcparm(psb_f_type_) = psb_f_none_ -!!$ -!!$ case ('DIAG') -!!$ p%iprcparm(:) = 0 -!!$ p%iprcparm(psb_p_type_) = psb_diag_ -!!$ p%iprcparm(psb_f_type_) = psb_f_none_ -!!$ -!!$ case ('BJAC') -!!$ p%iprcparm(:) = 0 -!!$ p%iprcparm(psb_p_type_) = psb_bjac_ -!!$ p%iprcparm(psb_f_type_) = psb_f_ilu_n_ -!!$ p%iprcparm(psb_ilu_fill_in_) = 0 -!!$ -!!$ case default -!!$ write(0,*) 'Unknown preconditioner type request "',ptype,'"' -!!$ info = 2 -!!$ -!!$ end select - else - if (allocated(p%dprec) ) then - call p%dprec%precfree(info) - if (info == 0) deallocate(p%dprec,stat=info) - if (info /= 0) return - end if - - select case(psb_toupper(ptype(1:len_trim(ptype)))) - case ('NONE','NOPREC') - - allocate(psb_d_null_prec_type :: p%dprec, stat=info) - - case ('DIAG') - allocate(psb_d_diag_prec_type :: p%dprec, stat=info) - - case ('BJAC') - allocate(psb_d_bjac_prec_type :: p%dprec, stat=info) - - case default - write(0,*) 'Unknown preconditioner type request "',ptype,'"' - info = 2 - - end select - if (info == 0) call p%dprec%precinit(info) - + if (allocated(p%prec) ) then + call p%prec%precfree(info) + if (info == 0) deallocate(p%prec,stat=info) + if (info /= 0) return end if + + select case(psb_toupper(ptype(1:len_trim(ptype)))) + case ('NONE','NOPREC') + + allocate(psb_d_null_prec_type :: p%prec, stat=info) + + case ('DIAG') + allocate(psb_d_diag_prec_type :: p%prec, stat=info) + + case ('BJAC') + allocate(psb_d_bjac_prec_type :: p%prec, stat=info) + + case default + write(0,*) 'Unknown preconditioner type request "',ptype,'"' + info = 2 + + end select + if (info == 0) call p%prec%precinit(info) + end subroutine psb_dprecinit diff --git a/prec/psb_dprecset.f90 b/prec/psb_dprecset.f90 index 54989e56..0c56e424 100644 --- a/prec/psb_dprecset.f90 +++ b/prec/psb_dprecset.f90 @@ -40,35 +40,15 @@ subroutine psb_dprecseti(p,what,val,info) character(len=20) :: name='precset' info = 0 - if (.not.allocated(p%dprec)) then + if (.not.allocated(p%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") return !!$ goto 9999 end if - call p%dprec%precset(what,val,info) -!!$ select case(what) -!!$ case (psb_f_type_) -!!$ if (p%iprcparm(psb_p_type_) /= psb_bjac_) then -!!$ write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& -!!$ & 'ignoring user specification' -!!$ return -!!$ endif -!!$ p%iprcparm(psb_f_type_) = val -!!$ -!!$ case (psb_ilu_fill_in_) -!!$ if ((p%iprcparm(psb_p_type_) /= psb_bjac_).or.(p%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then -!!$ write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& -!!$ & 'ignoring user specification' -!!$ return -!!$ endif -!!$ p%iprcparm(psb_ilu_fill_in_) = val -!!$ -!!$ case default -!!$ write(0,*) 'WHAT is invalid, ignoring user specification' -!!$ -!!$ end select + call p%prec%precset(what,val,info) + return end subroutine psb_dprecseti @@ -86,39 +66,15 @@ subroutine psb_dprecsetd(p,what,val,info) character(len=20) :: name='precset' info = 0 - if (.not.allocated(p%dprec)) then + if (.not.allocated(p%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") return !!$ goto 9999 end if - call p%dprec%precset(what,val,info) -!!$! -!!$! This will have to be changed if/when we put together an ILU(eps) -!!$! factorization. -!!$! -!!$ select case(what) -!!$ case (psb_f_type_) -!!$ if (p%iprcparm(psb_p_type_) /= psb_bjac_) then -!!$ write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& -!!$ & 'ignoring user specification' -!!$ return -!!$ endif -!!$ p%iprcparm(psb_f_type_) = val -!!$ -!!$ case (psb_ilu_fill_in_) -!!$ if ((p%iprcparm(psb_p_type_) /= psb_bjac_).or.(p%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then -!!$ write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& -!!$ & 'ignoring user specification' -!!$ return -!!$ endif -!!$ p%iprcparm(psb_ilu_fill_in_) = val -!!$ -!!$ case default -!!$ write(0,*) 'WHAT is invalid, ignoring user specification' -!!$ -!!$ end select + call p%prec%precset(what,val,info) + return end subroutine psb_dprecsetd diff --git a/prec/psb_prec_type.f03 b/prec/psb_prec_type.f03 index a12c1ac0..596781eb 100644 --- a/prec/psb_prec_type.f03 +++ b/prec/psb_prec_type.f03 @@ -64,21 +64,28 @@ module psb_prec_type integer, parameter :: psb_max_avsz=psb_bp_ilu_avsz + type psb_s_base_prec_type + contains + procedure, pass(prec) :: apply => s_base_apply + procedure, pass(prec) :: precbld => s_base_precbld + procedure, pass(prec) :: s_base_precseti + procedure, pass(prec) :: s_base_precsetr + procedure, pass(prec) :: s_base_precsetc + procedure, pass(prec) :: sizeof => s_base_sizeof + generic, public :: precset => s_base_precseti, s_base_precsetr, s_base_precsetc + procedure, pass(prec) :: precinit => s_base_precinit + procedure, pass(prec) :: precfree => s_base_precfree + procedure, pass(prec) :: precdescr => s_base_precdescr + end type psb_s_base_prec_type + type psb_sprec_type - type(psb_s_sparse_mat), allocatable :: av(:) - real(psb_spk_), allocatable :: d(:) - type(psb_desc_type) :: desc_data - integer, allocatable :: iprcparm(:) - real(psb_spk_), allocatable :: rprcparm(:) - integer, allocatable :: perm(:), invperm(:) - integer :: prec + class(psb_s_base_prec_type), allocatable :: prec contains procedure, pass(prec) :: s_apply2v procedure, pass(prec) :: s_apply1v generic, public :: apply => s_apply2v, s_apply1v end type psb_sprec_type - type psb_d_base_prec_type contains procedure, pass(prec) :: apply => d_base_apply @@ -94,36 +101,52 @@ module psb_prec_type end type psb_d_base_prec_type type psb_dprec_type - class(psb_d_base_prec_type), allocatable :: dprec + class(psb_d_base_prec_type), allocatable :: prec contains procedure, pass(prec) :: d_apply2v procedure, pass(prec) :: d_apply1v generic, public :: apply => d_apply2v, d_apply1v end type psb_dprec_type + + type psb_c_base_prec_type + contains + procedure, pass(prec) :: apply => c_base_apply + procedure, pass(prec) :: precbld => c_base_precbld + procedure, pass(prec) :: c_base_precseti + procedure, pass(prec) :: c_base_precsetr + procedure, pass(prec) :: c_base_precsetc + procedure, pass(prec) :: sizeof => c_base_sizeof + generic, public :: precset => c_base_precseti, c_base_precsetr, c_base_precsetc + procedure, pass(prec) :: precinit => c_base_precinit + procedure, pass(prec) :: precfree => c_base_precfree + procedure, pass(prec) :: precdescr => c_base_precdescr + end type psb_c_base_prec_type + type psb_cprec_type - type(psb_c_sparse_mat), allocatable :: av(:) - complex(psb_spk_), allocatable :: d(:) - type(psb_desc_type) :: desc_data - integer, allocatable :: iprcparm(:) - real(psb_spk_), allocatable :: rprcparm(:) - integer, allocatable :: perm(:), invperm(:) - integer :: prec + class(psb_c_base_prec_type), allocatable :: prec contains procedure, pass(prec) :: c_apply2v procedure, pass(prec) :: c_apply1v generic, public :: apply => c_apply2v, c_apply1v end type psb_cprec_type - + type psb_z_base_prec_type + contains + procedure, pass(prec) :: apply => z_base_apply + procedure, pass(prec) :: precbld => z_base_precbld + procedure, pass(prec) :: z_base_precseti + procedure, pass(prec) :: z_base_precsetr + procedure, pass(prec) :: z_base_precsetc + procedure, pass(prec) :: sizeof => z_base_sizeof + generic, public :: precset => z_base_precseti, z_base_precsetr, z_base_precsetc + procedure, pass(prec) :: precinit => z_base_precinit + procedure, pass(prec) :: precfree => z_base_precfree + procedure, pass(prec) :: precdescr => z_base_precdescr + end type psb_z_base_prec_type + type psb_zprec_type - type(psb_z_sparse_mat), allocatable :: av(:) - complex(psb_dpk_), allocatable :: d(:) - type(psb_desc_type) :: desc_data - integer, allocatable :: iprcparm(:) - real(psb_dpk_), allocatable :: rprcparm(:) - integer, allocatable :: perm(:), invperm(:) - integer :: prec + class(psb_z_base_prec_type), allocatable :: prec contains procedure, pass(prec) :: z_apply2v procedure, pass(prec) :: z_apply1v @@ -165,7 +188,6 @@ module psb_prec_type - interface psb_precaply subroutine psb_sprc_aply(prec,x,y,desc_data,info,trans,work) use psb_base_mod, only : psb_desc_type, psb_spk_ @@ -259,7 +281,7 @@ contains use psb_base_mod type(psb_dprec_type), intent(in) :: p integer, intent(in), optional :: iout - integer :: iout_ + integer :: iout_, info character(len=20) :: name='prec_descr' if (present(iout)) then @@ -268,42 +290,42 @@ contains iout_ = 6 end if - if (.not.allocated(p%dprec)) then + if (.not.allocated(p%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") end if - call p%dprec%precdescr(iout) + call p%prec%precdescr(iout) end subroutine psb_file_prec_descr subroutine psb_sfile_prec_descr(p,iout) + use psb_base_mod type(psb_sprec_type), intent(in) :: p integer, intent(in), optional :: iout - integer :: iout_ + integer :: iout_,info + character(len=20) :: name='prec_descr' if (present(iout)) then iout_ = iout else iout_ = 6 end if - - write(iout_,*) 'Preconditioner description' - select case(p%iprcparm(psb_p_type_)) - case(psb_noprec_) - write(iout_,*) 'No preconditioning' - case(psb_diag_) - write(iout_,*) 'Diagonal scaling' - case(psb_bjac_) - write(iout_,*) 'Block Jacobi with: ',& - & fact_names(p%iprcparm(psb_f_type_)) - end select + + if (.not.allocated(p%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + end if + call p%prec%precdescr(iout) end subroutine psb_sfile_prec_descr + subroutine psb_cfile_prec_descr(p,iout) + use psb_base_mod type(psb_cprec_type), intent(in) :: p integer, intent(in), optional :: iout - integer :: iout_ + integer :: iout_,info + character(len=20) :: name='prec_descr' if (present(iout)) then iout_ = iout @@ -311,22 +333,21 @@ contains iout_ = 6 end if - write(iout_,*) 'Preconditioner description' - select case(p%iprcparm(psb_p_type_)) - case(psb_noprec_) - write(iout_,*) 'No preconditioning' - case(psb_diag_) - write(iout_,*) 'Diagonal scaling' - case(psb_bjac_) - write(iout_,*) 'Block Jacobi with: ',& - & fact_names(p%iprcparm(psb_f_type_)) - end select + if (.not.allocated(p%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + end if + call p%prec%precdescr(iout) + end subroutine psb_cfile_prec_descr + subroutine psb_zfile_prec_descr(p,iout) + use psb_base_mod type(psb_zprec_type), intent(in) :: p integer, intent(in), optional :: iout - integer :: iout_ + integer :: iout_,info + character(len=20) :: name='prec_descr' if (present(iout)) then iout_ = iout @@ -334,16 +355,12 @@ contains iout_ = 6 end if - write(iout_,*) 'Preconditioner description' - select case(p%iprcparm(psb_p_type_)) - case(psb_noprec_) - write(iout_,*) 'No preconditioning' - case(psb_diag_) - write(iout_,*) 'Diagonal scaling' - case(psb_bjac_) - write(iout_,*) 'Block Jacobi with: ',& - & fact_names(p%iprcparm(psb_f_type_)) - end select + if (.not.allocated(p%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + end if + call p%prec%precdescr(iout) + end subroutine psb_zfile_prec_descr @@ -436,40 +453,12 @@ contains me=-1 - ! Actually we migh just deallocate the top level array, except - ! for the inner UMFPACK or SLU stuff - - if (allocated(p%d)) then - deallocate(p%d,stat=info) - end if - - if (allocated(p%av)) then - do i=1,size(p%av) - call p%av(i)%free() - enddo - deallocate(p%av,stat=info) - end if - - if (allocated(p%desc_data%matrix_data)) & - & call psb_cdfree(p%desc_data,info) - - if (allocated(p%rprcparm)) then - deallocate(p%rprcparm,stat=info) - end if - - if (allocated(p%perm)) then - deallocate(p%perm,stat=info) - endif - - if (allocated(p%invperm)) then - deallocate(p%invperm,stat=info) - endif - - if (allocated(p%iprcparm)) then - deallocate(p%iprcparm,stat=info) + if (allocated(p%prec)) then + call p%prec%precfree(info) + if (info /= 0) goto 9999 + deallocate(p%prec,stat=info) + if (info /= 0) goto 9999 end if - call psb_nullify_prec(p) - call psb_erractionrestore(err_act) return @@ -486,9 +475,6 @@ contains subroutine psb_nullify_sprec(p) type(psb_sprec_type), intent(inout) :: p -!!$ nullify(p%av,p%d,p%iprcparm,p%rprcparm,p%perm,p%invperm,p%mlia,& -!!$ & p%nlaggr,p%base_a,p%base_desc,p%dorig,p%desc_data, p%desc_ac) - end subroutine psb_nullify_sprec subroutine psb_d_precfree(p,info) @@ -504,11 +490,10 @@ contains me=-1 - - if (allocated(p%dprec)) then - call p%dprec%precfree(info) + if (allocated(p%prec)) then + call p%prec%precfree(info) if (info /= 0) goto 9999 - deallocate(p%dprec,stat=info) + deallocate(p%prec,stat=info) if (info /= 0) goto 9999 end if call psb_erractionrestore(err_act) @@ -541,36 +526,14 @@ contains name = 'psb_precfree' call psb_erractionsave(err_act) - if (allocated(p%d)) then - deallocate(p%d,stat=info) - end if - - if (allocated(p%av)) then - do i=1,size(p%av) - call p%av(i)%free() - enddo - deallocate(p%av,stat=info) - - end if - if (allocated(p%desc_data%matrix_data)) & - & call psb_cdfree(p%desc_data,info) - - if (allocated(p%rprcparm)) then - deallocate(p%rprcparm,stat=info) - end if - - if (allocated(p%perm)) then - deallocate(p%perm,stat=info) - endif - - if (allocated(p%invperm)) then - deallocate(p%invperm,stat=info) - endif + me=-1 - if (allocated(p%iprcparm)) then - deallocate(p%iprcparm,stat=info) + if (allocated(p%prec)) then + call p%prec%precfree(info) + if (info /= 0) goto 9999 + deallocate(p%prec,stat=info) + if (info /= 0) goto 9999 end if - call psb_nullify_prec(p) call psb_erractionrestore(err_act) return @@ -600,36 +563,14 @@ contains name = 'psb_precfree' call psb_erractionsave(err_act) - if (allocated(p%d)) then - deallocate(p%d,stat=info) - end if - - if (allocated(p%av)) then - do i=1,size(p%av) - call p%av(i)%free() - enddo - deallocate(p%av,stat=info) - - end if - if (allocated(p%desc_data%matrix_data)) & - & call psb_cdfree(p%desc_data,info) - - if (allocated(p%rprcparm)) then - deallocate(p%rprcparm,stat=info) - end if - - if (allocated(p%perm)) then - deallocate(p%perm,stat=info) - endif - - if (allocated(p%invperm)) then - deallocate(p%invperm,stat=info) - endif + me=-1 - if (allocated(p%iprcparm)) then - deallocate(p%iprcparm,stat=info) + if (allocated(p%prec)) then + call p%prec%precfree(info) + if (info /= 0) goto 9999 + deallocate(p%prec,stat=info) + if (info /= 0) goto 9999 end if - call psb_nullify_prec(p) call psb_erractionrestore(err_act) return @@ -645,7 +586,6 @@ contains subroutine psb_nullify_zprec(p) type(psb_zprec_type), intent(inout) :: p - end subroutine psb_nullify_zprec @@ -675,8 +615,8 @@ contains integer :: i val = 0 - if (allocated(prec%dprec)) then - val = val + prec%dprec%sizeof() + if (allocated(prec%prec)) then + val = val + prec%prec%sizeof() end if end function psb_dprec_sizeof @@ -687,16 +627,9 @@ contains integer :: i val = 0 - if (allocated(prec%iprcparm)) val = val + psb_sizeof_int * size(prec%iprcparm) - if (allocated(prec%rprcparm)) val = val + psb_sizeof_sp * size(prec%rprcparm) - if (allocated(prec%d)) val = val + psb_sizeof_sp * size(prec%d) - if (allocated(prec%perm)) val = val + psb_sizeof_int * size(prec%perm) - if (allocated(prec%invperm)) val = val + psb_sizeof_int * size(prec%invperm) - val = val + psb_sizeof(prec%desc_data) - if (allocated(prec%av)) then - do i=1,size(prec%av) - val = val + psb_sizeof(prec%av(i)) - end do + + if (allocated(prec%prec)) then + val = val + prec%prec%sizeof() end if end function psb_sprec_sizeof @@ -708,16 +641,8 @@ contains integer :: i val = 0 - if (allocated(prec%iprcparm)) val = val + psb_sizeof_int * size(prec%iprcparm) - if (allocated(prec%rprcparm)) val = val + psb_sizeof_dp * size(prec%rprcparm) - if (allocated(prec%d)) val = val + 2 * psb_sizeof_dp * size(prec%d) - if (allocated(prec%perm)) val = val + psb_sizeof_int * size(prec%perm) - if (allocated(prec%invperm)) val = val + psb_sizeof_int * size(prec%invperm) - val = val + psb_sizeof(prec%desc_data) - if (allocated(prec%av)) then - do i=1,size(prec%av) - val = val + psb_sizeof(prec%av(i)) - end do + if (allocated(prec%prec)) then + val = val + prec%prec%sizeof() end if end function psb_zprec_sizeof @@ -729,22 +654,13 @@ contains integer :: i val = 0 - if (allocated(prec%iprcparm)) val = val + psb_sizeof_int * size(prec%iprcparm) - if (allocated(prec%rprcparm)) val = val + psb_sizeof_sp * size(prec%rprcparm) - if (allocated(prec%d)) val = val + 2 * psb_sizeof_sp * size(prec%d) - if (allocated(prec%perm)) val = val + psb_sizeof_int * size(prec%perm) - if (allocated(prec%invperm)) val = val + psb_sizeof_int * size(prec%invperm) - val = val + psb_sizeof(prec%desc_data) - if (allocated(prec%av)) then - do i=1,size(prec%av) - val = val + psb_sizeof(prec%av(i)) - end do + if (allocated(prec%prec)) then + val = val + prec%prec%sizeof() end if end function psb_cprec_sizeof - - + subroutine s_apply2v(prec,x,y,desc_data,info,trans,work) use psb_base_mod type(psb_desc_type),intent(in) :: desc_data @@ -754,23 +670,56 @@ contains integer, intent(out) :: info character(len=1), optional :: trans real(psb_spk_),intent(inout), optional, target :: work(:) - Integer :: err_act - character(len=20) :: name='s_prec_apply' - + + character :: trans_ + real(psb_spk_), pointer :: work_(:) + integer :: ictxt,np,me,err_act + character(len=20) :: name + + name='s_apply2v' + info = 0 call psb_erractionsave(err_act) - select type(prec) - type is (psb_sprec_type) - call psb_precaply(prec,x,y,desc_data,info,trans,work) - class default - info = 700 - call psb_errpush(info,name) - goto 9999 - end select + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + if (present(trans)) then + trans_=trans + else + trans_='N' + end if + + if (present(work)) then + work_ => work + else + allocate(work_(4*psb_cd_get_local_cols(desc_data)),stat=info) + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + call prec%prec%apply(sone,x,szero,y,desc_data,info,trans_,work=work_) + if (present(work)) then + else + deallocate(work_,stat=info) + if (info /= 0) then + info = 4010 + call psb_errpush(info,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 @@ -780,6 +729,7 @@ contains return end subroutine s_apply2v + subroutine s_apply1v(prec,x,desc_data,info,trans) use psb_base_mod type(psb_desc_type),intent(in) :: desc_data @@ -787,32 +737,61 @@ contains real(psb_spk_),intent(inout) :: x(:) integer, intent(out) :: info character(len=1), optional :: trans - Integer :: err_act - character(len=20) :: name='s_prec_apply' + character :: trans_ + integer :: ictxt,np,me, err_act + real(psb_spk_), pointer :: WW(:), w1(:) + character(len=20) :: name + name='s_apply1v' + info = 0 call psb_erractionsave(err_act) - select type(prec) - type is (psb_sprec_type) - call psb_precaply(prec,x,desc_data,info,trans) - class default - info = 700 - call psb_errpush(info,name) - goto 9999 - end select + + ictxt=psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + if (present(trans)) then + trans_=psb_toupper(trans) + else + trans_='N' + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + allocate(ww(size(x)),w1(size(x)),stat=info) + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + call prec%prec%apply(sone,x,szero,ww,desc_data,info,trans_,work=w1) + if(info /=0) goto 9999 + x(:) = ww(:) + deallocate(ww,W1,stat=info) + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err='DeAllocate') + goto 9999 + end if + call psb_erractionrestore(err_act) return 9999 continue + call psb_errpush(info,name) call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then call psb_error() return end if return + end subroutine s_apply1v + subroutine d_apply2v(prec,x,y,desc_data,info,trans,work) use psb_base_mod type(psb_desc_type),intent(in) :: desc_data @@ -828,7 +807,7 @@ contains integer :: ictxt,np,me,err_act character(len=20) :: name - name='psb_d_prc_apply' + name='d_apply2v' info = 0 call psb_erractionsave(err_act) @@ -853,12 +832,12 @@ contains end if - if (.not.allocated(prec%dprec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 end if - call prec%dprec%apply(done,x,dzero,y,desc_data,info,trans_,work=work_) + call prec%prec%apply(done,x,dzero,y,desc_data,info,trans_,work=work_) if (present(work)) then else deallocate(work_,stat=info) @@ -894,7 +873,7 @@ contains integer :: ictxt,np,me, err_act real(psb_dpk_), pointer :: WW(:), w1(:) character(len=20) :: name - name='psb_d_apply1' + name='d_apply1v' info = 0 call psb_erractionsave(err_act) @@ -907,7 +886,7 @@ contains trans_='N' end if - if (.not.allocated(prec%dprec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 @@ -918,7 +897,7 @@ contains call psb_errpush(info,name,a_err='Allocate') goto 9999 end if - call prec%dprec%apply(done,x,dzero,ww,desc_data,info,trans_,work=w1) + call prec%prec%apply(done,x,dzero,ww,desc_data,info,trans_,work=w1) if(info /=0) goto 9999 x(:) = ww(:) deallocate(ww,W1,stat=info) @@ -942,33 +921,67 @@ contains return end subroutine d_apply1v + + subroutine c_apply2v(prec,x,y,desc_data,info,trans,work) use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_cprec_type), intent(in) :: prec - complex(psb_spk_),intent(in) :: x(:) - complex(psb_spk_),intent(inout) :: y(:) + class(psb_cprec_type), intent(in) :: prec + complex(psb_spk_),intent(in) :: x(:) + 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 - character(len=20) :: name='s_prec_apply' - + + character :: trans_ + complex(psb_spk_), pointer :: work_(:) + integer :: ictxt,np,me,err_act + character(len=20) :: name + + name='c_apply2v' + info = 0 call psb_erractionsave(err_act) - select type(prec) - type is (psb_cprec_type) - call psb_precaply(prec,x,y,desc_data,info,trans,work) - class default - info = 700 - call psb_errpush(info,name) - goto 9999 - end select + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + if (present(trans)) then + trans_=trans + else + trans_='N' + end if + + if (present(work)) then + work_ => work + else + allocate(work_(4*psb_cd_get_local_cols(desc_data)),stat=info) + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + call prec%prec%apply(cone,x,czero,y,desc_data,info,trans_,work=work_) + if (present(work)) then + else + deallocate(work_,stat=info) + if (info /= 0) then + info = 4010 + call psb_errpush(info,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 @@ -978,32 +991,59 @@ contains return end subroutine c_apply2v + subroutine c_apply1v(prec,x,desc_data,info,trans) use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_cprec_type), intent(in) :: prec - complex(psb_spk_),intent(inout) :: x(:) + class(psb_cprec_type), intent(in) :: prec + complex(psb_spk_),intent(inout) :: x(:) integer, intent(out) :: info character(len=1), optional :: trans - Integer :: err_act - character(len=20) :: name='c_prec_apply' + character :: trans_ + integer :: ictxt,np,me, err_act + complex(psb_spk_), pointer :: WW(:), w1(:) + character(len=20) :: name + name='c_apply1v' + info = 0 call psb_erractionsave(err_act) - select type(prec) - type is (psb_cprec_type) - call psb_precaply(prec,x,desc_data,info,trans) - class default - info = 700 - call psb_errpush(info,name) - goto 9999 - end select + + ictxt=psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + if (present(trans)) then + trans_=psb_toupper(trans) + else + trans_='N' + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + allocate(ww(size(x)),w1(size(x)),stat=info) + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + call prec%prec%apply(cone,x,czero,ww,desc_data,info,trans_,work=w1) + if(info /=0) goto 9999 + x(:) = ww(:) + deallocate(ww,W1,stat=info) + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err='DeAllocate') + goto 9999 + end if + call psb_erractionrestore(err_act) return 9999 continue + call psb_errpush(info,name) call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then call psb_error() @@ -1012,33 +1052,67 @@ contains return end subroutine c_apply1v - + + subroutine z_apply2v(prec,x,y,desc_data,info,trans,work) use psb_base_mod type(psb_desc_type),intent(in) :: desc_data - class(psb_zprec_type), intent(in) :: prec - complex(psb_dpk_),intent(in) :: x(:) - complex(psb_dpk_),intent(inout) :: y(:) + class(psb_zprec_type), intent(in) :: prec + complex(psb_dpk_),intent(in) :: x(:) + 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 - character(len=20) :: name='z_prec_apply' - + + character :: trans_ + complex(psb_dpk_), pointer :: work_(:) + integer :: ictxt,np,me,err_act + character(len=20) :: name + + name='z_apply2v' + info = 0 call psb_erractionsave(err_act) - select type(prec) - type is (psb_zprec_type) - call psb_precaply(prec,x,y,desc_data,info,trans,work) - class default - info = 700 - call psb_errpush(info,name) - goto 9999 - end select + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + if (present(trans)) then + trans_=trans + else + trans_='N' + end if + + if (present(work)) then + work_ => work + else + allocate(work_(4*psb_cd_get_local_cols(desc_data)),stat=info) + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + call prec%prec%apply(zone,x,zzero,y,desc_data,info,trans_,work=work_) + if (present(work)) then + else + deallocate(work_,stat=info) + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err='DeAllocate') + goto 9999 + end if + end if + + call psb_erractionrestore(err_act) + return - call psb_erractionrestore(err_act) - return - 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -1046,34 +1120,61 @@ contains return end if return - + end subroutine z_apply2v + subroutine z_apply1v(prec,x,desc_data,info,trans) use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_zprec_type), intent(in) :: prec - complex(psb_dpk_),intent(inout) :: x(:) + class(psb_zprec_type), intent(in) :: prec + complex(psb_dpk_),intent(inout) :: x(:) integer, intent(out) :: info character(len=1), optional :: trans - Integer :: err_act - character(len=20) :: name='z_prec_apply' + character :: trans_ + integer :: ictxt,np,me, err_act + complex(psb_dpk_), pointer :: WW(:), w1(:) + character(len=20) :: name + name='z_apply1v' + info = 0 call psb_erractionsave(err_act) - select type(prec) - type is (psb_zprec_type) - call psb_precaply(prec,x,desc_data,info,trans) - class default - info = 700 - call psb_errpush(info,name) - goto 9999 - end select + + ictxt=psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + if (present(trans)) then + trans_=psb_toupper(trans) + else + trans_='N' + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + allocate(ww(size(x)),w1(size(x)),stat=info) + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + call prec%prec%apply(zone,x,zzero,ww,desc_data,info,trans_,work=w1) + if(info /=0) goto 9999 + x(:) = ww(:) + deallocate(ww,W1,stat=info) + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err='DeAllocate') + goto 9999 + end if + call psb_erractionrestore(err_act) return 9999 continue + call psb_errpush(info,name) call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then call psb_error() @@ -1084,18 +1185,18 @@ contains end subroutine z_apply1v - subroutine d_base_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) + subroutine s_base_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_base_prec_type), intent(in) :: prec - real(psb_dpk_),intent(in) :: alpha, beta - real(psb_dpk_),intent(in) :: x(:) - real(psb_dpk_),intent(inout) :: y(:) + class(psb_s_base_prec_type), intent(in) :: prec + real(psb_spk_),intent(in) :: alpha, beta + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) integer, intent(out) :: info character(len=1), optional :: trans - real(psb_dpk_),intent(inout), optional, target :: work(:) + real(psb_spk_),intent(inout), optional, target :: work(:) Integer :: err_act, nrow - character(len=20) :: name='d_base_prec_apply' + character(len=20) :: name='s_base_prec_apply' call psb_erractionsave(err_act) @@ -1118,17 +1219,17 @@ contains end if return - end subroutine d_base_apply + end subroutine s_base_apply - subroutine d_base_precinit(prec,info) + subroutine s_base_precinit(prec,info) use psb_base_mod Implicit None - class(psb_d_base_prec_type),intent(inout) :: prec + class(psb_s_base_prec_type),intent(inout) :: prec integer, intent(out) :: info Integer :: err_act, nrow - character(len=20) :: name='d_base_precinit' + character(len=20) :: name='s_base_precinit' call psb_erractionsave(err_act) @@ -1150,20 +1251,20 @@ contains return end if return - end subroutine d_base_precinit + end subroutine s_base_precinit - subroutine d_base_precbld(a,desc_a,prec,info,upd) + subroutine s_base_precbld(a,desc_a,prec,info,upd) use psb_base_mod Implicit None - type(psb_d_sparse_mat), intent(in), target :: a + type(psb_s_sparse_mat), intent(in), target :: a type(psb_desc_type), intent(in), target :: desc_a - class(psb_d_base_prec_type),intent(inout) :: prec + class(psb_s_base_prec_type),intent(inout) :: prec integer, intent(out) :: info character, intent(in), optional :: upd Integer :: err_act, nrow - character(len=20) :: name='d_base_precbld' + character(len=20) :: name='s_base_precbld' call psb_erractionsave(err_act) @@ -1185,19 +1286,19 @@ contains return end if return - end subroutine d_base_precbld + end subroutine s_base_precbld - subroutine d_base_precseti(prec,what,val,info) + subroutine s_base_precseti(prec,what,val,info) use psb_base_mod Implicit None - class(psb_d_base_prec_type),intent(inout) :: prec + class(psb_s_base_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_base_precseti' + character(len=20) :: name='s_base_precseti' call psb_erractionsave(err_act) @@ -1219,19 +1320,19 @@ contains return end if return - end subroutine d_base_precseti + end subroutine s_base_precseti - subroutine d_base_precsetr(prec,what,val,info) + subroutine s_base_precsetr(prec,what,val,info) use psb_base_mod Implicit None - class(psb_d_base_prec_type),intent(inout) :: prec + class(psb_s_base_prec_type),intent(inout) :: prec integer, intent(in) :: what - real(psb_dpk_), intent(in) :: val + real(psb_spk_), intent(in) :: val integer, intent(out) :: info Integer :: err_act, nrow - character(len=20) :: name='d_base_precsetr' + character(len=20) :: name='s_base_precsetr' call psb_erractionsave(err_act) @@ -1253,19 +1354,19 @@ contains return end if return - end subroutine d_base_precsetr + end subroutine s_base_precsetr - subroutine d_base_precsetc(prec,what,val,info) + subroutine s_base_precsetc(prec,what,val,info) use psb_base_mod Implicit None - class(psb_d_base_prec_type),intent(inout) :: prec + class(psb_s_base_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='d_base_precsetc' + character(len=20) :: name='s_base_precsetc' call psb_erractionsave(err_act) @@ -1287,18 +1388,18 @@ contains return end if return - end subroutine d_base_precsetc + end subroutine s_base_precsetc - subroutine d_base_precfree(prec,info) + subroutine s_base_precfree(prec,info) use psb_base_mod Implicit None - class(psb_d_base_prec_type), intent(inout) :: prec + class(psb_s_base_prec_type), intent(inout) :: prec integer, intent(out) :: info Integer :: err_act, nrow - character(len=20) :: name='d_base_precfree' + character(len=20) :: name='s_base_precfree' call psb_erractionsave(err_act) @@ -1321,19 +1422,19 @@ contains end if return - end subroutine d_base_precfree + end subroutine s_base_precfree - subroutine d_base_precdescr(prec,iout) + subroutine s_base_precdescr(prec,iout) use psb_base_mod Implicit None - class(psb_d_base_prec_type), intent(in) :: prec + class(psb_s_base_prec_type), intent(in) :: prec integer, intent(in), optional :: iout Integer :: err_act, nrow, info - character(len=20) :: name='d_base_precdescr' + character(len=20) :: name='s_base_precdescr' call psb_erractionsave(err_act) @@ -1356,17 +1457,873 @@ contains end if return - end subroutine d_base_precdescr + end subroutine s_base_precdescr - function d_base_sizeof(prec) result(val) + function s_base_sizeof(prec) result(val) use psb_base_mod - class(psb_d_base_prec_type), intent(in) :: prec + class(psb_s_base_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: val val = 0 return - end function d_base_sizeof + end function s_base_sizeof + + + subroutine d_base_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_base_prec_type), intent(in) :: prec + real(psb_dpk_),intent(in) :: alpha, beta + real(psb_dpk_),intent(in) :: x(:) + 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_base_prec_apply' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine d_base_apply + + subroutine d_base_precinit(prec,info) + + use psb_base_mod + Implicit None + + class(psb_d_base_prec_type),intent(inout) :: prec + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='d_base_precinit' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine d_base_precinit + + subroutine d_base_precbld(a,desc_a,prec,info,upd) + + use psb_base_mod + Implicit None + + type(psb_d_sparse_mat), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_d_base_prec_type),intent(inout) :: prec + integer, intent(out) :: info + character, intent(in), optional :: upd + Integer :: err_act, nrow + character(len=20) :: name='d_base_precbld' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine d_base_precbld + + subroutine d_base_precseti(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_d_base_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_base_precseti' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine d_base_precseti + + subroutine d_base_precsetr(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_d_base_prec_type),intent(inout) :: prec + integer, intent(in) :: what + real(psb_dpk_), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='d_base_precsetr' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine d_base_precsetr + + subroutine d_base_precsetc(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_d_base_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='d_base_precsetc' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine d_base_precsetc + + subroutine d_base_precfree(prec,info) + + use psb_base_mod + Implicit None + + class(psb_d_base_prec_type), intent(inout) :: prec + integer, intent(out) :: info + + Integer :: err_act, nrow + character(len=20) :: name='d_base_precfree' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine d_base_precfree + + + subroutine d_base_precdescr(prec,iout) + + use psb_base_mod + Implicit None + + class(psb_d_base_prec_type), intent(in) :: prec + integer, intent(in), optional :: iout + + Integer :: err_act, nrow, info + character(len=20) :: name='d_base_precdescr' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine d_base_precdescr + + + function d_base_sizeof(prec) result(val) + use psb_base_mod + class(psb_d_base_prec_type), intent(in) :: prec + integer(psb_long_int_k_) :: val + + val = 0 + return + end function d_base_sizeof + + + subroutine c_base_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_base_prec_type), intent(in) :: prec + complex(psb_spk_),intent(in) :: alpha, beta + complex(psb_spk_),intent(in) :: x(:) + 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_base_prec_apply' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_base_apply + + subroutine c_base_precinit(prec,info) + + use psb_base_mod + Implicit None + + class(psb_c_base_prec_type),intent(inout) :: prec + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='c_base_precinit' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine c_base_precinit + + subroutine c_base_precbld(a,desc_a,prec,info,upd) + + use psb_base_mod + Implicit None + + type(psb_c_sparse_mat), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_c_base_prec_type),intent(inout) :: prec + integer, intent(out) :: info + character, intent(in), optional :: upd + Integer :: err_act, nrow + character(len=20) :: name='c_base_precbld' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine c_base_precbld + + subroutine c_base_precseti(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_c_base_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_base_precseti' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine c_base_precseti + + subroutine c_base_precsetr(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_c_base_prec_type),intent(inout) :: prec + integer, intent(in) :: what + real(psb_spk_), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='c_base_precsetr' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine c_base_precsetr + + subroutine c_base_precsetc(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_c_base_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_base_precsetc' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine c_base_precsetc + + subroutine c_base_precfree(prec,info) + + use psb_base_mod + Implicit None + + class(psb_c_base_prec_type), intent(inout) :: prec + integer, intent(out) :: info + + Integer :: err_act, nrow + character(len=20) :: name='c_base_precfree' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_base_precfree + + + subroutine c_base_precdescr(prec,iout) + + use psb_base_mod + Implicit None + + class(psb_c_base_prec_type), intent(in) :: prec + integer, intent(in), optional :: iout + + Integer :: err_act, nrow, info + character(len=20) :: name='c_base_precdescr' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_base_precdescr + + + function c_base_sizeof(prec) result(val) + use psb_base_mod + class(psb_c_base_prec_type), intent(in) :: prec + integer(psb_long_int_k_) :: val + + val = 0 + return + end function c_base_sizeof + + + subroutine z_base_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_base_prec_type), intent(in) :: prec + complex(psb_dpk_),intent(in) :: alpha, beta + complex(psb_dpk_),intent(in) :: x(:) + 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_base_prec_apply' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_base_apply + + subroutine z_base_precinit(prec,info) + + use psb_base_mod + Implicit None + + class(psb_z_base_prec_type),intent(inout) :: prec + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='z_base_precinit' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine z_base_precinit + + subroutine z_base_precbld(a,desc_a,prec,info,upd) + + use psb_base_mod + Implicit None + + type(psb_z_sparse_mat), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_z_base_prec_type),intent(inout) :: prec + integer, intent(out) :: info + character, intent(in), optional :: upd + Integer :: err_act, nrow + character(len=20) :: name='z_base_precbld' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine z_base_precbld + + subroutine z_base_precseti(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_z_base_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_base_precseti' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine z_base_precseti + + subroutine z_base_precsetr(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_z_base_prec_type),intent(inout) :: prec + integer, intent(in) :: what + real(psb_dpk_), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='z_base_precsetr' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine z_base_precsetr + + subroutine z_base_precsetc(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_z_base_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='z_base_precsetc' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine z_base_precsetc + + subroutine z_base_precfree(prec,info) + + use psb_base_mod + Implicit None + + class(psb_z_base_prec_type), intent(inout) :: prec + integer, intent(out) :: info + + Integer :: err_act, nrow + character(len=20) :: name='z_base_precfree' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_base_precfree + + + subroutine z_base_precdescr(prec,iout) + + use psb_base_mod + Implicit None + + class(psb_z_base_prec_type), intent(in) :: prec + integer, intent(in), optional :: iout + + Integer :: err_act, nrow, info + character(len=20) :: name='z_base_precdescr' + + call psb_erractionsave(err_act) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 700 + call psb_errpush(info,name) + goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_base_precdescr + + + function z_base_sizeof(prec) result(val) + use psb_base_mod + class(psb_z_base_prec_type), intent(in) :: prec + integer(psb_long_int_k_) :: val + + val = 0 + return + end function z_base_sizeof + end module psb_prec_type diff --git a/prec/psb_s_bjacprec.f03 b/prec/psb_s_bjacprec.f03 new file mode 100644 index 00000000..b7554fb8 --- /dev/null +++ b/prec/psb_s_bjacprec.f03 @@ -0,0 +1,563 @@ +module psb_s_bjacprec + use psb_prec_type + + + type, extends(psb_s_base_prec_type) :: psb_s_bjac_prec_type + integer, allocatable :: iprcparm(:) + type(psb_s_sparse_mat), allocatable :: av(:) + real(psb_spk_), allocatable :: d(:) + contains + procedure, pass(prec) :: apply => s_bjac_apply + procedure, pass(prec) :: precbld => s_bjac_precbld + procedure, pass(prec) :: precinit => s_bjac_precinit + procedure, pass(prec) :: s_base_precseti => s_bjac_precseti + procedure, pass(prec) :: s_base_precsetr => s_bjac_precsetr + procedure, pass(prec) :: s_base_precsetc => s_bjac_precsetc + procedure, pass(prec) :: precfree => s_bjac_precfree + procedure, pass(prec) :: precdescr => s_bjac_precdescr + procedure, pass(prec) :: sizeof => s_bjac_sizeof + end type psb_s_bjac_prec_type + + + character(len=15), parameter, private :: & + & fact_names(0:2)=(/'None ','ILU(n) ',& + & 'ILU(eps) '/) + +contains + + + subroutine 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(in) :: 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 = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + + trans_ = psb_toupper(trans) + select case(trans_) + case('N','T','C') + ! Ok + case default + call psb_errpush(40,name) + goto 9999 + end select + + + n_row = psb_cd_get_local_rows(desc_data) + n_col = psb_cd_get_local_cols(desc_data) + + 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%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 /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + if (info /= 0) then + call psb_errpush(4010,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%d,choice=psb_none_,work=aux) + if(info ==0) 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(sone,prec%av(psb_u_pr_),x,szero,ww,desc_data,info,& + & trans=trans_,scale='L',diag=prec%d,choice=psb_none_, work=aux) + if(info ==0) 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 /=0) then + ch_err="psb_spsm" + goto 9999 + end if + + + case default + info = 4001 + 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 s_bjac_apply + + subroutine 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' + + call psb_erractionsave(err_act) + + info = 0 + call psb_realloc(psb_ifpsz,prec%iprcparm,info) + if (info /= 0) then + info = 4000 + 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 s_bjac_precinit + + + subroutine s_bjac_precbld(a,desc_a,prec,info,upd) + + use psb_base_mod + use psb_prec_mod + Implicit None + + type(psb_s_sparse_mat), 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 + + ! .. Local Scalars .. + integer :: i, m + integer :: int_err(5) + character :: trans, unitd + type(psb_s_csr_sparse_mat), allocatable :: lf, uf + 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 = 0 + + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + + m = a%get_nrows() + if (m < 0) then + info = 10 + 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 /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + endif + + nrow_a = psb_cd_get_local_rows(desc_a) + nztota = a%get_nzeros() + + n_col = psb_cd_get_local_cols(desc_a) + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == 0) call lf%allocate(n_row,n_row,nztota) + if (info == 0) call uf%allocate(n_row,n_row,nztota) + + if(info/=0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (allocated(prec%d)) then + if (size(prec%d) < n_row) then + deallocate(prec%d) + endif + endif + if (.not.allocated(prec%d)) then + allocate(prec%d(n_row),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + endif + ! This is where we have no renumbering, thus no need + call psb_ilu_fct(a,lf,uf,prec%d,info) + + if(info==0) 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() + else + info=4010 + ch_err='psb_ilu_fct' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + +!!$ call prec%av(psb_l_pr_)%print(30+me) +!!$ call prec%av(psb_u_pr_)%print(40+me) +!!$ do i=1,n_row +!!$ write(50+me,*) i,prec%d(i) +!!$ end do + + case(psb_f_none_) + info=4010 + ch_err='Inconsistent prec psb_f_none_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + + case default + info=4010 + ch_err='Unknown psb_f_type_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + 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 s_bjac_precbld + + subroutine 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 = 0 + 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(0,*) '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(0,*) '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(0,*) '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 s_bjac_precseti + + subroutine 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 + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='s_bjac_precset' + + call psb_erractionsave(err_act) + + info = 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 s_bjac_precsetr + + subroutine 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 + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='s_bjac_precset' + + call psb_erractionsave(err_act) + + info = 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 s_bjac_precsetc + + subroutine 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 = 0 + if (allocated(prec%av)) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + end if + if (allocated(prec%d)) then + deallocate(prec%d,stat=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 s_bjac_precfree + + + subroutine 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 = 0 + + 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 = 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 s_bjac_precdescr + + function s_bjac_sizeof(prec) result(val) + use psb_base_mod + 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 s_bjac_sizeof + +end module psb_s_bjacprec diff --git a/prec/psb_s_diagprec.f03 b/prec/psb_s_diagprec.f03 new file mode 100644 index 00000000..392f3f04 --- /dev/null +++ b/prec/psb_s_diagprec.f03 @@ -0,0 +1,352 @@ +module psb_s_diagprec + use psb_prec_type + + + type, extends(psb_s_base_prec_type) :: psb_s_diag_prec_type + real(psb_spk_), allocatable :: d(:) + contains + procedure, pass(prec) :: apply => s_diag_apply + procedure, pass(prec) :: precbld => s_diag_precbld + procedure, pass(prec) :: precinit => s_diag_precinit + procedure, pass(prec) :: s_base_precseti => s_diag_precseti + procedure, pass(prec) :: s_base_precsetr => s_diag_precsetr + procedure, pass(prec) :: s_base_precsetc => s_diag_precsetc + procedure, pass(prec) :: precfree => s_diag_precfree + procedure, pass(prec) :: precdescr => s_diag_precdescr + procedure, pass(prec) :: sizeof => s_diag_sizeof + end type psb_s_diag_prec_type + + +contains + + + subroutine 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(in) :: 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_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 = 0 + + nrow = psb_cd_get_local_rows(desc_data) + 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 /= 0) then + call psb_errpush(4025,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 /= 0) then + call psb_errpush(4010,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 s_diag_apply + + subroutine s_diag_precinit(prec,info) + + use psb_base_mod + Implicit None + + class(psb_s_diag_prec_type),intent(inout) :: prec + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='s_diag_precinit' + + call psb_erractionsave(err_act) + + info = 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 s_diag_precinit + + + subroutine s_diag_precbld(a,desc_a,prec,info,upd) + + use psb_base_mod + Implicit None + + type(psb_s_sparse_mat), 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 + Integer :: err_act, nrow,i + character(len=20) :: name='s_diag_precbld' + + call psb_erractionsave(err_act) + + info = 0 + nrow = psb_cd_get_local_cols(desc_a) + if (allocated(prec%d)) then + if (size(prec%d) < nrow) then + deallocate(prec%d,stat=info) + end if + end if + if ((info == 0).and.(.not.allocated(prec%d))) then + allocate(prec%d(nrow), stat=info) + end if + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + call a%get_diag(prec%d,info) + if (info /= 0) then + info = 4010 + 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 + + 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 s_diag_precbld + + subroutine s_diag_precseti(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_s_diag_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_diag_precset' + + call psb_erractionsave(err_act) + + info = 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 s_diag_precseti + + subroutine s_diag_precsetr(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_s_diag_prec_type),intent(inout) :: prec + integer, intent(in) :: what + real(psb_spk_), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='s_diag_precset' + + call psb_erractionsave(err_act) + + info = 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 s_diag_precsetr + + subroutine s_diag_precsetc(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_s_diag_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='s_diag_precset' + + call psb_erractionsave(err_act) + + info = 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 s_diag_precsetc + + subroutine s_diag_precfree(prec,info) + + use psb_base_mod + Implicit None + + class(psb_s_diag_prec_type), intent(inout) :: prec + integer, intent(out) :: info + + Integer :: err_act, nrow + character(len=20) :: name='s_diag_precset' + + call psb_erractionsave(err_act) + + info = 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 s_diag_precfree + + + subroutine s_diag_precdescr(prec,iout) + + use psb_base_mod + Implicit None + + class(psb_s_diag_prec_type), intent(in) :: prec + integer, intent(in), optional :: iout + + Integer :: err_act, nrow, info + character(len=20) :: name='s_diag_precdescr' + + integer :: iout_ + + call psb_erractionsave(err_act) + + info = 0 + + if (present(iout)) then + iout_ = iout + else + iout_ = 6 + end if + + write(iout_,*) 'Diagonal scaling' + + call psb_erractionsave(err_act) + + info = 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 s_diag_precdescr + + function s_diag_sizeof(prec) result(val) + use psb_base_mod + 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) + return + end function s_diag_sizeof + +end module psb_s_diagprec diff --git a/prec/psb_s_nullprec.f03 b/prec/psb_s_nullprec.f03 new file mode 100644 index 00000000..1feedcbc --- /dev/null +++ b/prec/psb_s_nullprec.f03 @@ -0,0 +1,293 @@ +module psb_s_nullprec + use psb_prec_type + + + type, extends(psb_s_base_prec_type) :: psb_s_null_prec_type + contains + procedure, pass(prec) :: apply => s_null_apply + procedure, pass(prec) :: precbld => s_null_precbld + procedure, pass(prec) :: precinit => s_null_precinit + procedure, pass(prec) :: s_base_precseti => s_null_precseti + procedure, pass(prec) :: s_base_precsetr => s_null_precsetr + procedure, pass(prec) :: s_base_precsetc => s_null_precsetc + procedure, pass(prec) :: precfree => s_null_precfree + procedure, pass(prec) :: precdescr => s_null_precdescr + procedure, pass(prec) :: sizeof => s_null_sizeof + end type psb_s_null_prec_type + + +contains + + + subroutine 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(in) :: 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) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 0 + + nrow = psb_cd_get_local_rows(desc_data) + 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 /= 0 ) then + info = 4010 + 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 s_null_apply + + + subroutine s_null_precinit(prec,info) + + use psb_base_mod + Implicit None + + class(psb_s_null_prec_type),intent(inout) :: prec + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='s_null_precinit' + + call psb_erractionsave(err_act) + + info = 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 s_null_precinit + + subroutine s_null_precbld(a,desc_a,prec,info,upd) + + use psb_base_mod + Implicit None + + type(psb_s_sparse_mat), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_s_null_prec_type),intent(inout) :: prec + integer, intent(out) :: info + character, intent(in), optional :: upd + Integer :: err_act, nrow + character(len=20) :: name='s_null_precbld' + + call psb_erractionsave(err_act) + + info = 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 s_null_precbld + + subroutine s_null_precseti(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_s_null_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_null_precset' + + call psb_erractionsave(err_act) + + info = 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 s_null_precseti + + subroutine s_null_precsetr(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_s_null_prec_type),intent(inout) :: prec + integer, intent(in) :: what + real(psb_spk_), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='s_null_precset' + + call psb_erractionsave(err_act) + + info = 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 s_null_precsetr + + subroutine s_null_precsetc(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_s_null_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='s_null_precset' + + call psb_erractionsave(err_act) + + info = 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 s_null_precsetc + + subroutine s_null_precfree(prec,info) + + use psb_base_mod + Implicit None + + class(psb_s_null_prec_type), intent(inout) :: prec + integer, intent(out) :: info + + Integer :: err_act, nrow + character(len=20) :: name='s_null_precset' + + call psb_erractionsave(err_act) + + info = 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 s_null_precfree + + + subroutine s_null_precdescr(prec,iout) + + use psb_base_mod + Implicit None + + class(psb_s_null_prec_type), intent(in) :: prec + integer, intent(in), optional :: iout + + Integer :: err_act, nrow, info + character(len=20) :: name='s_null_precset' + integer :: iout_ + + call psb_erractionsave(err_act) + + info = 0 + + if (present(iout)) then + iout_ = iout + else + iout_ = 6 + end if + + write(iout_,*) 'No preconditioning' + + 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 s_null_precdescr + + function 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 + + val = 0 + + return + end function s_null_sizeof + +end module psb_s_nullprec diff --git a/prec/psb_sbjac_aply.f90 b/prec/psb_sbjac_aply.f90 deleted file mode 100644 index 05810cbf..00000000 --- a/prec/psb_sbjac_aply.f90 +++ /dev/null @@ -1,158 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psb_sbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) - ! - ! Compute Y <- beta*Y + alpha*K^-1 X - ! where K is a a Block Jacobi preconditioner stored in prec - ! Note that desc_data may or may not be the same as prec%desc_data, - ! but since both are INTENT(IN) this should be legal. - ! - - use psb_base_mod - use psb_prec_mod, psb_protect_name => psb_sbjac_aply - implicit none - - type(psb_desc_type), intent(in) :: desc_data - type(psb_sprec_type), intent(in) :: prec - real(psb_spk_),intent(in) :: x(:) - real(psb_spk_),intent(inout) :: y(:) - real(psb_spk_),intent(in) :: alpha,beta - character(len=1) :: trans - real(psb_spk_),target :: work(:) - integer, intent(out) :: info - - ! 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, ch_err - - name='psb_bjac_aply' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = psb_cd_get_context(desc_data) - call psb_info(ictxt, me, np) - - - trans_ = psb_toupper(trans) - select case(trans_) - case('N','T','C') - ! Ok - case default - call psb_errpush(40,name) - goto 9999 - end select - - - n_row=desc_data%matrix_data(psb_n_row_) - n_col=desc_data%matrix_data(psb_n_col_) - - 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 /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - - endif - else - allocate(ww(n_col),aux(4*n_col),stat=info) - if (info /= 0) then - call psb_errpush(4010,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%d,choice=psb_none_,work=aux) - if(info /=0) goto 9999 - call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_, work=aux) - if(info /=0) goto 9999 - - case('T','C') - call psb_spsm(sone,prec%av(psb_u_pr_),x,szero,ww,desc_data,info,& - & trans=trans_,scale='L',diag=prec%d,choice=psb_none_, work=aux) - if(info /=0) goto 9999 - call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) - if(info /=0) goto 9999 - - end select - - - case default - info = 4001 - 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_sbjac_aply diff --git a/prec/psb_sbjac_bld.f90 b/prec/psb_sbjac_bld.f90 deleted file mode 100644 index 3e732b48..00000000 --- a/prec/psb_sbjac_bld.f90 +++ /dev/null @@ -1,181 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psb_sbjac_bld(a,desc_a,p,upd,info) - use psb_base_mod - use psb_prec_mod, psb_protect_name => psb_sbjac_bld - implicit none - ! - ! .. Scalar Arguments .. - integer, intent(out) :: info - ! .. array Arguments .. - type(psb_s_sparse_mat), intent(in), target :: a - type(psb_sprec_type), intent(inout) :: p - type(psb_desc_type), intent(in) :: desc_a - character, intent(in) :: upd - - ! .. Local Scalars .. - integer :: i, m - integer :: int_err(5) - character :: trans, unitd - type(psb_s_csr_sparse_mat), allocatable :: lf, uf - real(psb_dpk_) :: t1,t2,t3,t4,t5,t6, t7, t8 - integer nztota, err_act, n_row, nrow_a,n_col, nhalo - integer :: ictxt,np,me - character(len=20) :: name, ch_err - - - if(psb_get_errstatus() /= 0) return - info=0 - name='psb_sbjac_bld' - call psb_erractionsave(err_act) - - ictxt=psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - - m = a%get_nrows() - if (m < 0) then - info = 10 - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - trans = 'N' - unitd = 'U' - - call psb_cdcpy(desc_a,p%desc_data,info) - if(info /= 0) then - info=4010 - ch_err='psb_cdcpy' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - - select case(p%iprcparm(psb_f_type_)) - - case(psb_f_ilu_n_) - - if (allocated(p%av)) then - if (size(p%av) < psb_bp_ilu_avsz) then - do i=1,size(p%av) - call p%av(i)%free() - enddo - deallocate(p%av,stat=info) - endif - end if - if (.not.allocated(p%av)) then - allocate(p%av(psb_max_avsz),stat=info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - endif - - nrow_a = psb_cd_get_local_rows(desc_a) - nztota = a%get_nzeros() - - n_col = psb_cd_get_local_cols(desc_a) - nhalo = n_col-nrow_a - n_row = p%desc_data%matrix_data(psb_n_row_) - - allocate(lf,uf,stat=info) - if (info == 0) call lf%allocate(n_row,n_row,nztota) - if (info == 0) call uf%allocate(n_row,n_row,nztota) - - if(info/=0) then - info=4010 - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if (allocated(p%d)) then - if (size(p%d) < n_row) then - deallocate(p%d) - endif - endif - if (.not.allocated(p%d)) then - allocate(p%d(n_row),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - - endif - t3 = psb_wtime() - ! This is where we have no renumbering, thus no need - call psb_ilu_fct(a,lf,uf,p%d,info) - - if(info==0) then - call p%av(psb_l_pr_)%mv_from(lf) - call p%av(psb_u_pr_)%mv_from(uf) - call p%av(psb_l_pr_)%set_asb() - call p%av(psb_u_pr_)%set_asb() - call p%av(psb_l_pr_)%trim() - call p%av(psb_u_pr_)%trim() - else - info=4010 - ch_err='psb_ilu_fct' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case(psb_f_none_) - info=4010 - ch_err='Inconsistent prec psb_f_none_' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - - case default - info=4010 - ch_err='Unknown psb_f_type_' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - 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_sbjac_bld - - diff --git a/prec/psb_sdiagsc_bld.f90 b/prec/psb_sdiagsc_bld.f90 deleted file mode 100644 index 850230c3..00000000 --- a/prec/psb_sdiagsc_bld.f90 +++ /dev/null @@ -1,120 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psb_sdiagsc_bld(a,desc_a,p,upd,info) - - use psb_base_mod - use psb_prec_mod, psb_protect_name => psb_sdiagsc_bld - Implicit None - - type(psb_s_sparse_mat), intent(in), target :: a - type(psb_desc_type), intent(in) :: desc_a - type(psb_sprec_type),intent(inout) :: p - character, intent(in) :: upd - integer, intent(out) :: info - - - ! Local scalars - Integer :: err, n_row, n_col,I,ictxt,& - & me,np,mglob, err_act - integer :: int_err(5) - - integer,parameter :: iroot=psb_root_,iout=60,ilout=40 - character(len=20) :: name, ch_err - - if(psb_get_errstatus() /= 0) return - info=0 - err=0 - call psb_erractionsave(err_act) - name = 'psb_diagsc_bld' - - info = 0 - int_err(1) = 0 - ictxt = psb_cd_get_context(desc_a) - n_row = psb_cd_get_local_rows(desc_a) - n_col = psb_cd_get_local_cols(desc_a) - mglob = psb_cd_get_global_rows(desc_a) - - call psb_info(ictxt, me, np) - - ! diagonal scaling - - call psb_realloc(n_col,p%d,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_realloc') - goto 9999 - end if - - ! - ! Retrieve the diagonal entries of the matrix A - ! - call a%get_diag(p%d,info) - if(info /= 0) then - info=4010 - ch_err='psb_sp_getdiag' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ! - ! Copy into p%desc_data the descriptor associated to A - ! - call psb_cdcpy(desc_a,p%desc_Data,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_cdcpy') - goto 9999 - end if - - ! - ! The i-th diagonal entry of the preconditioner is set to one if the - ! corresponding entry a_ii of the sparse matrix A is zero; otherwise - ! it is set to one/a_ii - ! - do i=1,n_row - if (p%d(i) == szero) then - p%d(i) = sone - else - p%d(i) = sone/p%d(i) - endif - end do - - 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_sdiagsc_bld - diff --git a/prec/psb_sgprec_aply.f90 b/prec/psb_sgprec_aply.f90 deleted file mode 100644 index 408e3a9c..00000000 --- a/prec/psb_sgprec_aply.f90 +++ /dev/null @@ -1,135 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psb_sgprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) - ! - ! Compute Y <- beta*Y + alpha*K^-1 X - ! where K is a a basic preconditioner stored in prec - ! - - use psb_base_mod - use psb_prec_mod, psb_protect_name => psb_sgprec_aply - implicit none - - type(psb_desc_type),intent(in) :: desc_data - type(psb_sprec_type), intent(in) :: prec - real(psb_spk_),intent(in) :: x(:) - real(psb_spk_),intent(inout) :: y(:) - real(psb_spk_),intent(in) :: alpha,beta - character(len=1) :: trans - real(psb_spk_),target :: work(:) - integer, intent(out) :: info - - ! Local variables - integer :: n_row,int_err(5) - real(psb_spk_), pointer :: ww(:) - character :: trans_ - integer :: ictxt,np,me, err_act - character(len=20) :: name, ch_err - - name='psb_sgprec_aply' - info = 0 - call psb_erractionsave(err_act) - - ictxt=desc_data%matrix_data(psb_ctxt_) - call psb_info(ictxt, me, np) - - trans_ = psb_toupper(trans) - - select case(trans_) - case('N') - case('T','C') - case default - info=40 - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - select case(prec%iprcparm(psb_p_type_)) - - case(psb_noprec_) - - call psb_geaxpby(alpha,x,beta,y,desc_data,info) - - case(psb_diag_) - - if (size(work) >= size(x)) then - ww => work - else - allocate(ww(size(x)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - end if - - n_row=desc_data%matrix_data(psb_n_row_) - ww(1:n_row) = x(1:n_row)*prec%d(1:n_row) - call psb_geaxpby(alpha,ww,beta,y,desc_data,info) - - if (size(work) < size(x)) then - deallocate(ww,stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Deallocate') - goto 9999 - end if - end if - - case(psb_bjac_) - - call psb_bjac_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info) - if(info /= 0) then - info=4010 - ch_err='psb_bjac_aply' - goto 9999 - end if - - case default - info = 4001 - call psb_errpush(info,name,a_err='Invalid prectype') - goto 9999 - end select - - 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_sgprec_aply - diff --git a/prec/psb_silu_fct.f90 b/prec/psb_silu_fct.f90 index c5bfd7eb..b31f0b82 100644 --- a/prec/psb_silu_fct.f90 +++ b/prec/psb_silu_fct.f90 @@ -136,7 +136,7 @@ contains if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) - call trw%allocate(0,0,info) + call trw%allocate(0,0,1) if(info /= 0) then info=4010 ch_err='psb_sp_all' diff --git a/prec/psb_sprc_aply.f90 b/prec/psb_sprc_aply.f90 index a011e357..5d4084c9 100644 --- a/prec/psb_sprc_aply.f90 +++ b/prec/psb_sprc_aply.f90 @@ -73,8 +73,12 @@ subroutine psb_sprc_aply(prec,x,y,desc_data,info,trans, work) end if - call psb_gprec_aply(sone,prec,x,szero,y,desc_data,trans_,work_,info) - + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + call prec%prec%apply(sone,x,szero,y,desc_data,info,trans_,work=work_) if (present(work)) then else deallocate(work_) @@ -148,7 +152,7 @@ subroutine psb_sprc_aply1(prec,x,desc_data,info,trans) integer :: ictxt,np,me, err_act real(psb_spk_), pointer :: WW(:), w1(:) character(len=20) :: name - name='psb_sprec_aply1' + name='psb_prc_aply1' info = 0 call psb_erractionsave(err_act) @@ -161,12 +165,17 @@ subroutine psb_sprc_aply1(prec,x,desc_data,info,trans) trans_='N' end if + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if allocate(ww(size(x)),w1(size(x)),stat=info) if (info /= 0) then call psb_errpush(4010,name,a_err='Allocate') goto 9999 end if - call psb_sprc_aply(prec,x,ww,desc_data,info,trans_,work=w1) + call prec%prec%apply(sone,x,szero,ww,desc_data,info,trans_,work=w1) if(info /=0) goto 9999 x(:) = ww(:) deallocate(ww,W1) diff --git a/prec/psb_sprecbld.f90 b/prec/psb_sprecbld.f90 index 4823ff57..a53f440a 100644 --- a/prec/psb_sprecbld.f90 +++ b/prec/psb_sprecbld.f90 @@ -81,51 +81,14 @@ subroutine psb_sprecbld(a,desc_a,p,info,upd) ! ALso should define symbolic names for the preconditioners. ! - call psb_check_def(p%iprcparm(psb_p_type_),'base_prec',& - & psb_diag_,is_legal_prec) - - call psb_nullify_desc(p%desc_data) - - select case(p%iprcparm(psb_p_type_)) - case (psb_noprec_) - ! Do nothing. - call psb_cdcpy(desc_a,p%desc_data,info) - if(info /= 0) then - info=4010 - ch_err='psb_cdcpy' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case (psb_diag_) - - call psb_diagsc_bld(a,desc_a,p,upd_,info) - if(info /= 0) then - info=4010 - ch_err='psb_diagsc_bld' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case (psb_bjac_) - - call psb_check_def(p%iprcparm(psb_f_type_),'fact',& - & psb_f_ilu_n_,is_legal_ml_fact) - - call psb_bjac_bld(a,desc_a,p,upd_,info) - - if(info /= 0) then - call psb_errpush(4010,name,a_err='psb_bjac_bld') - goto 9999 - end if - - case default - info=4010 - ch_err='Unknown psb_p_type_' - call psb_errpush(info,name,a_err=ch_err) + if (.not.allocated(p%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") goto 9999 + end if - end select + call p%prec%precbld(a,desc_a,info,upd) + if (info /= 0) goto 9999 call psb_erractionrestore(err_act) return diff --git a/prec/psb_sprecinit.f90 b/prec/psb_sprecinit.f90 index 46d49391..b9425038 100644 --- a/prec/psb_sprecinit.f90 +++ b/prec/psb_sprecinit.f90 @@ -33,6 +33,9 @@ subroutine psb_sprecinit(p,ptype,info) use psb_base_mod use psb_prec_mod, psb_protect_name => psb_sprecinit + use psb_s_nullprec + use psb_s_diagprec + use psb_s_bjacprec implicit none type(psb_sprec_type), intent(inout) :: p character(len=*), intent(in) :: ptype @@ -40,32 +43,28 @@ subroutine psb_sprecinit(p,ptype,info) info = 0 - call psb_realloc(psb_ifpsz,p%iprcparm,info) - if (info == 0) call psb_realloc(psb_rfpsz,p%rprcparm,info) - if (info /= 0) return - p%iprcparm(:) = 0 - + if (allocated(p%prec) ) then + call p%prec%precfree(info) + if (info == 0) deallocate(p%prec,stat=info) + if (info /= 0) return + end if + select case(psb_toupper(ptype(1:len_trim(ptype)))) case ('NONE','NOPREC') - p%iprcparm(:) = 0 - p%iprcparm(psb_p_type_) = psb_noprec_ - p%iprcparm(psb_f_type_) = psb_f_none_ - + + allocate(psb_s_null_prec_type :: p%prec, stat=info) + case ('DIAG') - p%iprcparm(:) = 0 - p%iprcparm(psb_p_type_) = psb_diag_ - p%iprcparm(psb_f_type_) = psb_f_none_ - + allocate(psb_s_diag_prec_type :: p%prec, stat=info) + case ('BJAC') - p%iprcparm(:) = 0 - p%iprcparm(psb_p_type_) = psb_bjac_ - p%iprcparm(psb_f_type_) = psb_f_ilu_n_ - p%iprcparm(psb_ilu_fill_in_) = 0 - + allocate(psb_s_bjac_prec_type :: p%prec, stat=info) + case default write(0,*) 'Unknown preconditioner type request "',ptype,'"' info = 2 - + end select - + if (info == 0) call p%prec%precinit(info) + end subroutine psb_sprecinit diff --git a/prec/psb_sprecset.f90 b/prec/psb_sprecset.f90 index dc1505f7..0c220cb7 100644 --- a/prec/psb_sprecset.f90 +++ b/prec/psb_sprecset.f90 @@ -37,30 +37,18 @@ subroutine psb_sprecseti(p,what,val,info) type(psb_sprec_type), intent(inout) :: p integer :: what, val integer, intent(out) :: info + character(len=20) :: name='precset' info = 0 + if (.not.allocated(p%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + return +!!$ goto 9999 + end if - select case(what) - case (psb_f_type_) - if (p%iprcparm(psb_p_type_) /= psb_bjac_) then - write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif - p%iprcparm(psb_f_type_) = val + call p%prec%precset(what,val,info) - case (psb_ilu_fill_in_) - if ((p%iprcparm(psb_p_type_) /= psb_bjac_).or.(p%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then - write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif - p%iprcparm(psb_ilu_fill_in_) = val - - case default - write(0,*) 'WHAT is invalid, ignoring user specification' - - end select return end subroutine psb_sprecseti @@ -75,32 +63,18 @@ subroutine psb_sprecsets(p,what,val,info) integer :: what real(psb_spk_) :: val integer, intent(out) :: info + character(len=20) :: name='precset' + + info = 0 + if (.not.allocated(p%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + return +!!$ goto 9999 + end if -! -! This will have to be changed if/when we put together an ILU(eps) -! factorization. -! - select case(what) -!!$ case (psb_f_type_) -!!$ if (p%iprcparm(psb_p_type_) /= psb_bjac_) then -!!$ write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& -!!$ & 'ignoring user specification' -!!$ return -!!$ endif -!!$ p%iprcparm(psb_f_type_) = val -!!$ -!!$ case (psb_ilu_fill_in_) -!!$ if ((p%iprcparm(psb_p_type_) /= psb_bjac_).or.(p%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then -!!$ write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& -!!$ & 'ignoring user specification' -!!$ return -!!$ endif -!!$ p%iprcparm(psb_ilu_fill_in_) = val - - case default - write(0,*) 'WHAT is invalid, ignoring user specification' + call p%prec%precset(what,val,info) - end select return end subroutine psb_sprecsets diff --git a/prec/psb_z_bjacprec.f03 b/prec/psb_z_bjacprec.f03 new file mode 100644 index 00000000..877c9fda --- /dev/null +++ b/prec/psb_z_bjacprec.f03 @@ -0,0 +1,569 @@ +module psb_z_bjacprec + use psb_prec_type + + + type, extends(psb_z_base_prec_type) :: psb_z_bjac_prec_type + integer, allocatable :: iprcparm(:) + type(psb_z_sparse_mat), allocatable :: av(:) + complex(psb_dpk_), allocatable :: d(:) + contains + procedure, pass(prec) :: apply => z_bjac_apply + procedure, pass(prec) :: precbld => z_bjac_precbld + procedure, pass(prec) :: precinit => z_bjac_precinit + procedure, pass(prec) :: z_base_precseti => z_bjac_precseti + procedure, pass(prec) :: z_base_precsetr => z_bjac_precsetr + procedure, pass(prec) :: z_base_precsetc => z_bjac_precsetc + procedure, pass(prec) :: precfree => z_bjac_precfree + procedure, pass(prec) :: precdescr => z_bjac_precdescr + procedure, pass(prec) :: sizeof => z_bjac_sizeof + end type psb_z_bjac_prec_type + + + character(len=15), parameter, private :: & + & fact_names(0:2)=(/'None ','ILU(n) ',& + & 'ILU(eps) '/) + +contains + + + subroutine 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(in) :: 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 = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + + trans_ = psb_toupper(trans) + select case(trans_) + case('N','T','C') + ! Ok + case default + call psb_errpush(40,name) + goto 9999 + end select + + + n_row = psb_cd_get_local_rows(desc_data) + n_col = psb_cd_get_local_cols(desc_data) + + 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%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 /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + if (info /= 0) then + call psb_errpush(4010,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%d,choice=psb_none_,work=aux) + if(info ==0) 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%d,choice=psb_none_, work=aux) + if(info ==0) 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%d),choice=psb_none_, work=aux) + if(info ==0) 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 /=0) then + ch_err="psb_spsm" + goto 9999 + end if + + + case default + info = 4001 + 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 z_bjac_apply + + subroutine 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' + + call psb_erractionsave(err_act) + + info = 0 + call psb_realloc(psb_ifpsz,prec%iprcparm,info) + if (info /= 0) then + info = 4000 + 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 z_bjac_precinit + + + subroutine z_bjac_precbld(a,desc_a,prec,info,upd) + + use psb_base_mod + use psb_prec_mod + Implicit None + + type(psb_z_sparse_mat), 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 + + ! .. Local Scalars .. + integer :: i, m + integer :: int_err(5) + character :: trans, unitd + type(psb_z_csr_sparse_mat), allocatable :: lf, uf + 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 = 0 + + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + + m = a%get_nrows() + if (m < 0) then + info = 10 + 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 /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + endif + + nrow_a = psb_cd_get_local_rows(desc_a) + nztota = a%get_nzeros() + + n_col = psb_cd_get_local_cols(desc_a) + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == 0) call lf%allocate(n_row,n_row,nztota) + if (info == 0) call uf%allocate(n_row,n_row,nztota) + + if(info/=0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (allocated(prec%d)) then + if (size(prec%d) < n_row) then + deallocate(prec%d) + endif + endif + if (.not.allocated(prec%d)) then + allocate(prec%d(n_row),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + endif + ! This is where we have no renumbering, thus no need + call psb_ilu_fct(a,lf,uf,prec%d,info) + + if(info==0) 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() + else + info=4010 + ch_err='psb_ilu_fct' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + +!!$ call prec%av(psb_l_pr_)%print(30+me) +!!$ call prec%av(psb_u_pr_)%print(40+me) +!!$ do i=1,n_row +!!$ write(50+me,*) i,prec%d(i) +!!$ end do + + case(psb_f_none_) + info=4010 + ch_err='Inconsistent prec psb_f_none_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + + case default + info=4010 + ch_err='Unknown psb_f_type_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + 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 z_bjac_precbld + + subroutine 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 = 0 + 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(0,*) '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(0,*) '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(0,*) '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 z_bjac_precseti + + subroutine 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 + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='z_bjac_precset' + + call psb_erractionsave(err_act) + + info = 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 z_bjac_precsetr + + subroutine 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' + + call psb_erractionsave(err_act) + + info = 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 z_bjac_precsetc + + subroutine 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 = 0 + if (allocated(prec%av)) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + end if + if (allocated(prec%d)) then + deallocate(prec%d,stat=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 z_bjac_precfree + + + subroutine 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 = 0 + + 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 = 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 z_bjac_precdescr + + function z_bjac_sizeof(prec) result(val) + use psb_base_mod + 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 z_bjac_sizeof + +end module psb_z_bjacprec diff --git a/prec/psb_z_diagprec.f03 b/prec/psb_z_diagprec.f03 new file mode 100644 index 00000000..34a14e50 --- /dev/null +++ b/prec/psb_z_diagprec.f03 @@ -0,0 +1,375 @@ +module psb_z_diagprec + use psb_prec_type + + + type, extends(psb_z_base_prec_type) :: psb_z_diag_prec_type + complex(psb_dpk_), allocatable :: d(:) + contains + procedure, pass(prec) :: apply => z_diag_apply + procedure, pass(prec) :: precbld => z_diag_precbld + procedure, pass(prec) :: precinit => z_diag_precinit + procedure, pass(prec) :: z_base_precseti => z_diag_precseti + procedure, pass(prec) :: z_base_precsetr => z_diag_precsetr + procedure, pass(prec) :: z_base_precsetc => z_diag_precsetc + procedure, pass(prec) :: precfree => z_diag_precfree + procedure, pass(prec) :: precdescr => z_diag_precdescr + procedure, pass(prec) :: sizeof => z_diag_sizeof + end type psb_z_diag_prec_type + + +contains + + + subroutine 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(in) :: 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) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the DIAG preonditioner??? + ! + info = 0 + + + nrow = psb_cd_get_local_rows(desc_data) + 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=40 + 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 /= 0) then + call psb_errpush(4025,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 /= 0) then + call psb_errpush(4010,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 z_diag_apply + + subroutine z_diag_precinit(prec,info) + + use psb_base_mod + Implicit None + + class(psb_z_diag_prec_type),intent(inout) :: prec + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='z_diag_precinit' + + call psb_erractionsave(err_act) + + info = 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 z_diag_precinit + + + subroutine z_diag_precbld(a,desc_a,prec,info,upd) + + use psb_base_mod + Implicit None + + type(psb_z_sparse_mat), 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 + Integer :: err_act, nrow,i + character(len=20) :: name='z_diag_precbld' + + call psb_erractionsave(err_act) + + info = 0 + nrow = psb_cd_get_local_cols(desc_a) + if (allocated(prec%d)) then + if (size(prec%d) < nrow) then + deallocate(prec%d,stat=info) + end if + end if + if ((info == 0).and.(.not.allocated(prec%d))) then + allocate(prec%d(nrow), stat=info) + end if + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + call a%get_diag(prec%d,info) + if (info /= 0) then + info = 4010 + 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 + + 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 z_diag_precbld + + subroutine z_diag_precseti(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_z_diag_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_diag_precset' + + call psb_erractionsave(err_act) + + info = 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 z_diag_precseti + + subroutine z_diag_precsetr(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_z_diag_prec_type),intent(inout) :: prec + integer, intent(in) :: what + real(psb_dpk_), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='z_diag_precset' + + call psb_erractionsave(err_act) + + info = 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 z_diag_precsetr + + subroutine z_diag_precsetc(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_z_diag_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='z_diag_precset' + + call psb_erractionsave(err_act) + + info = 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 z_diag_precsetc + + subroutine z_diag_precfree(prec,info) + + use psb_base_mod + Implicit None + + class(psb_z_diag_prec_type), intent(inout) :: prec + integer, intent(out) :: info + + Integer :: err_act, nrow + character(len=20) :: name='z_diag_precset' + + call psb_erractionsave(err_act) + + info = 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 z_diag_precfree + + + subroutine z_diag_precdescr(prec,iout) + + use psb_base_mod + Implicit None + + class(psb_z_diag_prec_type), intent(in) :: prec + integer, intent(in), optional :: iout + + Integer :: err_act, nrow, info + character(len=20) :: name='z_diag_precdescr' + + integer :: iout_ + + call psb_erractionsave(err_act) + + info = 0 + + if (present(iout)) then + iout_ = iout + else + iout_ = 6 + end if + + write(iout_,*) 'Diagonal scaling' + + call psb_erractionsave(err_act) + + info = 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 z_diag_precdescr + + function z_diag_sizeof(prec) result(val) + use psb_base_mod + 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) + return + end function z_diag_sizeof + +end module psb_z_diagprec diff --git a/prec/psb_z_nullprec.f03 b/prec/psb_z_nullprec.f03 new file mode 100644 index 00000000..20888dcb --- /dev/null +++ b/prec/psb_z_nullprec.f03 @@ -0,0 +1,293 @@ +module psb_z_nullprec + use psb_prec_type + + + type, extends(psb_z_base_prec_type) :: psb_z_null_prec_type + contains + procedure, pass(prec) :: apply => z_null_apply + procedure, pass(prec) :: precbld => z_null_precbld + procedure, pass(prec) :: precinit => z_null_precinit + procedure, pass(prec) :: z_base_precseti => z_null_precseti + procedure, pass(prec) :: z_base_precsetr => z_null_precsetr + procedure, pass(prec) :: z_base_precsetc => z_null_precsetc + procedure, pass(prec) :: precfree => z_null_precfree + procedure, pass(prec) :: precdescr => z_null_precdescr + procedure, pass(prec) :: sizeof => z_null_sizeof + end type psb_z_null_prec_type + + +contains + + + subroutine 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(in) :: 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) + + ! + ! This is the base version and we should throw an error. + ! Or should it be the NULL preonditioner??? + ! + info = 0 + + nrow = psb_cd_get_local_rows(desc_data) + 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 /= 0 ) then + info = 4010 + 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 z_null_apply + + + subroutine z_null_precinit(prec,info) + + use psb_base_mod + Implicit None + + class(psb_z_null_prec_type),intent(inout) :: prec + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='z_null_precinit' + + call psb_erractionsave(err_act) + + info = 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 z_null_precinit + + subroutine z_null_precbld(a,desc_a,prec,info,upd) + + use psb_base_mod + Implicit None + + type(psb_z_sparse_mat), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + class(psb_z_null_prec_type),intent(inout) :: prec + integer, intent(out) :: info + character, intent(in), optional :: upd + Integer :: err_act, nrow + character(len=20) :: name='z_null_precbld' + + call psb_erractionsave(err_act) + + info = 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 z_null_precbld + + subroutine z_null_precseti(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_z_null_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_null_precset' + + call psb_erractionsave(err_act) + + info = 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 z_null_precseti + + subroutine z_null_precsetr(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_z_null_prec_type),intent(inout) :: prec + integer, intent(in) :: what + real(psb_dpk_), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act, nrow + character(len=20) :: name='z_null_precset' + + call psb_erractionsave(err_act) + + info = 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 z_null_precsetr + + subroutine z_null_precsetc(prec,what,val,info) + + use psb_base_mod + Implicit None + + class(psb_z_null_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='z_null_precset' + + call psb_erractionsave(err_act) + + info = 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 z_null_precsetc + + subroutine z_null_precfree(prec,info) + + use psb_base_mod + Implicit None + + class(psb_z_null_prec_type), intent(inout) :: prec + integer, intent(out) :: info + + Integer :: err_act, nrow + character(len=20) :: name='z_null_precset' + + call psb_erractionsave(err_act) + + info = 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 z_null_precfree + + + subroutine z_null_precdescr(prec,iout) + + use psb_base_mod + Implicit None + + class(psb_z_null_prec_type), intent(in) :: prec + integer, intent(in), optional :: iout + + Integer :: err_act, nrow, info + character(len=20) :: name='z_null_precset' + integer :: iout_ + + call psb_erractionsave(err_act) + + info = 0 + + if (present(iout)) then + iout_ = iout + else + iout_ = 6 + end if + + write(iout_,*) 'No preconditioning' + + 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 z_null_precdescr + + function 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 + + val = 0 + + return + end function z_null_sizeof + +end module psb_z_nullprec diff --git a/prec/psb_zbjac_aply.f90 b/prec/psb_zbjac_aply.f90 deleted file mode 100644 index 4f2a9474..00000000 --- a/prec/psb_zbjac_aply.f90 +++ /dev/null @@ -1,166 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) - ! - ! Compute Y <- beta*Y + alpha*K^-1 X - ! where K is a a Block Jacobi preconditioner stored in prec - ! Note that desc_data may or may not be the same as prec%desc_data, - ! but since both are INTENT(IN) this should be legal. - ! - - use psb_base_mod - use psb_prec_mod, psb_protect_name => psb_zbjac_aply - implicit none - - type(psb_desc_type), intent(in) :: desc_data - type(psb_zprec_type), intent(in) :: prec - complex(psb_dpk_),intent(in) :: x(:) - complex(psb_dpk_),intent(inout) :: y(:) - complex(psb_dpk_),intent(in) :: alpha,beta - character(len=1) :: trans - complex(psb_dpk_),target :: work(:) - integer, intent(out) :: info - - ! 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, ch_err - - name='psb_bjac_aply' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = psb_cd_get_context(desc_data) - call psb_info(ictxt, me, np) - - - trans_ = psb_toupper(trans) - select case(trans_) - case('N','T','C') - ! Ok - case default - call psb_errpush(40,name) - goto 9999 - end select - - - n_row=desc_data%matrix_data(psb_n_row_) - n_col=desc_data%matrix_data(psb_n_col_) - - 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 /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - - endif - else - allocate(ww(n_col),aux(4*n_col),stat=info) - if (info /= 0) then - call psb_errpush(4010,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%d,choice=psb_none_,work=aux) - if(info /=0) goto 9999 - call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_, work=aux) - if(info /=0) goto 9999 - - case('T') - call psb_spsm(zone,prec%av(psb_u_pr_),x,zzero,ww,desc_data,info,& - & trans=trans_,scale='L',diag=prec%d,choice=psb_none_, work=aux) - if(info /=0) goto 9999 - call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) - if(info /=0) goto 9999 - - case('C') - call psb_spsm(zone,prec%av(psb_u_pr_),x,zzero,ww,desc_data,info,& - & trans=trans_,scale='L',diag=conjg(prec%d),choice=psb_none_, work=aux) - if(info /=0) goto 9999 - call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) - if(info /=0) goto 9999 - - end select - - - case default - info = 4001 - 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_zbjac_aply diff --git a/prec/psb_zbjac_bld.f90 b/prec/psb_zbjac_bld.f90 deleted file mode 100644 index 933c90f3..00000000 --- a/prec/psb_zbjac_bld.f90 +++ /dev/null @@ -1,181 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psb_zbjac_bld(a,desc_a,p,upd,info) - use psb_base_mod - use psb_prec_mod, psb_protect_name => psb_zbjac_bld - implicit none - ! - ! .. Scalar Arguments .. - integer, intent(out) :: info - ! .. array Arguments .. - type(psb_z_sparse_mat), intent(in), target :: a - type(psb_zprec_type), intent(inout) :: p - type(psb_desc_type), intent(in) :: desc_a - character, intent(in) :: upd - - ! .. Local Scalars .. - integer :: i, m - integer :: int_err(5) - character :: trans, unitd - type(psb_z_csr_sparse_mat), allocatable :: lf, uf - real(psb_dpk_) :: t1,t2,t3,t4,t5,t6, t7, t8 - integer nztota, err_act, n_row, nrow_a,n_col, nhalo - integer :: ictxt,np,me - character(len=20) :: name, ch_err - - - if(psb_get_errstatus() /= 0) return - info=0 - name='psb_zbjac_bld' - call psb_erractionsave(err_act) - - ictxt=psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - - m = a%get_nrows() - if (m < 0) then - info = 10 - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - trans = 'N' - unitd = 'U' - - call psb_cdcpy(desc_a,p%desc_data,info) - if(info /= 0) then - info=4010 - ch_err='psb_cdcpy' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - - select case(p%iprcparm(psb_f_type_)) - - case(psb_f_ilu_n_) - - if (allocated(p%av)) then - if (size(p%av) < psb_bp_ilu_avsz) then - do i=1,size(p%av) - call p%av(i)%free() - enddo - deallocate(p%av,stat=info) - endif - end if - if (.not.allocated(p%av)) then - allocate(p%av(psb_max_avsz),stat=info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - endif - - nrow_a = psb_cd_get_local_rows(desc_a) - nztota = a%get_nzeros() - - n_col = psb_cd_get_local_cols(desc_a) - nhalo = n_col-nrow_a - n_row = p%desc_data%matrix_data(psb_n_row_) - - allocate(lf,uf,stat=info) - if (info == 0) call lf%allocate(n_row,n_row,nztota) - if (info == 0) call uf%allocate(n_row,n_row,nztota) - - if(info/=0) then - info=4010 - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if (allocated(p%d)) then - if (size(p%d) < n_row) then - deallocate(p%d) - endif - endif - if (.not.allocated(p%d)) then - allocate(p%d(n_row),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - - endif - t3 = psb_wtime() - ! This is where we have no renumbering, thus no need - call psb_ilu_fct(a,lf,uf,p%d,info) - - if(info==0) then - call p%av(psb_l_pr_)%mv_from(lf) - call p%av(psb_u_pr_)%mv_from(uf) - call p%av(psb_l_pr_)%set_asb() - call p%av(psb_u_pr_)%set_asb() - call p%av(psb_l_pr_)%trim() - call p%av(psb_u_pr_)%trim() - else - info=4010 - ch_err='psb_ilu_fct' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case(psb_f_none_) - info=4010 - ch_err='Inconsistent prec psb_f_none_' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - - case default - info=4010 - ch_err='Unknown psb_f_type_' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - 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_zbjac_bld - - diff --git a/prec/psb_zdiagsc_bld.f90 b/prec/psb_zdiagsc_bld.f90 deleted file mode 100644 index 745845d4..00000000 --- a/prec/psb_zdiagsc_bld.f90 +++ /dev/null @@ -1,120 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psb_zdiagsc_bld(a,desc_a,p,upd,info) - - use psb_base_mod - use psb_prec_mod, psb_protect_name => psb_zdiagsc_bld - Implicit None - - type(psb_z_sparse_mat), intent(in), target :: a - type(psb_desc_type), intent(in) :: desc_a - type(psb_zprec_type),intent(inout) :: p - character, intent(in) :: upd - integer, intent(out) :: info - - - ! Local scalars - Integer :: err, n_row, n_col,I,ictxt,& - & me,np,mglob,err_act - integer :: int_err(5) - - integer,parameter :: iroot=psb_root_,iout=60,ilout=40 - character(len=20) :: name, ch_err - - if(psb_get_errstatus() /= 0) return - info=0 - err=0 - call psb_erractionsave(err_act) - name = 'psb_diagsc_bld' - - info = 0 - int_err(1) = 0 - ictxt = psb_cd_get_context(desc_a) - n_row = psb_cd_get_local_rows(desc_a) - n_col = psb_cd_get_local_cols(desc_a) - mglob = psb_cd_get_global_rows(desc_a) - - call psb_info(ictxt, me, np) - - ! diagonal scaling - - call psb_realloc(n_col,p%d,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_realloc') - goto 9999 - end if - - ! - ! Retrieve the diagonal entries of the matrix A - ! - call a%get_diag(p%d,info) - if(info /= 0) then - info=4010 - ch_err='psb_sp_getdiag' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ! - ! Copy into p%desc_data the descriptor associated to A - ! - call psb_cdcpy(desc_a,p%desc_Data,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_cdcpy') - goto 9999 - end if - - ! - ! The i-th diagonal entry of the preconditioner is set to one if the - ! corresponding entry a_ii of the sparse matrix A is zero; otherwise - ! it is set to one/a_ii - ! - do i=1,n_row - if (p%d(i) == zzero) then - p%d(i) = zone - else - p%d(i) = zone/p%d(i) - endif - end do - - 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_zdiagsc_bld - diff --git a/prec/psb_zgprec_aply.f90 b/prec/psb_zgprec_aply.f90 deleted file mode 100644 index dd16b654..00000000 --- a/prec/psb_zgprec_aply.f90 +++ /dev/null @@ -1,140 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psb_zgprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) - ! - ! Compute Y <- beta*Y + alpha*K^-1 X - ! where K is a a basic preconditioner stored in prec - ! - - use psb_base_mod - use psb_prec_mod, psb_protect_name => psb_zgprec_aply - implicit none - - type(psb_desc_type),intent(in) :: desc_data - type(psb_zprec_type), intent(in) :: prec - complex(psb_dpk_),intent(in) :: x(:) - complex(psb_dpk_),intent(inout) :: y(:) - complex(psb_dpk_),intent(in) :: alpha,beta - character(len=1) :: trans - complex(psb_dpk_),target :: work(:) - integer, intent(out) :: info - - ! Local variables - integer :: n_row,int_err(5) - complex(psb_dpk_), pointer :: ww(:) - character :: trans_ - integer :: ictxt,np,me, err_act - character(len=20) :: name, ch_err - - - name='psb_zgprec_aply' - info = 0 - call psb_erractionsave(err_act) - - ictxt=desc_data%matrix_data(psb_ctxt_) - call psb_info(ictxt, me, np) - - trans_ = psb_toupper(trans) - - select case(trans_) - case('N') - case('T','C') - case default - info=40 - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - select case(prec%iprcparm(psb_p_type_)) - - case(psb_noprec_) - - call psb_geaxpby(alpha,x,beta,y,desc_data,info) - - case(psb_diag_) - - if (size(work) >= size(x)) then - ww => work - else - allocate(ww(size(x)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - end if - - n_row=desc_data%matrix_data(psb_n_row_) - if (trans_=='C') then - ww(1:n_row) = x(1:n_row)*conjg(prec%d(1:n_row)) - else - ww(1:n_row) = x(1:n_row)*prec%d(1:n_row) - endif - call psb_geaxpby(alpha,ww,beta,y,desc_data,info) - - if (size(work) < size(x)) then - deallocate(ww,stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Deallocate') - goto 9999 - end if - end if - - case(psb_bjac_) - - call psb_bjac_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info) - if(info /= 0) then - info=4010 - ch_err='psb_bjac_aply' - goto 9999 - end if - - case default - info = 4001 - call psb_errpush(info,name,a_err='Invalid prectype') - goto 9999 - end select - - 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_zgprec_aply - diff --git a/prec/psb_zilu_fct.f90 b/prec/psb_zilu_fct.f90 index 95503d40..9e80384e 100644 --- a/prec/psb_zilu_fct.f90 +++ b/prec/psb_zilu_fct.f90 @@ -133,7 +133,7 @@ contains if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) - call trw%allocate(0,0,info) + call trw%allocate(0,0,1) if(info /= 0) then info=4010 ch_err='psb_sp_all' diff --git a/prec/psb_zprc_aply.f90 b/prec/psb_zprc_aply.f90 index 8ed701c3..52068e46 100644 --- a/prec/psb_zprc_aply.f90 +++ b/prec/psb_zprc_aply.f90 @@ -50,7 +50,7 @@ subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans, work) integer :: ictxt,np,me,err_act character(len=20) :: name - name='psb_zprec_aply' + name='psb_prc_aply' info = 0 call psb_erractionsave(err_act) @@ -74,10 +74,12 @@ subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans, work) end if - call psb_gprec_aply(zone,prec,x,zzero,y,desc_data,trans_,work_,info) - - ! If the original distribution has an overlap we should fix that. - + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + call prec%prec%apply(zone,x,zzero,y,desc_data,info,trans_,work=work_) if (present(work)) then else deallocate(work_) @@ -151,7 +153,7 @@ subroutine psb_zprc_aply1(prec,x,desc_data,info,trans) integer :: ictxt,np,me, err_act complex(psb_dpk_), pointer :: WW(:), w1(:) character(len=20) :: name - name='psb_zprec1' + name='psb_prc_aply1' info = 0 call psb_erractionsave(err_act) @@ -164,12 +166,17 @@ subroutine psb_zprc_aply1(prec,x,desc_data,info,trans) trans_='N' end if + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if allocate(ww(size(x)),w1(size(x)),stat=info) if (info /= 0) then call psb_errpush(4010,name,a_err='Allocate') goto 9999 end if - call psb_zprc_aply(prec,x,ww,desc_data,info,trans_,work=w1) + call prec%prec%apply(zone,x,zzero,ww,desc_data,info,trans_,work=w1) if(info /=0) goto 9999 x(:) = ww(:) deallocate(ww,W1) diff --git a/prec/psb_zprecbld.f90 b/prec/psb_zprecbld.f90 index 890117c3..490fdf25 100644 --- a/prec/psb_zprecbld.f90 +++ b/prec/psb_zprecbld.f90 @@ -82,51 +82,14 @@ subroutine psb_zprecbld(a,desc_a,p,info,upd) ! ALso should define symbolic names for the preconditioners. ! - call psb_check_def(p%iprcparm(psb_p_type_),'base_prec',& - & psb_diag_,is_legal_prec) - - call psb_nullify_desc(p%desc_data) - - select case(p%iprcparm(psb_p_type_)) - case (psb_noprec_) - ! Do nothing. - call psb_cdcpy(desc_a,p%desc_data,info) - if(info /= 0) then - info=4010 - ch_err='psb_cdcpy' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case (psb_diag_) - - call psb_diagsc_bld(a,desc_a,p,upd_,info) - if(info /= 0) then - info=4010 - ch_err='psb_diagsc_bld' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case (psb_bjac_) - - call psb_check_def(p%iprcparm(psb_f_type_),'fact',& - & psb_f_ilu_n_,is_legal_ml_fact) - - call psb_bjac_bld(a,desc_a,p,upd_,info) - - if(info /= 0) then - call psb_errpush(4010,name,a_err='psb_bjac_bld') - goto 9999 - end if - - case default - info=4010 - ch_err='Unknown psb_p_type_' - call psb_errpush(info,name,a_err=ch_err) + if (.not.allocated(p%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") goto 9999 + end if - end select + call p%prec%precbld(a,desc_a,info,upd) + if (info /= 0) goto 9999 call psb_erractionrestore(err_act) return diff --git a/prec/psb_zprecinit.f90 b/prec/psb_zprecinit.f90 index 43a94cb1..ee221386 100644 --- a/prec/psb_zprecinit.f90 +++ b/prec/psb_zprecinit.f90 @@ -33,6 +33,9 @@ subroutine psb_zprecinit(p,ptype,info) use psb_base_mod use psb_prec_mod, psb_protect_name => psb_zprecinit + use psb_z_nullprec + use psb_z_diagprec + use psb_z_bjacprec implicit none type(psb_zprec_type), intent(inout) :: p @@ -40,35 +43,29 @@ subroutine psb_zprecinit(p,ptype,info) integer, intent(out) :: info info = 0 - - call psb_realloc(psb_ifpsz,p%iprcparm,info) - if (info == 0) call psb_realloc(psb_rfpsz,p%rprcparm,info) - if (info /= 0) return - p%iprcparm(:) = 0 + if (allocated(p%prec) ) then + call p%prec%precfree(info) + if (info == 0) deallocate(p%prec,stat=info) + if (info /= 0) return + end if + select case(psb_toupper(ptype(1:len_trim(ptype)))) case ('NONE','NOPREC') - p%iprcparm(:) = 0 - p%iprcparm(psb_p_type_) = psb_noprec_ - p%iprcparm(psb_f_type_) = psb_f_none_ - + + allocate(psb_z_null_prec_type :: p%prec, stat=info) + case ('DIAG') - p%iprcparm(:) = 0 - p%iprcparm(psb_p_type_) = psb_diag_ - p%iprcparm(psb_f_type_) = psb_f_none_ - + allocate(psb_z_diag_prec_type :: p%prec, stat=info) + case ('BJAC') - p%iprcparm(:) = 0 - p%iprcparm(psb_p_type_) = psb_bjac_ - p%iprcparm(psb_f_type_) = psb_f_ilu_n_ - p%iprcparm(psb_ilu_fill_in_) = 0 - + allocate(psb_z_bjac_prec_type :: p%prec, stat=info) + case default write(0,*) 'Unknown preconditioner type request "',ptype,'"' - info = 2 - + end select - - + if (info == 0) call p%prec%precinit(info) + end subroutine psb_zprecinit diff --git a/prec/psb_zprecset.f90 b/prec/psb_zprecset.f90 index a4170be4..9697f3d9 100644 --- a/prec/psb_zprecset.f90 +++ b/prec/psb_zprecset.f90 @@ -37,30 +37,18 @@ subroutine psb_zprecseti(p,what,val,info) type(psb_zprec_type), intent(inout) :: p integer :: what, val integer, intent(out) :: info + character(len=20) :: name='precset' info = 0 + if (.not.allocated(p%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + return +!!$ goto 9999 + end if - select case(what) - case (psb_f_type_) - if (p%iprcparm(psb_p_type_) /= psb_bjac_) then - write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif - p%iprcparm(psb_f_type_) = val + call p%prec%precset(what,val,info) - case (psb_ilu_fill_in_) - if ((p%iprcparm(psb_p_type_) /= psb_bjac_).or.(p%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then - write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif - p%iprcparm(psb_ilu_fill_in_) = val - - case default - write(0,*) 'WHAT is invalid, ignoring user specification' - - end select return end subroutine psb_zprecseti @@ -75,32 +63,18 @@ subroutine psb_zprecsetd(p,what,val,info) integer :: what real(psb_dpk_) :: val integer, intent(out) :: info + character(len=20) :: name='precset' + + info = 0 + if (.not.allocated(p%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + return +!!$ goto 9999 + end if -! -! This will have to be changed if/when we put together an ILU(eps) -! factorization. -! - select case(what) -!!$ case (psb_f_type_) -!!$ if (p%iprcparm(psb_p_type_) /= psb_bjac_) then -!!$ write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& -!!$ & 'ignoring user specification' -!!$ return -!!$ endif -!!$ p%iprcparm(psb_f_type_) = val -!!$ -!!$ case (psb_ilu_fill_in_) -!!$ if ((p%iprcparm(psb_p_type_) /= psb_bjac_).or.(p%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then -!!$ write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& -!!$ & 'ignoring user specification' -!!$ return -!!$ endif -!!$ p%iprcparm(psb_ilu_fill_in_) = val - - case default - write(0,*) 'WHAT is invalid, ignoring user specification' + call p%prec%precset(what,val,info) - end select return end subroutine psb_zprecsetd diff --git a/test/fileread/runs/cfs.inp b/test/fileread/runs/cfs.inp index 29ba24c4..5b4a01f4 100644 --- a/test/fileread/runs/cfs.inp +++ b/test/fileread/runs/cfs.inp @@ -1,9 +1,9 @@ 11 Number of inputs -young1c.mtx This (and others) from: http://math.nist.gov/MatrixMarket/ or +waveguide3D.mtx This (and others) from: http://math.nist.gov/MatrixMarket/ or NONE http://www.cise.ufl.edu/research/sparse/matrices/index.html MM File format: MM: Matrix Market HB: Harwell-Boeing. BICGSTAB Iterative method: BiCGSTAB CGS RGMRES BiCGSTABL BICG CG -BJAC Preconditioner NONE DIAG BJAC +DIAG Preconditioner NONE DIAG BJAC CSR Storage format CSR COO JAD 0 IPART: Partition method 0: BLK 2: graph (with Metis) 2 ISTOPC diff --git a/test/fileread/runs/dfs.inp b/test/fileread/runs/dfs.inp index 8027620d..38314654 100644 --- a/test/fileread/runs/dfs.inp +++ b/test/fileread/runs/dfs.inp @@ -1,13 +1,13 @@ 11 Number of inputs -thm200x120.mtx sherman3.mtx This (and others) from: http://math.nist.gov/MatrixMarket/ or +10974x10974.mtx sherman3.mtx This (and others) from: http://math.nist.gov/MatrixMarket/ or NONE sherman3_rhs1.mtx http://www.cise.ufl.edu/research/sparse/matrices/index.html MM File format: MM: Matrix Market HB: Harwell-Boeing. BICGSTAB Iterative method: BiCGSTAB CGS RGMRES BiCGSTABL BICG CG BJAC Preconditioner NONE DIAG BJAC CSR Storage format CSR COO JAD -2 IPART: Partition method 0: BLK 2: graph (with Metis) +0 IPART: Partition method 0: BLK 2: graph (with Metis) 2 ISTOPC -01000 ITMAX +00010 ITMAX 01 ITRACE 30 IRST (restart for RGMRES and BiCGSTABL) 1.d-6 EPS diff --git a/test/fileread/runs/zfs.inp b/test/fileread/runs/zfs.inp index 676c75fb..6472cb1a 100644 --- a/test/fileread/runs/zfs.inp +++ b/test/fileread/runs/zfs.inp @@ -5,7 +5,7 @@ MM File format: MM: Matrix Market HB: Harwell-Boeing. BICGSTAB Iterative method: BiCGSTAB CGS RGMRES BiCGSTABL BICG CG BJAC Preconditioner NONE DIAG BJAC CSR Storage format CSR COO JAD -0 IPART: Partition method 0: BLK 2: graph (with Metis) +2 IPART: Partition method 0: BLK 2: graph (with Metis) 2 ISTOPC 05000 ITMAX 01 ITRACE diff --git a/test/pargen/Makefile b/test/pargen/Makefile index 6f06a50c..b563e0b1 100644 --- a/test/pargen/Makefile +++ b/test/pargen/Makefile @@ -17,7 +17,7 @@ EXEDIR=./runs all: ppde spde ppde: ppde.o psb_d_csc_impl.o psb_d_csc_mat_mod.o - $(F90LINK) ppde.o psb_d_csc_impl.o psb_d_csc_mat_mod.o -o ppde $(PSBLAS_LIB) $(LDLIBS) + $(F90LINK) -pg ppde.o psb_d_csc_impl.o psb_d_csc_mat_mod.o -o ppde $(PSBLAS_LIB) $(LDLIBS) /bin/mv ppde $(EXEDIR) psb_d_csc_impl.o ppde.o: psb_d_csc_mat_mod.o diff --git a/test/pargen/runs/ppde.inp b/test/pargen/runs/ppde.inp index ddb9148b..1d4a6c03 100644 --- a/test/pargen/runs/ppde.inp +++ b/test/pargen/runs/ppde.inp @@ -4,8 +4,8 @@ BJAC Preconditioner NONE DIAG BJAC CSR Storage format for matrix A: CSR COO JAD 060 Domain size (acutal system is this**3) 2 Stopping criterion -0400 MAXIT -001 ITRACE +0100 MAXIT +01 ITRACE 20 IRST restart for RGMRES and BiCGSTABL diff --git a/util/psb_mat_dist_mod.f90 b/util/psb_mat_dist_mod.f90 index 68ff8024..326e9d4b 100644 --- a/util/psb_mat_dist_mod.f90 +++ b/util/psb_mat_dist_mod.f90 @@ -1324,6 +1324,7 @@ contains goto 9999 end if + write(0,*)name,' Calling spasb',psb_dupl_err_,' ',afmt call psb_barrier(ictxt) t2 = psb_wtime() call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt)