diff --git a/prec/psb_d_bjacprec.f03 b/prec/psb_d_bjacprec.f03 index 724e03e4..12db4dcf 100644 --- a/prec/psb_d_bjacprec.f03 +++ b/prec/psb_d_bjacprec.f03 @@ -115,23 +115,22 @@ contains 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,& + 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) - 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,& + 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) - if(info /=0) goto 9999 end select + if (info /=0) then + ch_err="psb_spsm" + goto 9999 + end if case default @@ -207,18 +206,18 @@ contains subroutine d_bjac_precbld(a,desc_a,prec,info,upd) - + use psb_base_mod use psb_prec_mod Implicit None - + type(psb_d_sparse_mat), intent(in), target :: a type(psb_desc_type), intent(in), target :: desc_a class(psb_d_bjac_prec_type),intent(inout) :: prec integer, intent(out) :: info character, intent(in), optional :: upd - ! .. Local Scalars .. + ! .. Local Scalars .. integer :: i, m integer :: int_err(5) character :: trans, unitd @@ -228,120 +227,126 @@ contains integer :: ictxt,np,me character(len=20) :: name='d_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) + if(psb_get_errstatus() /= 0) return + info = 0 - 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_erractionsave(err_act) - select case(prec%iprcparm(psb_f_type_)) + ictxt=psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) - case(psb_f_ilu_n_) + 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' - 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) + 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 - 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) + + 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 - 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 - 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 + t3 = psb_wtime() + ! 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 - endif - t3 = psb_wtime() - ! 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 + case(psb_f_none_) info=4010 - ch_err='psb_ilu_fct' + ch_err='Inconsistent prec psb_f_none_' 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 + 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 + call psb_erractionrestore(err_act) + return 9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if return - end if - return end subroutine d_bjac_precbld