psblas:

base/comm/psb_ihalo.f90
 base/comm/psb_iovrl.f90

HALO/OVRL for multivectors.

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
+

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
+