From 88bbc06e06639570a5893c7ccc4ce80bffef9cec Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 17 Jul 2015 13:39:30 +0000 Subject: [PATCH] psblas: base/comm/psb_ihalo.f90 base/comm/psb_iovrl.f90 HALO/OVRL for multivectors. --- base/comm/psb_ihalo.f90 | 140 ++++++++++++++++++++++++++++++++++++++++ base/comm/psb_iovrl.f90 | 125 +++++++++++++++++++++++++++++++++++ 2 files changed, 265 insertions(+) diff --git a/base/comm/psb_ihalo.f90 b/base/comm/psb_ihalo.f90 index e8c9a9bf..3b0b5714 100644 --- a/base/comm/psb_ihalo.f90 +++ b/base/comm/psb_ihalo.f90 @@ -529,3 +529,143 @@ subroutine psb_ihalo_vect(x,desc_a,info,work,tran,mode,data) return end subroutine psb_ihalo_vect + + +subroutine psb_ihalo_multivect(x,desc_a,info,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_ihalo_multivect + use psi_mod + implicit none + + type(psb_i_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + 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 + + 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 call psb_error_handler(ictxt,err_act) + + return +end subroutine psb_ihalo_multivect + diff --git a/base/comm/psb_iovrl.f90 b/base/comm/psb_iovrl.f90 index 4248c14c..b75e092f 100644 --- a/base/comm/psb_iovrl.f90 +++ b/base/comm/psb_iovrl.f90 @@ -503,3 +503,128 @@ subroutine psb_iovrl_vect(x,desc_a,info,work,update,mode) return end subroutine psb_iovrl_vect + +subroutine psb_iovrl_multivect(x,desc_a,info,work,update,mode) + use psb_base_mod, psb_protect_name => psb_iovrl_multivect + use psi_mod + implicit none + + type(psb_i_multivect_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 call psb_error_handler(ictxt,err_act) + + return +end subroutine psb_iovrl_multivect +