diff --git a/base/comm/psb_ihalo.f90 b/base/comm/psb_ihalo.f90 index 2da50fba..841efea0 100644 --- a/base/comm/psb_ihalo.f90 +++ b/base/comm/psb_ihalo.f90 @@ -427,3 +427,153 @@ end subroutine psb_ihalov + +subroutine psb_ihalo_vect(x,desc_a,info,alpha,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_ihalo_vect + use psi_mod + implicit none + + type(psb_i_vect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: alpha + integer(psb_ipk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& + & err, liwork,data_ + integer(psb_ipk_),pointer :: iwork(:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_ihalov' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + ijx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + + if (present(tran)) then + tran_ = psb_toupper(tran) + else + tran_ = 'N' + endif + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + + ! check vector correctness + call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + if(present(alpha)) then + if(alpha /= done) then + call x%scal(alpha) + end if + end if + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + iwork => work + aliw=.false. + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + ! exchange halo elements + if(tran_ == 'N') then + call psi_swapdata(imode,izero,x%v,& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,ione,x%v,& + & desc_a,iwork,info) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 + end if + + if (info /= psb_success_) then + ch_err='PSI_swapdata' + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return +end subroutine psb_ihalo_vect diff --git a/base/comm/psb_iovrl.f90 b/base/comm/psb_iovrl.f90 index d3868d26..45a4baa8 100644 --- a/base/comm/psb_iovrl.f90 +++ b/base/comm/psb_iovrl.f90 @@ -388,3 +388,133 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode) end if return end subroutine psb_iovrlv + +subroutine psb_iovrl_vect(x,desc_a,info,work,update,mode) + use psb_base_mod, psb_protect_name => psb_iovrl_vect + use psi_mod + implicit none + + type(psb_i_vect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: update,mode + + ! locals + integer(psb_ipk_) :: ictxt, np, me, & + & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& + & mode_, err, liwork,ldx + integer(psb_ipk_),pointer :: iwork(:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_iovrlv' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + ijx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + k = 1 + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + + ! check vector correctness + call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + + ! exchange overlap elements + if (do_swap) then + call psi_swapdata(mode_,ione,x%v,& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return +end subroutine psb_iovrl_vect + diff --git a/base/internals/psi_ovrl_restr.f90 b/base/internals/psi_ovrl_restr.f90 index 60b5dfa6..17106ee7 100644 --- a/base/internals/psi_ovrl_restr.f90 +++ b/base/internals/psi_ovrl_restr.f90 @@ -531,6 +531,51 @@ end subroutine psi_iovrl_restrr2 +subroutine psi_iovrl_restr_vect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_iovrl_restr_vect + use psb_i_base_vect_mod + + implicit none + + class(psb_i_base_vect_type) :: x + integer(psb_ipk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_iovrl_restrr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,izero) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return +end subroutine psi_iovrl_restr_vect + + subroutine psi_sovrl_restr_vect(x,xs,desc_a,info) use psi_mod, psi_protect_name => psi_sovrl_restr_vect use psb_s_base_vect_mod diff --git a/base/internals/psi_ovrl_save.f90 b/base/internals/psi_ovrl_save.f90 index d9237fb1..c0f5c343 100644 --- a/base/internals/psi_ovrl_save.f90 +++ b/base/internals/psi_ovrl_save.f90 @@ -579,6 +579,57 @@ end subroutine psi_iovrl_saver2 +subroutine psi_iovrl_save_vect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_iovrl_save_vect + use psb_realloc_mod + use psb_i_base_vect_mod + + implicit none + + class(psb_i_base_vect_type) :: x + integer(psb_ipk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_iovrl_saver1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return +end subroutine psi_iovrl_save_vect + subroutine psi_sovrl_save_vect(x,xs,desc_a,info) use psi_mod, psi_protect_name => psi_sovrl_save_vect use psb_realloc_mod diff --git a/base/internals/psi_ovrl_upd.f90 b/base/internals/psi_ovrl_upd.f90 index f752f0cf..074a092b 100644 --- a/base/internals/psi_ovrl_upd.f90 +++ b/base/internals/psi_ovrl_upd.f90 @@ -748,6 +748,90 @@ subroutine psi_iovrl_updr2(x,desc_a,update,info) end subroutine psi_iovrl_updr2 +subroutine psi_iovrl_upd_vect(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_iovrl_upd_vect + use psb_realloc_mod + use psb_i_base_vect_mod + + implicit none + + class(psb_i_base_vect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_), allocatable :: xs(:) + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_iovrl_updr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + nx = size(desc_a%ovrlap_elem,1) + call psb_realloc(nx,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i) = izero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,izero) + 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(ictxt) + return + end if + return +end subroutine psi_iovrl_upd_vect + subroutine psi_sovrl_upd_vect(x,desc_a,update,info) use psi_mod, psi_protect_name => psi_sovrl_upd_vect use psb_realloc_mod diff --git a/base/modules/psb_i_tools_mod.f90 b/base/modules/psb_i_tools_mod.f90 index 3ad3a02b..0bc878c5 100644 --- a/base/modules/psb_i_tools_mod.f90 +++ b/base/modules/psb_i_tools_mod.f90 @@ -30,7 +30,8 @@ !!$ !!$ module psb_i_tools_mod - use psb_descriptor_type, only : psb_desc_type, psb_spk_, psb_ipk_, psb_success_ + use psb_descriptor_type, only : psb_desc_type, psb_ipk_, psb_success_ + use psb_i_vect_mod, only : psb_i_base_vect_type, psb_i_vect_type interface psb_geall @@ -48,6 +49,14 @@ module psb_i_tools_mod integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: n end subroutine psb_iallocv + subroutine psb_ialloc_vect(x, desc_a,info,n) + import :: psb_desc_type, psb_ipk_, & + & psb_i_base_vect_type, psb_i_vect_type + type(psb_i_vect_type), intent(out) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_ialloc_vect end interface @@ -64,6 +73,15 @@ module psb_i_tools_mod integer(psb_ipk_), allocatable, intent(inout) :: x(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_iasbv + subroutine psb_iasb_vect(x, desc_a, info,mold, scratch) + import :: psb_desc_type, psb_ipk_, & + & psb_i_base_vect_type, psb_i_vect_type + type(psb_desc_type), intent(in) :: desc_a + type(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine psb_iasb_vect end interface @@ -80,10 +98,17 @@ module psb_i_tools_mod type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psb_ifreev + subroutine psb_ifree_vect(x, desc_a, info) + import :: psb_desc_type, psb_ipk_, & + & psb_i_base_vect_type, psb_i_vect_type + type(psb_desc_type), intent(in) :: desc_a + type(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ifree_vect end interface interface psb_geins - subroutine psb_iinsi(m,irw,val, x,desc_a,info,dupl) + subroutine psb_iinsi(m,irw,val, x,desc_a,info,dupl,local) import :: psb_ipk_, psb_desc_type integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a @@ -92,8 +117,9 @@ module psb_i_tools_mod integer(psb_ipk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local end subroutine psb_iinsi - subroutine psb_iinsvi(m, irw,val, x,desc_a,info,dupl) + subroutine psb_iinsvi(m, irw,val, x,desc_a,info,dupl,local) import :: psb_ipk_, psb_desc_type integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a @@ -102,7 +128,20 @@ module psb_i_tools_mod integer(psb_ipk_), intent(in) :: val(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local end subroutine psb_iinsvi + subroutine psb_iins_vect(m,irw,val,x,desc_a,info,dupl,local) + import :: psb_desc_type, psb_ipk_, & + & psb_i_base_vect_type, psb_i_vect_type + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + type(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_ipk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_iins_vect end interface diff --git a/base/modules/psi_i_mod.f90 b/base/modules/psi_i_mod.f90 index c54abbe1..4bc9ca8c 100644 --- a/base/modules/psi_i_mod.f90 +++ b/base/modules/psi_i_mod.f90 @@ -413,6 +413,13 @@ module psi_i_mod integer(psb_ipk_), intent(in) :: update integer(psb_ipk_), intent(out) :: info end subroutine psi_iovrl_updr2 + subroutine psi_iovrl_upd_vect(x,desc_a,update,info) + import :: psb_desc_type, psb_ipk_, psb_i_base_vect_type + class(psb_i_base_vect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_iovrl_upd_vect end interface interface psi_ovrl_save @@ -430,6 +437,13 @@ module psi_i_mod type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_iovrl_saver2 + subroutine psi_iovrl_save_vect(x,xs,desc_a,info) + import :: psb_desc_type, psb_ipk_, psb_i_base_vect_type + class(psb_i_base_vect_type) :: x + integer(psb_ipk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_iovrl_save_vect end interface interface psi_ovrl_restore @@ -447,6 +461,13 @@ module psi_i_mod type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_iovrl_restrr2 + subroutine psi_iovrl_restr_vect(x,xs,desc_a,info) + import :: psb_desc_type, psb_ipk_, psb_i_base_vect_type + class(psb_i_base_vect_type) :: x + integer(psb_ipk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_iovrl_restr_vect end interface end module psi_i_mod diff --git a/base/tools/psb_ialloc.f90 b/base/tools/psb_ialloc.f90 index 8efc75cd..abae122c 100644 --- a/base/tools/psb_ialloc.f90 +++ b/base/tools/psb_ialloc.f90 @@ -250,3 +250,81 @@ subroutine psb_iallocv(x, desc_a, info,n) end subroutine psb_iallocv + +subroutine psb_ialloc_vect(x, desc_a,info,n) + use psb_base_mod, psb_protect_name => psb_ialloc_vect + use psi_mod + implicit none + + !....parameters... + type(psb_i_vect_type), intent(out) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + + !locals + integer(psb_ipk_) :: np,me,nr,i,err_act + integer(psb_ipk_) :: ictxt, int_err(5) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info=psb_success_ + if (psb_errstatus_fatal()) return + name='psb_geall' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + allocate(psb_i_base_vect_type :: x%v, stat=info) + if (info == 0) call x%all(nr,info) + if (psb_errstatus_fatal()) then + info=psb_err_alloc_request_ + int_err(1)=nr + call psb_errpush(info,name,int_err,a_err='integer(psb_ipk_)') + goto 9999 + endif + call x%zero() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + +end subroutine psb_ialloc_vect + diff --git a/base/tools/psb_iasb.f90 b/base/tools/psb_iasb.f90 index e54505d6..c05cb8b4 100644 --- a/base/tools/psb_iasb.f90 +++ b/base/tools/psb_iasb.f90 @@ -251,3 +251,82 @@ subroutine psb_iasbv(x, desc_a, info) end subroutine psb_iasbv + +subroutine psb_iasb_vect(x, desc_a, info, mold, scratch) + use psb_base_mod, psb_protect_name => psb_iasb_vect + implicit none + + type(psb_desc_type), intent(in) :: desc_a + type(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act + logical :: scratch_ + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name,ch_err + + info = psb_success_ + if (psb_errstatus_fatal()) return + + int_err(1) = 0 + name = 'psb_igeasb_v' + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + + if (scratch_) then + call x%free(info) + call x%bld(ncol,mold=mold) + else + call x%asb(ncol,info) + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_halo') + goto 9999 + end if + if (present(mold)) then + call x%cnv(mold) + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + +end subroutine psb_iasb_vect diff --git a/base/tools/psb_ifree.f90 b/base/tools/psb_ifree.f90 index 542d71e4..50c651ad 100644 --- a/base/tools/psb_ifree.f90 +++ b/base/tools/psb_ifree.f90 @@ -198,3 +198,63 @@ subroutine psb_ifreev(x, desc_a,info) return end subroutine psb_ifreev + + +subroutine psb_ifree_vect(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_ifree_vect + implicit none + !....parameters... + type(psb_i_vect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + !...locals.... + integer(psb_ipk_) :: ictxt,np,me,err_act + character(len=20) :: name + + + info=psb_success_ + if (psb_errstatus_fatal()) return + call psb_erractionsave(err_act) + name='psb_ifreev' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call x%free(info) + + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + +end subroutine psb_ifree_vect + diff --git a/base/tools/psb_iins.f90 b/base/tools/psb_iins.f90 index c8f0e11e..21914c55 100644 --- a/base/tools/psb_iins.f90 +++ b/base/tools/psb_iins.f90 @@ -366,3 +366,126 @@ subroutine psb_iinsi(m, irw, val, x, desc_a, info, dupl) return end subroutine psb_iinsi + + + +subroutine psb_iins_vect(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_iins_vect + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_ipk_), intent(in) :: val(:) + type(psb_i_vect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: ictxt,i,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_iinsvi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (x%get_nrows() < desc_a%get_local_rows()) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call psi_idx_cnv(m,irw,irl,desc_a,info,owned=.true.) + end if + call x%ins(m,irl,val,dupl_,info) + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error(ictxt) + end if + return + +end subroutine psb_iins_vect +