psblas:

base/comm/psb_chalo.f90
 base/comm/psb_dhalo.f90
 base/comm/psb_shalo.f90
 base/comm/psb_zhalo.f90
 base/internals/psi_cswapdata.F90
 base/internals/psi_cswaptran.F90
 base/internals/psi_dswapdata.F90
 base/internals/psi_dswaptran.F90
 base/internals/psi_iswapdata.F90
 base/internals/psi_iswaptran.F90
 base/internals/psi_sswapdata.F90
 base/internals/psi_sswaptran.F90
 base/internals/psi_zswapdata.F90
 base/internals/psi_zswaptran.F90
 base/modules/psb_c_base_vect_mod.f90
 base/modules/psb_c_comm_mod.f90
 base/modules/psb_c_tools_mod.f90
 base/modules/psb_c_vect_mod.F90
 base/modules/psb_d_base_vect_mod.f90
 base/modules/psb_d_comm_mod.f90
 base/modules/psb_d_tools_mod.f90
 base/modules/psb_d_vect_mod.F90
 base/modules/psb_i_base_vect_mod.f90
 base/modules/psb_i_comm_mod.f90
 base/modules/psb_i_tools_mod.f90
 base/modules/psb_i_vect_mod.F90
 base/modules/psb_s_base_vect_mod.f90
 base/modules/psb_s_comm_mod.f90
 base/modules/psb_s_tools_mod.f90
 base/modules/psb_s_vect_mod.F90
 base/modules/psb_z_base_vect_mod.f90
 base/modules/psb_z_comm_mod.f90
 base/modules/psb_z_tools_mod.f90
 base/modules/psb_z_vect_mod.F90
 base/tools/psb_callc.f90
 base/tools/psb_casb.f90
 base/tools/psb_dallc.f90
 base/tools/psb_dasb.f90
 base/tools/psb_iallc.f90
 base/tools/psb_iasb.f90
 base/tools/psb_sallc.f90
 base/tools/psb_sasb.f90
 base/tools/psb_zallc.f90
 base/tools/psb_zasb.f90

Set up full support for multivectors, step 1: define GEALL/GEASB/HALO.

base/comm/psb_chalo.f90

@@ -529,3 +529,143 @@ subroutine  psb_chalo_vect(x,desc_a,info,work,tran,mode,data)
 
     return
 end subroutine psb_chalo_vect
+
+
+subroutine  psb_chalo_multivect(x,desc_a,info,work,tran,mode,data)
+  use psb_base_mod, psb_protect_name => psb_chalo_multivect
+  use psi_mod
+  implicit none
+
+  type(psb_c_multivect_type), intent(inout)    :: x
+  type(psb_desc_type), intent(in)         :: desc_a
+  integer(psb_ipk_), intent(out)                    :: info
+  complex(psb_spk_), 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_
+  complex(psb_spk_),pointer :: iwork(:)
+  character                 :: tran_
+  character(len=20)         :: name, ch_err
+  logical                   :: aliw
+
+  name='psb_chalov'
+  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,czero,x%v,&
+         & desc_a,iwork,info,data=data_)
+  else if((tran_ == 'T').or.(tran_ == 'C')) then
+    call psi_swaptran(imode,cone,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_chalo_multivect
+

base/comm/psb_dhalo.f90

@@ -529,3 +529,143 @@ subroutine  psb_dhalo_vect(x,desc_a,info,work,tran,mode,data)
 
     return
 end subroutine psb_dhalo_vect
+
+
+subroutine  psb_dhalo_multivect(x,desc_a,info,work,tran,mode,data)
+  use psb_base_mod, psb_protect_name => psb_dhalo_multivect
+  use psi_mod
+  implicit none
+
+  type(psb_d_multivect_type), intent(inout)    :: x
+  type(psb_desc_type), intent(in)         :: desc_a
+  integer(psb_ipk_), intent(out)                    :: info
+  real(psb_dpk_), 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_
+  real(psb_dpk_),pointer :: iwork(:)
+  character                 :: tran_
+  character(len=20)         :: name, ch_err
+  logical                   :: aliw
+
+  name='psb_dhalov'
+  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,dzero,x%v,&
+         & desc_a,iwork,info,data=data_)
+  else if((tran_ == 'T').or.(tran_ == 'C')) then
+    call psi_swaptran(imode,done,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_dhalo_multivect
+

base/comm/psb_shalo.f90

@@ -529,3 +529,143 @@ subroutine  psb_shalo_vect(x,desc_a,info,work,tran,mode,data)
 
     return
 end subroutine psb_shalo_vect
+
+
+subroutine  psb_shalo_multivect(x,desc_a,info,work,tran,mode,data)
+  use psb_base_mod, psb_protect_name => psb_shalo_multivect
+  use psi_mod
+  implicit none
+
+  type(psb_s_multivect_type), intent(inout)    :: x
+  type(psb_desc_type), intent(in)         :: desc_a
+  integer(psb_ipk_), intent(out)                    :: info
+  real(psb_spk_), 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_
+  real(psb_spk_),pointer :: iwork(:)
+  character                 :: tran_
+  character(len=20)         :: name, ch_err
+  logical                   :: aliw
+
+  name='psb_shalov'
+  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,szero,x%v,&
+         & desc_a,iwork,info,data=data_)
+  else if((tran_ == 'T').or.(tran_ == 'C')) then
+    call psi_swaptran(imode,sone,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_shalo_multivect
+

base/comm/psb_zhalo.f90

@@ -529,3 +529,143 @@ subroutine  psb_zhalo_vect(x,desc_a,info,work,tran,mode,data)
 
     return
 end subroutine psb_zhalo_vect
+
+
+subroutine  psb_zhalo_multivect(x,desc_a,info,work,tran,mode,data)
+  use psb_base_mod, psb_protect_name => psb_zhalo_multivect
+  use psi_mod
+  implicit none
+
+  type(psb_z_multivect_type), intent(inout)    :: x
+  type(psb_desc_type), intent(in)         :: desc_a
+  integer(psb_ipk_), intent(out)                    :: info
+  complex(psb_dpk_), 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_
+  complex(psb_dpk_),pointer :: iwork(:)
+  character                 :: tran_
+  character(len=20)         :: name, ch_err
+  logical                   :: aliw
+
+  name='psb_zhalov'
+  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,zzero,x%v,&
+         & desc_a,iwork,info,data=data_)
+  else if((tran_ == 'T').or.(tran_ == 'C')) then
+    call psi_swaptran(imode,zone,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_zhalo_multivect
+

base/internals/psi_cswapdata.F90

@@ -1010,7 +1010,6 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
 
     return
 end subroutine psi_cswapidxv
-
 !
 !
 ! Subroutine: psi_cswapdata_vect
@@ -1351,3 +1350,343 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
   return
 end subroutine psi_cswap_vidx_vect
 
+!
+!
+! Subroutine: psi_cswapdata_multivect
+!   Data exchange among processes.
+!
+!   Takes care of Y an exanspulated multivector.
+!   
+!   
+! 
+subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,work,info,data)
+
+  use psi_mod, psb_protect_name => psi_cswapdata_multivect
+  use psb_c_base_multivect_mod
+  use psb_error_mod
+  use psb_desc_mod
+  use psb_penv_mod
+#ifdef MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef MPI_H
+  include 'mpif.h'
+#endif
+
+  integer(psb_ipk_), intent(in)         :: flag
+  integer(psb_ipk_), intent(out)        :: info
+  class(psb_c_base_multivect_type) :: y
+  complex(psb_spk_)           :: beta
+  complex(psb_spk_), target   :: work(:)
+  type(psb_desc_type), target  :: desc_a
+  integer(psb_ipk_), optional           :: data
+
+  ! locals
+  integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
+  class(psb_i_base_vect_type), pointer :: d_vidx
+  character(len=20)  :: name
+
+  info=psb_success_
+  name='psi_swap_datav'
+  call psb_erractionsave(err_act)
+
+  ictxt=desc_a%get_context()
+  icomm = desc_a%get_mpic()
+
+  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.psb_is_asb_desc(desc_a)) then 
+    info=psb_err_invalid_cd_state_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  if(present(data)) then
+    data_ = data
+  else
+    data_ = psb_comm_halo_
+  end if
+
+  call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) 
+  if (info /= psb_success_) then 
+    call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
+    goto 9999
+  end if
+
+  call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+    return
+end subroutine psi_cswapdata_multivect
+
+
+!
+!
+! Subroutine: psi_cswap_vidx_multivect
+!   Data exchange among processes.
+!
+!   Takes care of Y an exanspulated multivector. Relies on the gather/scatter methods
+!   of multivectors. 
+!   
+!   The real workhorse: the outer routine will only choose the index list
+!   this one takes the index list and does the actual exchange. 
+!   
+!   
+! 
+subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
+     & totxch,totsnd,totrcv,work,info)
+
+  use psi_mod, psb_protect_name => psi_cswap_vidx_multivect
+  use psb_error_mod
+  use psb_realloc_mod
+  use psb_desc_mod
+  use psb_penv_mod
+  use psb_c_base_multivect_mod
+#ifdef MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef MPI_H
+  include 'mpif.h'
+#endif
+
+  integer(psb_ipk_), intent(in)         :: iictxt,iicomm,flag
+  integer(psb_ipk_), intent(out)        :: info
+  class(psb_c_base_multivect_type) :: y
+  complex(psb_spk_)           :: beta
+  complex(psb_spk_), target   :: work(:)
+  class(psb_i_base_vect_type), intent(inout) :: idx
+  integer(psb_ipk_), intent(in)              :: totxch,totsnd, totrcv
+
+  ! locals
+  integer(psb_mpik_) :: ictxt, icomm, np, me,&
+       & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
+  integer(psb_mpik_), allocatable :: prcid(:)
+  integer(psb_ipk_) :: nesd, nerv,&
+       & err_act, i, idx_pt, totsnd_, totrcv_,&
+       & snd_pt, rcv_pt, pnti, n
+  integer(psb_ipk_) :: ierr(5)
+  logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
+       & albf,do_send,do_recv
+  logical, parameter :: usersend=.false., debug=.false.
+  character(len=20)  :: name
+
+  info=psb_success_
+  name='psi_swap_datav'
+  call psb_erractionsave(err_act)
+  ictxt = iictxt
+  icomm = iicomm
+
+  call psb_info(ictxt,me,np) 
+  if (np == -1) then
+    info=psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  n=1
+
+  swap_mpi  = iand(flag,psb_swap_mpi_)  /= 0
+  swap_sync = iand(flag,psb_swap_sync_) /= 0
+  swap_send = iand(flag,psb_swap_send_) /= 0
+  swap_recv = iand(flag,psb_swap_recv_) /= 0
+  do_send = swap_mpi .or. swap_sync .or. swap_send
+  do_recv = swap_mpi .or. swap_sync .or. swap_recv
+
+  totrcv_ = totrcv * n
+  totsnd_ = totsnd * n
+  call idx%sync()
+
+  if (debug) write(*,*) me,'Internal buffer'
+  if (do_send) then 
+    if (allocated(y%comid)) then 
+      ! 
+      ! Unfinished communication? Something is wrong....
+      !
+      info=psb_err_mpi_error_
+      ierr(1) = -2
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,'do_send start'
+    call y%new_buffer(size(idx%v),info)
+    call y%new_comid(totxch,info)
+    call psb_realloc(totxch,prcid,info)
+    ! First I post all the non blocking receives
+    pnti   = 1
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+      call psb_get_rank(prcid(i),ictxt,proc_to_comm)      
+      if ((nerv>0).and.(proc_to_comm /= me)) then 
+        if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
+        p2ptag = psb_complex_swap_tag
+        call mpi_irecv(y%combuf(rcv_pt),nerv,&
+             & psb_mpi_c_spk_,prcid(i),&
+             & p2ptag, icomm,y%comid(i,2),iret)
+      end if
+      pnti   = pnti + nerv + nesd + 3
+    end do
+    if (debug) write(*,*) me,' Gather '
+    !
+    ! Then gather for sending.
+    !    
+    pnti   = 1
+    do i=1, totxch
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+      idx_pt = snd_pt
+      call y%gth(idx_pt,nesd,idx)
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    !
+    ! Then wait 
+    !
+    call y%device_wait()
+
+    if (debug) write(*,*) me,' isend'
+    !
+    ! Then send
+    !
+
+    pnti   = 1
+    snd_pt = 1
+    rcv_pt = 1
+    p2ptag = psb_complex_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if ((nesd>0).and.(proc_to_comm /= me)) then 
+        call mpi_isend(y%combuf(snd_pt),nesd,&
+             & psb_mpi_c_spk_,prcid(i),&
+             & p2ptag,icomm,y%comid(i,1),iret)
+      end if
+
+      if(iret /= mpi_success) then
+        ierr(1) = iret
+        info=psb_err_mpi_error_
+        call psb_errpush(info,name,i_err=ierr)
+        goto 9999
+      end if
+
+      pnti   = pnti + nerv + nesd + 3
+    end do
+  end if
+
+  if (do_recv) then 
+    if (debug) write(*,*) me,' do_Recv'
+    if (.not.allocated(y%comid)) then 
+      ! 
+      ! No matching send? Something is wrong....
+      !
+      info=psb_err_mpi_error_
+      ierr(1) = -2
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+    call psb_realloc(totxch,prcid,info)
+
+    if (debug) write(*,*) me,' wait'
+    pnti   = 1
+    p2ptag = psb_complex_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if (proc_to_comm /= me)then 
+        if (nesd>0) then 
+          call mpi_wait(y%comid(i,1),p2pstat,iret)
+          if(iret /= mpi_success) then
+            ierr(1) = iret
+            info=psb_err_mpi_error_
+            call psb_errpush(info,name,i_err=ierr)
+            goto 9999
+          end if
+        end if
+        if (nerv>0) then 
+          call mpi_wait(y%comid(i,2),p2pstat,iret)
+          if(iret /= mpi_success) then
+            ierr(1) = iret
+            info=psb_err_mpi_error_
+            call psb_errpush(info,name,i_err=ierr)
+            goto 9999
+          end if
+        end if
+      else if (proc_to_comm == me) then 
+        if (nesd /= nerv) then 
+          write(psb_err_unit,*) &
+               & 'Fatal error in swapdata: mismatch on self send',&
+               & nerv,nesd
+        end if
+        y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1)
+      end if
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    if (debug) write(*,*) me,' scatter'      
+    pnti   = 1
+    snd_pt = 1
+    rcv_pt = 1
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      idx_pt = 1+pnti+psb_n_elem_recv_
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if (debug) write(0,*)me,' Received from: ',prcid(i),&
+           & y%combuf(rcv_pt:rcv_pt+nerv-1)        
+      call y%sct(rcv_pt,nerv,idx,beta)
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+
+    !
+    ! Then wait 
+    !
+    if (debug) write(*,*) me,' wait'
+    call y%device_wait()
+    if (debug) write(*,*) me,' free buffer'
+    call y%free_buffer(info)
+    if (info == 0) call y%free_comid(info)
+    if (info /= 0) then 
+      call psb_errpush(psb_err_alloc_dealloc_,name)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,' done'
+  end if
+
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+end subroutine psi_cswap_vidx_multivect
+

base/internals/psi_cswaptran.F90

@@ -1379,4 +1379,354 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
 end subroutine psi_ctran_vidx_vect
 
 
+!
+!
+!
+!
+! Subroutine: psi_cswaptran_vect
+!   Data exchange among processes.
+!
+!   Takes care of Y an exanspulated vector.
+!   
+!   
+subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data)
+
+  use psi_mod, psb_protect_name => psi_cswaptran_multivect
+  use psb_c_base_vect_mod
+  use psb_error_mod
+  use psb_desc_mod
+  use psb_penv_mod
+#ifdef MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef MPI_H
+  include 'mpif.h'
+#endif
+
+  integer(psb_ipk_), intent(in)         :: flag
+  integer(psb_ipk_), intent(out)        :: info
+  class(psb_c_base_multivect_type) :: y
+  complex(psb_spk_)           :: beta
+  complex(psb_spk_), target   :: work(:)
+  type(psb_desc_type),target  :: desc_a
+  integer(psb_ipk_), optional    :: data
+
+  ! locals
+  integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
+  class(psb_i_base_vect_type), pointer :: d_vidx
+  integer(psb_ipk_) :: ierr(5)
+  character(len=20)  :: name
+
+  info=psb_success_
+  name='psi_swap_tranv'
+  call psb_erractionsave(err_act)
+
+  ictxt = desc_a%get_context()
+  icomm = desc_a%get_mpic()
+  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.psb_is_asb_desc(desc_a)) then 
+    info=psb_err_invalid_cd_state_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  if (present(data)) then
+    data_ = data
+  else
+    data_ = psb_comm_halo_
+  end if
+  
+  call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) 
+  if (info /= psb_success_) then 
+    call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
+    goto 9999
+  end if
+
+  call  psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+    return
+  end subroutine psi_cswaptran_multivect
+
+
+
+!
+!
+! Subroutine: psi_ctran_vidx_vect
+!   Data exchange among processes.
+!
+!   Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
+!   of vectors. 
+!   
+!   The real workhorse: the outer routine will only choose the index list
+!   this one takes the index list and does the actual exchange. 
+!   
+!   
+! 
+subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
+     & totxch,totsnd,totrcv,work,info)
+
+  use psi_mod, psb_protect_name => psi_ctran_vidx_multivect
+  use psb_error_mod
+  use psb_desc_mod
+  use psb_penv_mod
+  use psb_c_base_vect_mod
+#ifdef MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef MPI_H
+  include 'mpif.h'
+#endif
+
+  integer(psb_ipk_), intent(in)      :: iictxt,iicomm,flag
+  integer(psb_ipk_), intent(out)     :: info
+  class(psb_c_base_multivect_type) :: y
+  complex(psb_spk_)         :: beta
+  complex(psb_spk_), target :: work(:)
+  class(psb_i_base_vect_type), intent(inout) :: idx
+  integer(psb_ipk_), intent(in)      :: totxch,totsnd, totrcv
+
+  ! locals
+  integer(psb_mpik_) :: ictxt, icomm, np, me,&
+       & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
+  integer(psb_mpik_), allocatable :: prcid(:)
+  integer(psb_ipk_) :: nesd, nerv,&
+       & err_act, i, idx_pt, totsnd_, totrcv_,&
+       & snd_pt, rcv_pt, pnti, n
+  integer(psb_ipk_) :: ierr(5)
+  logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
+       & albf,do_send,do_recv
+  logical, parameter :: usersend=.false., debug=.false.
+  character(len=20)  :: name
+
+  info=psb_success_
+  name='psi_swap_tran'
+  call psb_erractionsave(err_act)
+  ictxt = iictxt
+  icomm = iicomm
+
+  call psb_info(ictxt,me,np) 
+  if (np == -1) then
+    info=psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  n=1
+  swap_mpi  = iand(flag,psb_swap_mpi_) /= 0
+  swap_sync = iand(flag,psb_swap_sync_) /= 0
+  swap_send = iand(flag,psb_swap_send_) /= 0
+  swap_recv = iand(flag,psb_swap_recv_) /= 0
+  do_send = swap_mpi .or. swap_sync .or. swap_send
+  do_recv = swap_mpi .or. swap_sync .or. swap_recv
+
+  totrcv_ = totrcv * n
+  totsnd_ = totsnd * n
+
+  call idx%sync()
+
+  if (debug) write(*,*) me,'Internal buffer'
+  if (do_send) then 
+    if (allocated(y%comid)) then 
+      ! 
+      ! Unfinished communication? Something is wrong....
+      !
+      info=psb_err_mpi_error_
+      ierr(1) = -2
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,'do_send start'
+    call y%new_buffer(size(idx%v),info)
+    call y%new_comid(totxch,info)
+    call psb_realloc(totxch,prcid,info)
+    ! First I post all the non blocking receives
+    pnti   = 1
+    p2ptag = psb_complex_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+      call psb_get_rank(prcid(i),ictxt,proc_to_comm)      
+      if ((nesd>0).and.(proc_to_comm /= me)) then 
+        if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
+        call mpi_irecv(y%combuf(snd_pt),nesd,&
+             & psb_mpi_c_spk_,prcid(i),&
+             & p2ptag, icomm,y%comid(i,2),iret)
+      end if
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    if (debug) write(*,*) me,' Gather '
+    !
+    ! Then gather for sending.
+    !    
+    pnti   = 1
+    snd_pt = 1
+    do i=1, totxch
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      idx_pt = rcv_pt
+      call y%gth(idx_pt,nerv,idx)
+
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    !
+    ! Then wait 
+    !
+    call y%device_wait()
+
+    if (debug) write(*,*) me,' isend'
+
+    !
+    ! Then send
+    !
+
+    pnti   = 1
+    snd_pt = 1
+    rcv_pt = 1
+    p2ptag = psb_complex_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if ((nerv>0).and.(proc_to_comm /= me)) then 
+        call mpi_isend(y%combuf(rcv_pt),nerv,&
+             & psb_mpi_c_spk_,prcid(i),&
+             & p2ptag,icomm,y%comid(i,1),iret)
+      end if
+
+      if(iret /= mpi_success) then
+        ierr(1) = iret
+        info=psb_err_mpi_error_
+        call psb_errpush(info,name,i_err=ierr)
+        goto 9999
+      end if
+
+      pnti   = pnti + nerv + nesd + 3
+    end do
+  end if
+
+  if (do_recv) then 
+    if (debug) write(*,*) me,' do_Recv'
+    if (.not.allocated(y%comid)) then 
+      ! 
+      ! No matching send? Something is wrong....
+      !
+      info=psb_err_mpi_error_
+      ierr(1) = -2
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+    call psb_realloc(totxch,prcid,info)
+
+    if (debug) write(*,*) me,' wait'
+    pnti   = 1
+    p2ptag = psb_complex_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if (proc_to_comm /= me)then 
+        if (nerv>0) then 
+          call mpi_wait(y%comid(i,1),p2pstat,iret)
+          if(iret /= mpi_success) then
+            ierr(1) = iret
+            info=psb_err_mpi_error_
+            call psb_errpush(info,name,i_err=ierr)
+            goto 9999
+          end if
+        end if
+        if (nesd>0) then 
+          call mpi_wait(y%comid(i,2),p2pstat,iret)
+          if(iret /= mpi_success) then
+            ierr(1) = iret
+            info=psb_err_mpi_error_
+            call psb_errpush(info,name,i_err=ierr)
+            goto 9999
+          end if
+        end if
+      else if (proc_to_comm == me) then 
+        if (nesd /= nerv) then 
+          write(psb_err_unit,*) &
+               & 'Fatal error in swapdata: mismatch on self send',&
+               & nerv,nesd
+        end if
+        y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) 
+      end if
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    if (debug) write(*,*) me,' scatter'      
+    pnti   = 1
+    snd_pt = 1
+    rcv_pt = 1
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      idx_pt = 1+pnti+psb_n_elem_recv_
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if (debug) write(0,*)me,' Received from: ',prcid(i),&
+           & y%combuf(snd_pt:snd_pt+nesd-1)        
+      call y%sct(snd_pt,nesd,idx,beta)
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+  
+    !
+    ! Then wait 
+    !
+    if (debug) write(*,*) me,' wait'
+    call y%device_wait()
+    if (debug) write(*,*) me,' free buffer'
+    call y%free_buffer(info)
+    if (info == 0) call y%free_comid(info)
+    if (info /= 0) then 
+      call psb_errpush(psb_err_alloc_dealloc_,name)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,' done'
+  end if
+
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psi_ctran_vidx_multivect
+
+
+
 

base/internals/psi_dswapdata.F90

@@ -1010,7 +1010,6 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, &
 
     return
 end subroutine psi_dswapidxv
-
 !
 !
 ! Subroutine: psi_dswapdata_vect
@@ -1351,3 +1350,343 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
   return
 end subroutine psi_dswap_vidx_vect
 
+!
+!
+! Subroutine: psi_dswapdata_multivect
+!   Data exchange among processes.
+!
+!   Takes care of Y an exanspulated multivector.
+!   
+!   
+! 
+subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data)
+
+  use psi_mod, psb_protect_name => psi_dswapdata_multivect
+  use psb_d_base_multivect_mod
+  use psb_error_mod
+  use psb_desc_mod
+  use psb_penv_mod
+#ifdef MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef MPI_H
+  include 'mpif.h'
+#endif
+
+  integer(psb_ipk_), intent(in)         :: flag
+  integer(psb_ipk_), intent(out)        :: info
+  class(psb_d_base_multivect_type) :: y
+  real(psb_dpk_)           :: beta
+  real(psb_dpk_), target   :: work(:)
+  type(psb_desc_type), target  :: desc_a
+  integer(psb_ipk_), optional           :: data
+
+  ! locals
+  integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
+  class(psb_i_base_vect_type), pointer :: d_vidx
+  character(len=20)  :: name
+
+  info=psb_success_
+  name='psi_swap_datav'
+  call psb_erractionsave(err_act)
+
+  ictxt=desc_a%get_context()
+  icomm = desc_a%get_mpic()
+
+  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.psb_is_asb_desc(desc_a)) then 
+    info=psb_err_invalid_cd_state_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  if(present(data)) then
+    data_ = data
+  else
+    data_ = psb_comm_halo_
+  end if
+
+  call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) 
+  if (info /= psb_success_) then 
+    call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
+    goto 9999
+  end if
+
+  call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+    return
+end subroutine psi_dswapdata_multivect
+
+
+!
+!
+! Subroutine: psi_dswap_vidx_multivect
+!   Data exchange among processes.
+!
+!   Takes care of Y an exanspulated multivector. Relies on the gather/scatter methods
+!   of multivectors. 
+!   
+!   The real workhorse: the outer routine will only choose the index list
+!   this one takes the index list and does the actual exchange. 
+!   
+!   
+! 
+subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
+     & totxch,totsnd,totrcv,work,info)
+
+  use psi_mod, psb_protect_name => psi_dswap_vidx_multivect
+  use psb_error_mod
+  use psb_realloc_mod
+  use psb_desc_mod
+  use psb_penv_mod
+  use psb_d_base_multivect_mod
+#ifdef MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef MPI_H
+  include 'mpif.h'
+#endif
+
+  integer(psb_ipk_), intent(in)         :: iictxt,iicomm,flag
+  integer(psb_ipk_), intent(out)        :: info
+  class(psb_d_base_multivect_type) :: y
+  real(psb_dpk_)           :: beta
+  real(psb_dpk_), target   :: work(:)
+  class(psb_i_base_vect_type), intent(inout) :: idx
+  integer(psb_ipk_), intent(in)              :: totxch,totsnd, totrcv
+
+  ! locals
+  integer(psb_mpik_) :: ictxt, icomm, np, me,&
+       & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
+  integer(psb_mpik_), allocatable :: prcid(:)
+  integer(psb_ipk_) :: nesd, nerv,&
+       & err_act, i, idx_pt, totsnd_, totrcv_,&
+       & snd_pt, rcv_pt, pnti, n
+  integer(psb_ipk_) :: ierr(5)
+  logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
+       & albf,do_send,do_recv
+  logical, parameter :: usersend=.false., debug=.false.
+  character(len=20)  :: name
+
+  info=psb_success_
+  name='psi_swap_datav'
+  call psb_erractionsave(err_act)
+  ictxt = iictxt
+  icomm = iicomm
+
+  call psb_info(ictxt,me,np) 
+  if (np == -1) then
+    info=psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  n=1
+
+  swap_mpi  = iand(flag,psb_swap_mpi_)  /= 0
+  swap_sync = iand(flag,psb_swap_sync_) /= 0
+  swap_send = iand(flag,psb_swap_send_) /= 0
+  swap_recv = iand(flag,psb_swap_recv_) /= 0
+  do_send = swap_mpi .or. swap_sync .or. swap_send
+  do_recv = swap_mpi .or. swap_sync .or. swap_recv
+
+  totrcv_ = totrcv * n
+  totsnd_ = totsnd * n
+  call idx%sync()
+
+  if (debug) write(*,*) me,'Internal buffer'
+  if (do_send) then 
+    if (allocated(y%comid)) then 
+      ! 
+      ! Unfinished communication? Something is wrong....
+      !
+      info=psb_err_mpi_error_
+      ierr(1) = -2
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,'do_send start'
+    call y%new_buffer(size(idx%v),info)
+    call y%new_comid(totxch,info)
+    call psb_realloc(totxch,prcid,info)
+    ! First I post all the non blocking receives
+    pnti   = 1
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+      call psb_get_rank(prcid(i),ictxt,proc_to_comm)      
+      if ((nerv>0).and.(proc_to_comm /= me)) then 
+        if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
+        p2ptag = psb_double_swap_tag
+        call mpi_irecv(y%combuf(rcv_pt),nerv,&
+             & psb_mpi_r_dpk_,prcid(i),&
+             & p2ptag, icomm,y%comid(i,2),iret)
+      end if
+      pnti   = pnti + nerv + nesd + 3
+    end do
+    if (debug) write(*,*) me,' Gather '
+    !
+    ! Then gather for sending.
+    !    
+    pnti   = 1
+    do i=1, totxch
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+      idx_pt = snd_pt
+      call y%gth(idx_pt,nesd,idx)
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    !
+    ! Then wait 
+    !
+    call y%device_wait()
+
+    if (debug) write(*,*) me,' isend'
+    !
+    ! Then send
+    !
+
+    pnti   = 1
+    snd_pt = 1
+    rcv_pt = 1
+    p2ptag = psb_double_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if ((nesd>0).and.(proc_to_comm /= me)) then 
+        call mpi_isend(y%combuf(snd_pt),nesd,&
+             & psb_mpi_r_dpk_,prcid(i),&
+             & p2ptag,icomm,y%comid(i,1),iret)
+      end if
+
+      if(iret /= mpi_success) then
+        ierr(1) = iret
+        info=psb_err_mpi_error_
+        call psb_errpush(info,name,i_err=ierr)
+        goto 9999
+      end if
+
+      pnti   = pnti + nerv + nesd + 3
+    end do
+  end if
+
+  if (do_recv) then 
+    if (debug) write(*,*) me,' do_Recv'
+    if (.not.allocated(y%comid)) then 
+      ! 
+      ! No matching send? Something is wrong....
+      !
+      info=psb_err_mpi_error_
+      ierr(1) = -2
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+    call psb_realloc(totxch,prcid,info)
+
+    if (debug) write(*,*) me,' wait'
+    pnti   = 1
+    p2ptag = psb_double_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if (proc_to_comm /= me)then 
+        if (nesd>0) then 
+          call mpi_wait(y%comid(i,1),p2pstat,iret)
+          if(iret /= mpi_success) then
+            ierr(1) = iret
+            info=psb_err_mpi_error_
+            call psb_errpush(info,name,i_err=ierr)
+            goto 9999
+          end if
+        end if
+        if (nerv>0) then 
+          call mpi_wait(y%comid(i,2),p2pstat,iret)
+          if(iret /= mpi_success) then
+            ierr(1) = iret
+            info=psb_err_mpi_error_
+            call psb_errpush(info,name,i_err=ierr)
+            goto 9999
+          end if
+        end if
+      else if (proc_to_comm == me) then 
+        if (nesd /= nerv) then 
+          write(psb_err_unit,*) &
+               & 'Fatal error in swapdata: mismatch on self send',&
+               & nerv,nesd
+        end if
+        y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1)
+      end if
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    if (debug) write(*,*) me,' scatter'      
+    pnti   = 1
+    snd_pt = 1
+    rcv_pt = 1
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      idx_pt = 1+pnti+psb_n_elem_recv_
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if (debug) write(0,*)me,' Received from: ',prcid(i),&
+           & y%combuf(rcv_pt:rcv_pt+nerv-1)        
+      call y%sct(rcv_pt,nerv,idx,beta)
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+
+    !
+    ! Then wait 
+    !
+    if (debug) write(*,*) me,' wait'
+    call y%device_wait()
+    if (debug) write(*,*) me,' free buffer'
+    call y%free_buffer(info)
+    if (info == 0) call y%free_comid(info)
+    if (info /= 0) then 
+      call psb_errpush(psb_err_alloc_dealloc_,name)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,' done'
+  end if
+
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+end subroutine psi_dswap_vidx_multivect
+

base/internals/psi_dswaptran.F90

@@ -1379,4 +1379,354 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
 end subroutine psi_dtran_vidx_vect
 
 
+!
+!
+!
+!
+! Subroutine: psi_dswaptran_vect
+!   Data exchange among processes.
+!
+!   Takes care of Y an exanspulated vector.
+!   
+!   
+subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,work,info,data)
+
+  use psi_mod, psb_protect_name => psi_dswaptran_multivect
+  use psb_d_base_vect_mod
+  use psb_error_mod
+  use psb_desc_mod
+  use psb_penv_mod
+#ifdef MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef MPI_H
+  include 'mpif.h'
+#endif
+
+  integer(psb_ipk_), intent(in)         :: flag
+  integer(psb_ipk_), intent(out)        :: info
+  class(psb_d_base_multivect_type) :: y
+  real(psb_dpk_)           :: beta
+  real(psb_dpk_), target   :: work(:)
+  type(psb_desc_type),target  :: desc_a
+  integer(psb_ipk_), optional    :: data
+
+  ! locals
+  integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
+  class(psb_i_base_vect_type), pointer :: d_vidx
+  integer(psb_ipk_) :: ierr(5)
+  character(len=20)  :: name
+
+  info=psb_success_
+  name='psi_swap_tranv'
+  call psb_erractionsave(err_act)
+
+  ictxt = desc_a%get_context()
+  icomm = desc_a%get_mpic()
+  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.psb_is_asb_desc(desc_a)) then 
+    info=psb_err_invalid_cd_state_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  if (present(data)) then
+    data_ = data
+  else
+    data_ = psb_comm_halo_
+  end if
+  
+  call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) 
+  if (info /= psb_success_) then 
+    call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
+    goto 9999
+  end if
+
+  call  psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+    return
+  end subroutine psi_dswaptran_multivect
+
+
+
+!
+!
+! Subroutine: psi_dtran_vidx_vect
+!   Data exchange among processes.
+!
+!   Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
+!   of vectors. 
+!   
+!   The real workhorse: the outer routine will only choose the index list
+!   this one takes the index list and does the actual exchange. 
+!   
+!   
+! 
+subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
+     & totxch,totsnd,totrcv,work,info)
+
+  use psi_mod, psb_protect_name => psi_dtran_vidx_multivect
+  use psb_error_mod
+  use psb_desc_mod
+  use psb_penv_mod
+  use psb_d_base_vect_mod
+#ifdef MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef MPI_H
+  include 'mpif.h'
+#endif
+
+  integer(psb_ipk_), intent(in)      :: iictxt,iicomm,flag
+  integer(psb_ipk_), intent(out)     :: info
+  class(psb_d_base_multivect_type) :: y
+  real(psb_dpk_)         :: beta
+  real(psb_dpk_), target :: work(:)
+  class(psb_i_base_vect_type), intent(inout) :: idx
+  integer(psb_ipk_), intent(in)      :: totxch,totsnd, totrcv
+
+  ! locals
+  integer(psb_mpik_) :: ictxt, icomm, np, me,&
+       & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
+  integer(psb_mpik_), allocatable :: prcid(:)
+  integer(psb_ipk_) :: nesd, nerv,&
+       & err_act, i, idx_pt, totsnd_, totrcv_,&
+       & snd_pt, rcv_pt, pnti, n
+  integer(psb_ipk_) :: ierr(5)
+  logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
+       & albf,do_send,do_recv
+  logical, parameter :: usersend=.false., debug=.false.
+  character(len=20)  :: name
+
+  info=psb_success_
+  name='psi_swap_tran'
+  call psb_erractionsave(err_act)
+  ictxt = iictxt
+  icomm = iicomm
+
+  call psb_info(ictxt,me,np) 
+  if (np == -1) then
+    info=psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  n=1
+  swap_mpi  = iand(flag,psb_swap_mpi_) /= 0
+  swap_sync = iand(flag,psb_swap_sync_) /= 0
+  swap_send = iand(flag,psb_swap_send_) /= 0
+  swap_recv = iand(flag,psb_swap_recv_) /= 0
+  do_send = swap_mpi .or. swap_sync .or. swap_send
+  do_recv = swap_mpi .or. swap_sync .or. swap_recv
+
+  totrcv_ = totrcv * n
+  totsnd_ = totsnd * n
+
+  call idx%sync()
+
+  if (debug) write(*,*) me,'Internal buffer'
+  if (do_send) then 
+    if (allocated(y%comid)) then 
+      ! 
+      ! Unfinished communication? Something is wrong....
+      !
+      info=psb_err_mpi_error_
+      ierr(1) = -2
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,'do_send start'
+    call y%new_buffer(size(idx%v),info)
+    call y%new_comid(totxch,info)
+    call psb_realloc(totxch,prcid,info)
+    ! First I post all the non blocking receives
+    pnti   = 1
+    p2ptag = psb_double_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+      call psb_get_rank(prcid(i),ictxt,proc_to_comm)      
+      if ((nesd>0).and.(proc_to_comm /= me)) then 
+        if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
+        call mpi_irecv(y%combuf(snd_pt),nesd,&
+             & psb_mpi_r_dpk_,prcid(i),&
+             & p2ptag, icomm,y%comid(i,2),iret)
+      end if
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    if (debug) write(*,*) me,' Gather '
+    !
+    ! Then gather for sending.
+    !    
+    pnti   = 1
+    snd_pt = 1
+    do i=1, totxch
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      idx_pt = rcv_pt
+      call y%gth(idx_pt,nerv,idx)
+
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    !
+    ! Then wait 
+    !
+    call y%device_wait()
+
+    if (debug) write(*,*) me,' isend'
+
+    !
+    ! Then send
+    !
+
+    pnti   = 1
+    snd_pt = 1
+    rcv_pt = 1
+    p2ptag = psb_double_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if ((nerv>0).and.(proc_to_comm /= me)) then 
+        call mpi_isend(y%combuf(rcv_pt),nerv,&
+             & psb_mpi_r_dpk_,prcid(i),&
+             & p2ptag,icomm,y%comid(i,1),iret)
+      end if
+
+      if(iret /= mpi_success) then
+        ierr(1) = iret
+        info=psb_err_mpi_error_
+        call psb_errpush(info,name,i_err=ierr)
+        goto 9999
+      end if
+
+      pnti   = pnti + nerv + nesd + 3
+    end do
+  end if
+
+  if (do_recv) then 
+    if (debug) write(*,*) me,' do_Recv'
+    if (.not.allocated(y%comid)) then 
+      ! 
+      ! No matching send? Something is wrong....
+      !
+      info=psb_err_mpi_error_
+      ierr(1) = -2
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+    call psb_realloc(totxch,prcid,info)
+
+    if (debug) write(*,*) me,' wait'
+    pnti   = 1
+    p2ptag = psb_double_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if (proc_to_comm /= me)then 
+        if (nerv>0) then 
+          call mpi_wait(y%comid(i,1),p2pstat,iret)
+          if(iret /= mpi_success) then
+            ierr(1) = iret
+            info=psb_err_mpi_error_
+            call psb_errpush(info,name,i_err=ierr)
+            goto 9999
+          end if
+        end if
+        if (nesd>0) then 
+          call mpi_wait(y%comid(i,2),p2pstat,iret)
+          if(iret /= mpi_success) then
+            ierr(1) = iret
+            info=psb_err_mpi_error_
+            call psb_errpush(info,name,i_err=ierr)
+            goto 9999
+          end if
+        end if
+      else if (proc_to_comm == me) then 
+        if (nesd /= nerv) then 
+          write(psb_err_unit,*) &
+               & 'Fatal error in swapdata: mismatch on self send',&
+               & nerv,nesd
+        end if
+        y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) 
+      end if
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    if (debug) write(*,*) me,' scatter'      
+    pnti   = 1
+    snd_pt = 1
+    rcv_pt = 1
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      idx_pt = 1+pnti+psb_n_elem_recv_
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if (debug) write(0,*)me,' Received from: ',prcid(i),&
+           & y%combuf(snd_pt:snd_pt+nesd-1)        
+      call y%sct(snd_pt,nesd,idx,beta)
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+  
+    !
+    ! Then wait 
+    !
+    if (debug) write(*,*) me,' wait'
+    call y%device_wait()
+    if (debug) write(*,*) me,' free buffer'
+    call y%free_buffer(info)
+    if (info == 0) call y%free_comid(info)
+    if (info /= 0) then 
+      call psb_errpush(psb_err_alloc_dealloc_,name)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,' done'
+  end if
+
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psi_dtran_vidx_multivect
+
+
+
 

base/internals/psi_iswapdata.F90

@@ -1010,7 +1010,6 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
 
     return
 end subroutine psi_iswapidxv
-
 !
 !
 ! Subroutine: psi_iswapdata_vect
@@ -1351,3 +1350,343 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
   return
 end subroutine psi_iswap_vidx_vect
 
+!
+!
+! Subroutine: psi_iswapdata_multivect
+!   Data exchange among processes.
+!
+!   Takes care of Y an exanspulated multivector.
+!   
+!   
+! 
+subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data)
+
+  use psi_mod, psb_protect_name => psi_iswapdata_multivect
+  use psb_i_base_multivect_mod
+  use psb_error_mod
+  use psb_desc_mod
+  use psb_penv_mod
+#ifdef MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef MPI_H
+  include 'mpif.h'
+#endif
+
+  integer(psb_ipk_), intent(in)         :: flag
+  integer(psb_ipk_), intent(out)        :: info
+  class(psb_i_base_multivect_type) :: y
+  integer(psb_ipk_)           :: beta
+  integer(psb_ipk_), target   :: work(:)
+  type(psb_desc_type), target  :: desc_a
+  integer(psb_ipk_), optional           :: data
+
+  ! locals
+  integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
+  class(psb_i_base_vect_type), pointer :: d_vidx
+  character(len=20)  :: name
+
+  info=psb_success_
+  name='psi_swap_datav'
+  call psb_erractionsave(err_act)
+
+  ictxt=desc_a%get_context()
+  icomm = desc_a%get_mpic()
+
+  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.psb_is_asb_desc(desc_a)) then 
+    info=psb_err_invalid_cd_state_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  if(present(data)) then
+    data_ = data
+  else
+    data_ = psb_comm_halo_
+  end if
+
+  call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) 
+  if (info /= psb_success_) then 
+    call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
+    goto 9999
+  end if
+
+  call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+    return
+end subroutine psi_iswapdata_multivect
+
+
+!
+!
+! Subroutine: psi_iswap_vidx_multivect
+!   Data exchange among processes.
+!
+!   Takes care of Y an exanspulated multivector. Relies on the gather/scatter methods
+!   of multivectors. 
+!   
+!   The real workhorse: the outer routine will only choose the index list
+!   this one takes the index list and does the actual exchange. 
+!   
+!   
+! 
+subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
+     & totxch,totsnd,totrcv,work,info)
+
+  use psi_mod, psb_protect_name => psi_iswap_vidx_multivect
+  use psb_error_mod
+  use psb_realloc_mod
+  use psb_desc_mod
+  use psb_penv_mod
+  use psb_i_base_multivect_mod
+#ifdef MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef MPI_H
+  include 'mpif.h'
+#endif
+
+  integer(psb_ipk_), intent(in)         :: iictxt,iicomm,flag
+  integer(psb_ipk_), intent(out)        :: info
+  class(psb_i_base_multivect_type) :: y
+  integer(psb_ipk_)           :: beta
+  integer(psb_ipk_), target   :: work(:)
+  class(psb_i_base_vect_type), intent(inout) :: idx
+  integer(psb_ipk_), intent(in)              :: totxch,totsnd, totrcv
+
+  ! locals
+  integer(psb_mpik_) :: ictxt, icomm, np, me,&
+       & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
+  integer(psb_mpik_), allocatable :: prcid(:)
+  integer(psb_ipk_) :: nesd, nerv,&
+       & err_act, i, idx_pt, totsnd_, totrcv_,&
+       & snd_pt, rcv_pt, pnti, n
+  integer(psb_ipk_) :: ierr(5)
+  logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
+       & albf,do_send,do_recv
+  logical, parameter :: usersend=.false., debug=.false.
+  character(len=20)  :: name
+
+  info=psb_success_
+  name='psi_swap_datav'
+  call psb_erractionsave(err_act)
+  ictxt = iictxt
+  icomm = iicomm
+
+  call psb_info(ictxt,me,np) 
+  if (np == -1) then
+    info=psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  n=1
+
+  swap_mpi  = iand(flag,psb_swap_mpi_)  /= 0
+  swap_sync = iand(flag,psb_swap_sync_) /= 0
+  swap_send = iand(flag,psb_swap_send_) /= 0
+  swap_recv = iand(flag,psb_swap_recv_) /= 0
+  do_send = swap_mpi .or. swap_sync .or. swap_send
+  do_recv = swap_mpi .or. swap_sync .or. swap_recv
+
+  totrcv_ = totrcv * n
+  totsnd_ = totsnd * n
+  call idx%sync()
+
+  if (debug) write(*,*) me,'Internal buffer'
+  if (do_send) then 
+    if (allocated(y%comid)) then 
+      ! 
+      ! Unfinished communication? Something is wrong....
+      !
+      info=psb_err_mpi_error_
+      ierr(1) = -2
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,'do_send start'
+    call y%new_buffer(size(idx%v),info)
+    call y%new_comid(totxch,info)
+    call psb_realloc(totxch,prcid,info)
+    ! First I post all the non blocking receives
+    pnti   = 1
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+      call psb_get_rank(prcid(i),ictxt,proc_to_comm)      
+      if ((nerv>0).and.(proc_to_comm /= me)) then 
+        if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
+        p2ptag = psb_int_swap_tag
+        call mpi_irecv(y%combuf(rcv_pt),nerv,&
+             & psb_mpi_ipk_integer,prcid(i),&
+             & p2ptag, icomm,y%comid(i,2),iret)
+      end if
+      pnti   = pnti + nerv + nesd + 3
+    end do
+    if (debug) write(*,*) me,' Gather '
+    !
+    ! Then gather for sending.
+    !    
+    pnti   = 1
+    do i=1, totxch
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+      idx_pt = snd_pt
+      call y%gth(idx_pt,nesd,idx)
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    !
+    ! Then wait 
+    !
+    call y%device_wait()
+
+    if (debug) write(*,*) me,' isend'
+    !
+    ! Then send
+    !
+
+    pnti   = 1
+    snd_pt = 1
+    rcv_pt = 1
+    p2ptag = psb_int_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if ((nesd>0).and.(proc_to_comm /= me)) then 
+        call mpi_isend(y%combuf(snd_pt),nesd,&
+             & psb_mpi_ipk_integer,prcid(i),&
+             & p2ptag,icomm,y%comid(i,1),iret)
+      end if
+
+      if(iret /= mpi_success) then
+        ierr(1) = iret
+        info=psb_err_mpi_error_
+        call psb_errpush(info,name,i_err=ierr)
+        goto 9999
+      end if
+
+      pnti   = pnti + nerv + nesd + 3
+    end do
+  end if
+
+  if (do_recv) then 
+    if (debug) write(*,*) me,' do_Recv'
+    if (.not.allocated(y%comid)) then 
+      ! 
+      ! No matching send? Something is wrong....
+      !
+      info=psb_err_mpi_error_
+      ierr(1) = -2
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+    call psb_realloc(totxch,prcid,info)
+
+    if (debug) write(*,*) me,' wait'
+    pnti   = 1
+    p2ptag = psb_int_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if (proc_to_comm /= me)then 
+        if (nesd>0) then 
+          call mpi_wait(y%comid(i,1),p2pstat,iret)
+          if(iret /= mpi_success) then
+            ierr(1) = iret
+            info=psb_err_mpi_error_
+            call psb_errpush(info,name,i_err=ierr)
+            goto 9999
+          end if
+        end if
+        if (nerv>0) then 
+          call mpi_wait(y%comid(i,2),p2pstat,iret)
+          if(iret /= mpi_success) then
+            ierr(1) = iret
+            info=psb_err_mpi_error_
+            call psb_errpush(info,name,i_err=ierr)
+            goto 9999
+          end if
+        end if
+      else if (proc_to_comm == me) then 
+        if (nesd /= nerv) then 
+          write(psb_err_unit,*) &
+               & 'Fatal error in swapdata: mismatch on self send',&
+               & nerv,nesd
+        end if
+        y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1)
+      end if
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    if (debug) write(*,*) me,' scatter'      
+    pnti   = 1
+    snd_pt = 1
+    rcv_pt = 1
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      idx_pt = 1+pnti+psb_n_elem_recv_
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if (debug) write(0,*)me,' Received from: ',prcid(i),&
+           & y%combuf(rcv_pt:rcv_pt+nerv-1)        
+      call y%sct(rcv_pt,nerv,idx,beta)
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+
+    !
+    ! Then wait 
+    !
+    if (debug) write(*,*) me,' wait'
+    call y%device_wait()
+    if (debug) write(*,*) me,' free buffer'
+    call y%free_buffer(info)
+    if (info == 0) call y%free_comid(info)
+    if (info /= 0) then 
+      call psb_errpush(psb_err_alloc_dealloc_,name)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,' done'
+  end if
+
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+end subroutine psi_iswap_vidx_multivect
+

base/internals/psi_iswaptran.F90

@@ -1379,4 +1379,354 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
 end subroutine psi_itran_vidx_vect
 
 
+!
+!
+!
+!
+! Subroutine: psi_iswaptran_vect
+!   Data exchange among processes.
+!
+!   Takes care of Y an exanspulated vector.
+!   
+!   
+subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data)
+
+  use psi_mod, psb_protect_name => psi_iswaptran_multivect
+  use psb_i_base_vect_mod
+  use psb_error_mod
+  use psb_desc_mod
+  use psb_penv_mod
+#ifdef MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef MPI_H
+  include 'mpif.h'
+#endif
+
+  integer(psb_ipk_), intent(in)         :: flag
+  integer(psb_ipk_), intent(out)        :: info
+  class(psb_i_base_multivect_type) :: y
+  integer(psb_ipk_)           :: beta
+  integer(psb_ipk_), target   :: work(:)
+  type(psb_desc_type),target  :: desc_a
+  integer(psb_ipk_), optional    :: data
+
+  ! locals
+  integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
+  class(psb_i_base_vect_type), pointer :: d_vidx
+  integer(psb_ipk_) :: ierr(5)
+  character(len=20)  :: name
+
+  info=psb_success_
+  name='psi_swap_tranv'
+  call psb_erractionsave(err_act)
+
+  ictxt = desc_a%get_context()
+  icomm = desc_a%get_mpic()
+  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.psb_is_asb_desc(desc_a)) then 
+    info=psb_err_invalid_cd_state_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  if (present(data)) then
+    data_ = data
+  else
+    data_ = psb_comm_halo_
+  end if
+  
+  call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) 
+  if (info /= psb_success_) then 
+    call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
+    goto 9999
+  end if
+
+  call  psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+    return
+  end subroutine psi_iswaptran_multivect
+
+
+
+!
+!
+! Subroutine: psi_itran_vidx_vect
+!   Data exchange among processes.
+!
+!   Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
+!   of vectors. 
+!   
+!   The real workhorse: the outer routine will only choose the index list
+!   this one takes the index list and does the actual exchange. 
+!   
+!   
+! 
+subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
+     & totxch,totsnd,totrcv,work,info)
+
+  use psi_mod, psb_protect_name => psi_itran_vidx_multivect
+  use psb_error_mod
+  use psb_desc_mod
+  use psb_penv_mod
+  use psb_i_base_vect_mod
+#ifdef MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef MPI_H
+  include 'mpif.h'
+#endif
+
+  integer(psb_ipk_), intent(in)      :: iictxt,iicomm,flag
+  integer(psb_ipk_), intent(out)     :: info
+  class(psb_i_base_multivect_type) :: y
+  integer(psb_ipk_)         :: beta
+  integer(psb_ipk_), target :: work(:)
+  class(psb_i_base_vect_type), intent(inout) :: idx
+  integer(psb_ipk_), intent(in)      :: totxch,totsnd, totrcv
+
+  ! locals
+  integer(psb_mpik_) :: ictxt, icomm, np, me,&
+       & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
+  integer(psb_mpik_), allocatable :: prcid(:)
+  integer(psb_ipk_) :: nesd, nerv,&
+       & err_act, i, idx_pt, totsnd_, totrcv_,&
+       & snd_pt, rcv_pt, pnti, n
+  integer(psb_ipk_) :: ierr(5)
+  logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
+       & albf,do_send,do_recv
+  logical, parameter :: usersend=.false., debug=.false.
+  character(len=20)  :: name
+
+  info=psb_success_
+  name='psi_swap_tran'
+  call psb_erractionsave(err_act)
+  ictxt = iictxt
+  icomm = iicomm
+
+  call psb_info(ictxt,me,np) 
+  if (np == -1) then
+    info=psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  n=1
+  swap_mpi  = iand(flag,psb_swap_mpi_) /= 0
+  swap_sync = iand(flag,psb_swap_sync_) /= 0
+  swap_send = iand(flag,psb_swap_send_) /= 0
+  swap_recv = iand(flag,psb_swap_recv_) /= 0
+  do_send = swap_mpi .or. swap_sync .or. swap_send
+  do_recv = swap_mpi .or. swap_sync .or. swap_recv
+
+  totrcv_ = totrcv * n
+  totsnd_ = totsnd * n
+
+  call idx%sync()
+
+  if (debug) write(*,*) me,'Internal buffer'
+  if (do_send) then 
+    if (allocated(y%comid)) then 
+      ! 
+      ! Unfinished communication? Something is wrong....
+      !
+      info=psb_err_mpi_error_
+      ierr(1) = -2
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,'do_send start'
+    call y%new_buffer(size(idx%v),info)
+    call y%new_comid(totxch,info)
+    call psb_realloc(totxch,prcid,info)
+    ! First I post all the non blocking receives
+    pnti   = 1
+    p2ptag = psb_int_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+      call psb_get_rank(prcid(i),ictxt,proc_to_comm)      
+      if ((nesd>0).and.(proc_to_comm /= me)) then 
+        if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
+        call mpi_irecv(y%combuf(snd_pt),nesd,&
+             & psb_mpi_ipk_integer,prcid(i),&
+             & p2ptag, icomm,y%comid(i,2),iret)
+      end if
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    if (debug) write(*,*) me,' Gather '
+    !
+    ! Then gather for sending.
+    !    
+    pnti   = 1
+    snd_pt = 1
+    do i=1, totxch
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      idx_pt = rcv_pt
+      call y%gth(idx_pt,nerv,idx)
+
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    !
+    ! Then wait 
+    !
+    call y%device_wait()
+
+    if (debug) write(*,*) me,' isend'
+
+    !
+    ! Then send
+    !
+
+    pnti   = 1
+    snd_pt = 1
+    rcv_pt = 1
+    p2ptag = psb_int_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if ((nerv>0).and.(proc_to_comm /= me)) then 
+        call mpi_isend(y%combuf(rcv_pt),nerv,&
+             & psb_mpi_ipk_integer,prcid(i),&
+             & p2ptag,icomm,y%comid(i,1),iret)
+      end if
+
+      if(iret /= mpi_success) then
+        ierr(1) = iret
+        info=psb_err_mpi_error_
+        call psb_errpush(info,name,i_err=ierr)
+        goto 9999
+      end if
+
+      pnti   = pnti + nerv + nesd + 3
+    end do
+  end if
+
+  if (do_recv) then 
+    if (debug) write(*,*) me,' do_Recv'
+    if (.not.allocated(y%comid)) then 
+      ! 
+      ! No matching send? Something is wrong....
+      !
+      info=psb_err_mpi_error_
+      ierr(1) = -2
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+    call psb_realloc(totxch,prcid,info)
+
+    if (debug) write(*,*) me,' wait'
+    pnti   = 1
+    p2ptag = psb_int_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if (proc_to_comm /= me)then 
+        if (nerv>0) then 
+          call mpi_wait(y%comid(i,1),p2pstat,iret)
+          if(iret /= mpi_success) then
+            ierr(1) = iret
+            info=psb_err_mpi_error_
+            call psb_errpush(info,name,i_err=ierr)
+            goto 9999
+          end if
+        end if
+        if (nesd>0) then 
+          call mpi_wait(y%comid(i,2),p2pstat,iret)
+          if(iret /= mpi_success) then
+            ierr(1) = iret
+            info=psb_err_mpi_error_
+            call psb_errpush(info,name,i_err=ierr)
+            goto 9999
+          end if
+        end if
+      else if (proc_to_comm == me) then 
+        if (nesd /= nerv) then 
+          write(psb_err_unit,*) &
+               & 'Fatal error in swapdata: mismatch on self send',&
+               & nerv,nesd
+        end if
+        y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) 
+      end if
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    if (debug) write(*,*) me,' scatter'      
+    pnti   = 1
+    snd_pt = 1
+    rcv_pt = 1
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      idx_pt = 1+pnti+psb_n_elem_recv_
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if (debug) write(0,*)me,' Received from: ',prcid(i),&
+           & y%combuf(snd_pt:snd_pt+nesd-1)        
+      call y%sct(snd_pt,nesd,idx,beta)
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+  
+    !
+    ! Then wait 
+    !
+    if (debug) write(*,*) me,' wait'
+    call y%device_wait()
+    if (debug) write(*,*) me,' free buffer'
+    call y%free_buffer(info)
+    if (info == 0) call y%free_comid(info)
+    if (info /= 0) then 
+      call psb_errpush(psb_err_alloc_dealloc_,name)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,' done'
+  end if
+
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psi_itran_vidx_multivect
+
+
+
 

base/internals/psi_sswapdata.F90

@@ -1010,7 +1010,6 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
 
     return
 end subroutine psi_sswapidxv
-
 !
 !
 ! Subroutine: psi_sswapdata_vect
@@ -1351,3 +1350,343 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
   return
 end subroutine psi_sswap_vidx_vect
 
+!
+!
+! Subroutine: psi_sswapdata_multivect
+!   Data exchange among processes.
+!
+!   Takes care of Y an exanspulated multivector.
+!   
+!   
+! 
+subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,work,info,data)
+
+  use psi_mod, psb_protect_name => psi_sswapdata_multivect
+  use psb_s_base_multivect_mod
+  use psb_error_mod
+  use psb_desc_mod
+  use psb_penv_mod
+#ifdef MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef MPI_H
+  include 'mpif.h'
+#endif
+
+  integer(psb_ipk_), intent(in)         :: flag
+  integer(psb_ipk_), intent(out)        :: info
+  class(psb_s_base_multivect_type) :: y
+  real(psb_spk_)           :: beta
+  real(psb_spk_), target   :: work(:)
+  type(psb_desc_type), target  :: desc_a
+  integer(psb_ipk_), optional           :: data
+
+  ! locals
+  integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
+  class(psb_i_base_vect_type), pointer :: d_vidx
+  character(len=20)  :: name
+
+  info=psb_success_
+  name='psi_swap_datav'
+  call psb_erractionsave(err_act)
+
+  ictxt=desc_a%get_context()
+  icomm = desc_a%get_mpic()
+
+  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.psb_is_asb_desc(desc_a)) then 
+    info=psb_err_invalid_cd_state_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  if(present(data)) then
+    data_ = data
+  else
+    data_ = psb_comm_halo_
+  end if
+
+  call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) 
+  if (info /= psb_success_) then 
+    call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
+    goto 9999
+  end if
+
+  call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+    return
+end subroutine psi_sswapdata_multivect
+
+
+!
+!
+! Subroutine: psi_sswap_vidx_multivect
+!   Data exchange among processes.
+!
+!   Takes care of Y an exanspulated multivector. Relies on the gather/scatter methods
+!   of multivectors. 
+!   
+!   The real workhorse: the outer routine will only choose the index list
+!   this one takes the index list and does the actual exchange. 
+!   
+!   
+! 
+subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
+     & totxch,totsnd,totrcv,work,info)
+
+  use psi_mod, psb_protect_name => psi_sswap_vidx_multivect
+  use psb_error_mod
+  use psb_realloc_mod
+  use psb_desc_mod
+  use psb_penv_mod
+  use psb_s_base_multivect_mod
+#ifdef MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef MPI_H
+  include 'mpif.h'
+#endif
+
+  integer(psb_ipk_), intent(in)         :: iictxt,iicomm,flag
+  integer(psb_ipk_), intent(out)        :: info
+  class(psb_s_base_multivect_type) :: y
+  real(psb_spk_)           :: beta
+  real(psb_spk_), target   :: work(:)
+  class(psb_i_base_vect_type), intent(inout) :: idx
+  integer(psb_ipk_), intent(in)              :: totxch,totsnd, totrcv
+
+  ! locals
+  integer(psb_mpik_) :: ictxt, icomm, np, me,&
+       & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
+  integer(psb_mpik_), allocatable :: prcid(:)
+  integer(psb_ipk_) :: nesd, nerv,&
+       & err_act, i, idx_pt, totsnd_, totrcv_,&
+       & snd_pt, rcv_pt, pnti, n
+  integer(psb_ipk_) :: ierr(5)
+  logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
+       & albf,do_send,do_recv
+  logical, parameter :: usersend=.false., debug=.false.
+  character(len=20)  :: name
+
+  info=psb_success_
+  name='psi_swap_datav'
+  call psb_erractionsave(err_act)
+  ictxt = iictxt
+  icomm = iicomm
+
+  call psb_info(ictxt,me,np) 
+  if (np == -1) then
+    info=psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  n=1
+
+  swap_mpi  = iand(flag,psb_swap_mpi_)  /= 0
+  swap_sync = iand(flag,psb_swap_sync_) /= 0
+  swap_send = iand(flag,psb_swap_send_) /= 0
+  swap_recv = iand(flag,psb_swap_recv_) /= 0
+  do_send = swap_mpi .or. swap_sync .or. swap_send
+  do_recv = swap_mpi .or. swap_sync .or. swap_recv
+
+  totrcv_ = totrcv * n
+  totsnd_ = totsnd * n
+  call idx%sync()
+
+  if (debug) write(*,*) me,'Internal buffer'
+  if (do_send) then 
+    if (allocated(y%comid)) then 
+      ! 
+      ! Unfinished communication? Something is wrong....
+      !
+      info=psb_err_mpi_error_
+      ierr(1) = -2
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,'do_send start'
+    call y%new_buffer(size(idx%v),info)
+    call y%new_comid(totxch,info)
+    call psb_realloc(totxch,prcid,info)
+    ! First I post all the non blocking receives
+    pnti   = 1
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+      call psb_get_rank(prcid(i),ictxt,proc_to_comm)      
+      if ((nerv>0).and.(proc_to_comm /= me)) then 
+        if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
+        p2ptag = psb_real_swap_tag
+        call mpi_irecv(y%combuf(rcv_pt),nerv,&
+             & psb_mpi_r_spk_,prcid(i),&
+             & p2ptag, icomm,y%comid(i,2),iret)
+      end if
+      pnti   = pnti + nerv + nesd + 3
+    end do
+    if (debug) write(*,*) me,' Gather '
+    !
+    ! Then gather for sending.
+    !    
+    pnti   = 1
+    do i=1, totxch
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+      idx_pt = snd_pt
+      call y%gth(idx_pt,nesd,idx)
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    !
+    ! Then wait 
+    !
+    call y%device_wait()
+
+    if (debug) write(*,*) me,' isend'
+    !
+    ! Then send
+    !
+
+    pnti   = 1
+    snd_pt = 1
+    rcv_pt = 1
+    p2ptag = psb_real_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if ((nesd>0).and.(proc_to_comm /= me)) then 
+        call mpi_isend(y%combuf(snd_pt),nesd,&
+             & psb_mpi_r_spk_,prcid(i),&
+             & p2ptag,icomm,y%comid(i,1),iret)
+      end if
+
+      if(iret /= mpi_success) then
+        ierr(1) = iret
+        info=psb_err_mpi_error_
+        call psb_errpush(info,name,i_err=ierr)
+        goto 9999
+      end if
+
+      pnti   = pnti + nerv + nesd + 3
+    end do
+  end if
+
+  if (do_recv) then 
+    if (debug) write(*,*) me,' do_Recv'
+    if (.not.allocated(y%comid)) then 
+      ! 
+      ! No matching send? Something is wrong....
+      !
+      info=psb_err_mpi_error_
+      ierr(1) = -2
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+    call psb_realloc(totxch,prcid,info)
+
+    if (debug) write(*,*) me,' wait'
+    pnti   = 1
+    p2ptag = psb_real_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if (proc_to_comm /= me)then 
+        if (nesd>0) then 
+          call mpi_wait(y%comid(i,1),p2pstat,iret)
+          if(iret /= mpi_success) then
+            ierr(1) = iret
+            info=psb_err_mpi_error_
+            call psb_errpush(info,name,i_err=ierr)
+            goto 9999
+          end if
+        end if
+        if (nerv>0) then 
+          call mpi_wait(y%comid(i,2),p2pstat,iret)
+          if(iret /= mpi_success) then
+            ierr(1) = iret
+            info=psb_err_mpi_error_
+            call psb_errpush(info,name,i_err=ierr)
+            goto 9999
+          end if
+        end if
+      else if (proc_to_comm == me) then 
+        if (nesd /= nerv) then 
+          write(psb_err_unit,*) &
+               & 'Fatal error in swapdata: mismatch on self send',&
+               & nerv,nesd
+        end if
+        y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1)
+      end if
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    if (debug) write(*,*) me,' scatter'      
+    pnti   = 1
+    snd_pt = 1
+    rcv_pt = 1
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      idx_pt = 1+pnti+psb_n_elem_recv_
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if (debug) write(0,*)me,' Received from: ',prcid(i),&
+           & y%combuf(rcv_pt:rcv_pt+nerv-1)        
+      call y%sct(rcv_pt,nerv,idx,beta)
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+
+    !
+    ! Then wait 
+    !
+    if (debug) write(*,*) me,' wait'
+    call y%device_wait()
+    if (debug) write(*,*) me,' free buffer'
+    call y%free_buffer(info)
+    if (info == 0) call y%free_comid(info)
+    if (info /= 0) then 
+      call psb_errpush(psb_err_alloc_dealloc_,name)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,' done'
+  end if
+
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+end subroutine psi_sswap_vidx_multivect
+

base/internals/psi_sswaptran.F90

@@ -1379,4 +1379,354 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
 end subroutine psi_stran_vidx_vect
 
 
+!
+!
+!
+!
+! Subroutine: psi_sswaptran_vect
+!   Data exchange among processes.
+!
+!   Takes care of Y an exanspulated vector.
+!   
+!   
+subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data)
+
+  use psi_mod, psb_protect_name => psi_sswaptran_multivect
+  use psb_s_base_vect_mod
+  use psb_error_mod
+  use psb_desc_mod
+  use psb_penv_mod
+#ifdef MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef MPI_H
+  include 'mpif.h'
+#endif
+
+  integer(psb_ipk_), intent(in)         :: flag
+  integer(psb_ipk_), intent(out)        :: info
+  class(psb_s_base_multivect_type) :: y
+  real(psb_spk_)           :: beta
+  real(psb_spk_), target   :: work(:)
+  type(psb_desc_type),target  :: desc_a
+  integer(psb_ipk_), optional    :: data
+
+  ! locals
+  integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
+  class(psb_i_base_vect_type), pointer :: d_vidx
+  integer(psb_ipk_) :: ierr(5)
+  character(len=20)  :: name
+
+  info=psb_success_
+  name='psi_swap_tranv'
+  call psb_erractionsave(err_act)
+
+  ictxt = desc_a%get_context()
+  icomm = desc_a%get_mpic()
+  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.psb_is_asb_desc(desc_a)) then 
+    info=psb_err_invalid_cd_state_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  if (present(data)) then
+    data_ = data
+  else
+    data_ = psb_comm_halo_
+  end if
+  
+  call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) 
+  if (info /= psb_success_) then 
+    call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
+    goto 9999
+  end if
+
+  call  psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+    return
+  end subroutine psi_sswaptran_multivect
+
+
+
+!
+!
+! Subroutine: psi_stran_vidx_vect
+!   Data exchange among processes.
+!
+!   Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
+!   of vectors. 
+!   
+!   The real workhorse: the outer routine will only choose the index list
+!   this one takes the index list and does the actual exchange. 
+!   
+!   
+! 
+subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
+     & totxch,totsnd,totrcv,work,info)
+
+  use psi_mod, psb_protect_name => psi_stran_vidx_multivect
+  use psb_error_mod
+  use psb_desc_mod
+  use psb_penv_mod
+  use psb_s_base_vect_mod
+#ifdef MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef MPI_H
+  include 'mpif.h'
+#endif
+
+  integer(psb_ipk_), intent(in)      :: iictxt,iicomm,flag
+  integer(psb_ipk_), intent(out)     :: info
+  class(psb_s_base_multivect_type) :: y
+  real(psb_spk_)         :: beta
+  real(psb_spk_), target :: work(:)
+  class(psb_i_base_vect_type), intent(inout) :: idx
+  integer(psb_ipk_), intent(in)      :: totxch,totsnd, totrcv
+
+  ! locals
+  integer(psb_mpik_) :: ictxt, icomm, np, me,&
+       & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
+  integer(psb_mpik_), allocatable :: prcid(:)
+  integer(psb_ipk_) :: nesd, nerv,&
+       & err_act, i, idx_pt, totsnd_, totrcv_,&
+       & snd_pt, rcv_pt, pnti, n
+  integer(psb_ipk_) :: ierr(5)
+  logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
+       & albf,do_send,do_recv
+  logical, parameter :: usersend=.false., debug=.false.
+  character(len=20)  :: name
+
+  info=psb_success_
+  name='psi_swap_tran'
+  call psb_erractionsave(err_act)
+  ictxt = iictxt
+  icomm = iicomm
+
+  call psb_info(ictxt,me,np) 
+  if (np == -1) then
+    info=psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  n=1
+  swap_mpi  = iand(flag,psb_swap_mpi_) /= 0
+  swap_sync = iand(flag,psb_swap_sync_) /= 0
+  swap_send = iand(flag,psb_swap_send_) /= 0
+  swap_recv = iand(flag,psb_swap_recv_) /= 0
+  do_send = swap_mpi .or. swap_sync .or. swap_send
+  do_recv = swap_mpi .or. swap_sync .or. swap_recv
+
+  totrcv_ = totrcv * n
+  totsnd_ = totsnd * n
+
+  call idx%sync()
+
+  if (debug) write(*,*) me,'Internal buffer'
+  if (do_send) then 
+    if (allocated(y%comid)) then 
+      ! 
+      ! Unfinished communication? Something is wrong....
+      !
+      info=psb_err_mpi_error_
+      ierr(1) = -2
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,'do_send start'
+    call y%new_buffer(size(idx%v),info)
+    call y%new_comid(totxch,info)
+    call psb_realloc(totxch,prcid,info)
+    ! First I post all the non blocking receives
+    pnti   = 1
+    p2ptag = psb_real_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+      call psb_get_rank(prcid(i),ictxt,proc_to_comm)      
+      if ((nesd>0).and.(proc_to_comm /= me)) then 
+        if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
+        call mpi_irecv(y%combuf(snd_pt),nesd,&
+             & psb_mpi_r_spk_,prcid(i),&
+             & p2ptag, icomm,y%comid(i,2),iret)
+      end if
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    if (debug) write(*,*) me,' Gather '
+    !
+    ! Then gather for sending.
+    !    
+    pnti   = 1
+    snd_pt = 1
+    do i=1, totxch
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      idx_pt = rcv_pt
+      call y%gth(idx_pt,nerv,idx)
+
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    !
+    ! Then wait 
+    !
+    call y%device_wait()
+
+    if (debug) write(*,*) me,' isend'
+
+    !
+    ! Then send
+    !
+
+    pnti   = 1
+    snd_pt = 1
+    rcv_pt = 1
+    p2ptag = psb_real_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if ((nerv>0).and.(proc_to_comm /= me)) then 
+        call mpi_isend(y%combuf(rcv_pt),nerv,&
+             & psb_mpi_r_spk_,prcid(i),&
+             & p2ptag,icomm,y%comid(i,1),iret)
+      end if
+
+      if(iret /= mpi_success) then
+        ierr(1) = iret
+        info=psb_err_mpi_error_
+        call psb_errpush(info,name,i_err=ierr)
+        goto 9999
+      end if
+
+      pnti   = pnti + nerv + nesd + 3
+    end do
+  end if
+
+  if (do_recv) then 
+    if (debug) write(*,*) me,' do_Recv'
+    if (.not.allocated(y%comid)) then 
+      ! 
+      ! No matching send? Something is wrong....
+      !
+      info=psb_err_mpi_error_
+      ierr(1) = -2
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+    call psb_realloc(totxch,prcid,info)
+
+    if (debug) write(*,*) me,' wait'
+    pnti   = 1
+    p2ptag = psb_real_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if (proc_to_comm /= me)then 
+        if (nerv>0) then 
+          call mpi_wait(y%comid(i,1),p2pstat,iret)
+          if(iret /= mpi_success) then
+            ierr(1) = iret
+            info=psb_err_mpi_error_
+            call psb_errpush(info,name,i_err=ierr)
+            goto 9999
+          end if
+        end if
+        if (nesd>0) then 
+          call mpi_wait(y%comid(i,2),p2pstat,iret)
+          if(iret /= mpi_success) then
+            ierr(1) = iret
+            info=psb_err_mpi_error_
+            call psb_errpush(info,name,i_err=ierr)
+            goto 9999
+          end if
+        end if
+      else if (proc_to_comm == me) then 
+        if (nesd /= nerv) then 
+          write(psb_err_unit,*) &
+               & 'Fatal error in swapdata: mismatch on self send',&
+               & nerv,nesd
+        end if
+        y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) 
+      end if
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    if (debug) write(*,*) me,' scatter'      
+    pnti   = 1
+    snd_pt = 1
+    rcv_pt = 1
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      idx_pt = 1+pnti+psb_n_elem_recv_
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if (debug) write(0,*)me,' Received from: ',prcid(i),&
+           & y%combuf(snd_pt:snd_pt+nesd-1)        
+      call y%sct(snd_pt,nesd,idx,beta)
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+  
+    !
+    ! Then wait 
+    !
+    if (debug) write(*,*) me,' wait'
+    call y%device_wait()
+    if (debug) write(*,*) me,' free buffer'
+    call y%free_buffer(info)
+    if (info == 0) call y%free_comid(info)
+    if (info /= 0) then 
+      call psb_errpush(psb_err_alloc_dealloc_,name)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,' done'
+  end if
+
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psi_stran_vidx_multivect
+
+
+
 

base/internals/psi_zswapdata.F90

@@ -1010,7 +1010,6 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
 
     return
 end subroutine psi_zswapidxv
-
 !
 !
 ! Subroutine: psi_zswapdata_vect
@@ -1351,3 +1350,343 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
   return
 end subroutine psi_zswap_vidx_vect
 
+!
+!
+! Subroutine: psi_zswapdata_multivect
+!   Data exchange among processes.
+!
+!   Takes care of Y an exanspulated multivector.
+!   
+!   
+! 
+subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,work,info,data)
+
+  use psi_mod, psb_protect_name => psi_zswapdata_multivect
+  use psb_z_base_multivect_mod
+  use psb_error_mod
+  use psb_desc_mod
+  use psb_penv_mod
+#ifdef MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef MPI_H
+  include 'mpif.h'
+#endif
+
+  integer(psb_ipk_), intent(in)         :: flag
+  integer(psb_ipk_), intent(out)        :: info
+  class(psb_z_base_multivect_type) :: y
+  complex(psb_dpk_)           :: beta
+  complex(psb_dpk_), target   :: work(:)
+  type(psb_desc_type), target  :: desc_a
+  integer(psb_ipk_), optional           :: data
+
+  ! locals
+  integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
+  class(psb_i_base_vect_type), pointer :: d_vidx
+  character(len=20)  :: name
+
+  info=psb_success_
+  name='psi_swap_datav'
+  call psb_erractionsave(err_act)
+
+  ictxt=desc_a%get_context()
+  icomm = desc_a%get_mpic()
+
+  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.psb_is_asb_desc(desc_a)) then 
+    info=psb_err_invalid_cd_state_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  if(present(data)) then
+    data_ = data
+  else
+    data_ = psb_comm_halo_
+  end if
+
+  call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) 
+  if (info /= psb_success_) then 
+    call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
+    goto 9999
+  end if
+
+  call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+    return
+end subroutine psi_zswapdata_multivect
+
+
+!
+!
+! Subroutine: psi_zswap_vidx_multivect
+!   Data exchange among processes.
+!
+!   Takes care of Y an exanspulated multivector. Relies on the gather/scatter methods
+!   of multivectors. 
+!   
+!   The real workhorse: the outer routine will only choose the index list
+!   this one takes the index list and does the actual exchange. 
+!   
+!   
+! 
+subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
+     & totxch,totsnd,totrcv,work,info)
+
+  use psi_mod, psb_protect_name => psi_zswap_vidx_multivect
+  use psb_error_mod
+  use psb_realloc_mod
+  use psb_desc_mod
+  use psb_penv_mod
+  use psb_z_base_multivect_mod
+#ifdef MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef MPI_H
+  include 'mpif.h'
+#endif
+
+  integer(psb_ipk_), intent(in)         :: iictxt,iicomm,flag
+  integer(psb_ipk_), intent(out)        :: info
+  class(psb_z_base_multivect_type) :: y
+  complex(psb_dpk_)           :: beta
+  complex(psb_dpk_), target   :: work(:)
+  class(psb_i_base_vect_type), intent(inout) :: idx
+  integer(psb_ipk_), intent(in)              :: totxch,totsnd, totrcv
+
+  ! locals
+  integer(psb_mpik_) :: ictxt, icomm, np, me,&
+       & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
+  integer(psb_mpik_), allocatable :: prcid(:)
+  integer(psb_ipk_) :: nesd, nerv,&
+       & err_act, i, idx_pt, totsnd_, totrcv_,&
+       & snd_pt, rcv_pt, pnti, n
+  integer(psb_ipk_) :: ierr(5)
+  logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
+       & albf,do_send,do_recv
+  logical, parameter :: usersend=.false., debug=.false.
+  character(len=20)  :: name
+
+  info=psb_success_
+  name='psi_swap_datav'
+  call psb_erractionsave(err_act)
+  ictxt = iictxt
+  icomm = iicomm
+
+  call psb_info(ictxt,me,np) 
+  if (np == -1) then
+    info=psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  n=1
+
+  swap_mpi  = iand(flag,psb_swap_mpi_)  /= 0
+  swap_sync = iand(flag,psb_swap_sync_) /= 0
+  swap_send = iand(flag,psb_swap_send_) /= 0
+  swap_recv = iand(flag,psb_swap_recv_) /= 0
+  do_send = swap_mpi .or. swap_sync .or. swap_send
+  do_recv = swap_mpi .or. swap_sync .or. swap_recv
+
+  totrcv_ = totrcv * n
+  totsnd_ = totsnd * n
+  call idx%sync()
+
+  if (debug) write(*,*) me,'Internal buffer'
+  if (do_send) then 
+    if (allocated(y%comid)) then 
+      ! 
+      ! Unfinished communication? Something is wrong....
+      !
+      info=psb_err_mpi_error_
+      ierr(1) = -2
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,'do_send start'
+    call y%new_buffer(size(idx%v),info)
+    call y%new_comid(totxch,info)
+    call psb_realloc(totxch,prcid,info)
+    ! First I post all the non blocking receives
+    pnti   = 1
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+      call psb_get_rank(prcid(i),ictxt,proc_to_comm)      
+      if ((nerv>0).and.(proc_to_comm /= me)) then 
+        if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
+        p2ptag = psb_dcomplex_swap_tag
+        call mpi_irecv(y%combuf(rcv_pt),nerv,&
+             & psb_mpi_c_dpk_,prcid(i),&
+             & p2ptag, icomm,y%comid(i,2),iret)
+      end if
+      pnti   = pnti + nerv + nesd + 3
+    end do
+    if (debug) write(*,*) me,' Gather '
+    !
+    ! Then gather for sending.
+    !    
+    pnti   = 1
+    do i=1, totxch
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+      idx_pt = snd_pt
+      call y%gth(idx_pt,nesd,idx)
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    !
+    ! Then wait 
+    !
+    call y%device_wait()
+
+    if (debug) write(*,*) me,' isend'
+    !
+    ! Then send
+    !
+
+    pnti   = 1
+    snd_pt = 1
+    rcv_pt = 1
+    p2ptag = psb_dcomplex_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if ((nesd>0).and.(proc_to_comm /= me)) then 
+        call mpi_isend(y%combuf(snd_pt),nesd,&
+             & psb_mpi_c_dpk_,prcid(i),&
+             & p2ptag,icomm,y%comid(i,1),iret)
+      end if
+
+      if(iret /= mpi_success) then
+        ierr(1) = iret
+        info=psb_err_mpi_error_
+        call psb_errpush(info,name,i_err=ierr)
+        goto 9999
+      end if
+
+      pnti   = pnti + nerv + nesd + 3
+    end do
+  end if
+
+  if (do_recv) then 
+    if (debug) write(*,*) me,' do_Recv'
+    if (.not.allocated(y%comid)) then 
+      ! 
+      ! No matching send? Something is wrong....
+      !
+      info=psb_err_mpi_error_
+      ierr(1) = -2
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+    call psb_realloc(totxch,prcid,info)
+
+    if (debug) write(*,*) me,' wait'
+    pnti   = 1
+    p2ptag = psb_dcomplex_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if (proc_to_comm /= me)then 
+        if (nesd>0) then 
+          call mpi_wait(y%comid(i,1),p2pstat,iret)
+          if(iret /= mpi_success) then
+            ierr(1) = iret
+            info=psb_err_mpi_error_
+            call psb_errpush(info,name,i_err=ierr)
+            goto 9999
+          end if
+        end if
+        if (nerv>0) then 
+          call mpi_wait(y%comid(i,2),p2pstat,iret)
+          if(iret /= mpi_success) then
+            ierr(1) = iret
+            info=psb_err_mpi_error_
+            call psb_errpush(info,name,i_err=ierr)
+            goto 9999
+          end if
+        end if
+      else if (proc_to_comm == me) then 
+        if (nesd /= nerv) then 
+          write(psb_err_unit,*) &
+               & 'Fatal error in swapdata: mismatch on self send',&
+               & nerv,nesd
+        end if
+        y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1)
+      end if
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    if (debug) write(*,*) me,' scatter'      
+    pnti   = 1
+    snd_pt = 1
+    rcv_pt = 1
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      idx_pt = 1+pnti+psb_n_elem_recv_
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if (debug) write(0,*)me,' Received from: ',prcid(i),&
+           & y%combuf(rcv_pt:rcv_pt+nerv-1)        
+      call y%sct(rcv_pt,nerv,idx,beta)
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+
+    !
+    ! Then wait 
+    !
+    if (debug) write(*,*) me,' wait'
+    call y%device_wait()
+    if (debug) write(*,*) me,' free buffer'
+    call y%free_buffer(info)
+    if (info == 0) call y%free_comid(info)
+    if (info /= 0) then 
+      call psb_errpush(psb_err_alloc_dealloc_,name)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,' done'
+  end if
+
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+end subroutine psi_zswap_vidx_multivect
+

base/internals/psi_zswaptran.F90

@@ -1379,4 +1379,354 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
 end subroutine psi_ztran_vidx_vect
 
 
+!
+!
+!
+!
+! Subroutine: psi_zswaptran_vect
+!   Data exchange among processes.
+!
+!   Takes care of Y an exanspulated vector.
+!   
+!   
+subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data)
+
+  use psi_mod, psb_protect_name => psi_zswaptran_multivect
+  use psb_z_base_vect_mod
+  use psb_error_mod
+  use psb_desc_mod
+  use psb_penv_mod
+#ifdef MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef MPI_H
+  include 'mpif.h'
+#endif
+
+  integer(psb_ipk_), intent(in)         :: flag
+  integer(psb_ipk_), intent(out)        :: info
+  class(psb_z_base_multivect_type) :: y
+  complex(psb_dpk_)           :: beta
+  complex(psb_dpk_), target   :: work(:)
+  type(psb_desc_type),target  :: desc_a
+  integer(psb_ipk_), optional    :: data
+
+  ! locals
+  integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
+  class(psb_i_base_vect_type), pointer :: d_vidx
+  integer(psb_ipk_) :: ierr(5)
+  character(len=20)  :: name
+
+  info=psb_success_
+  name='psi_swap_tranv'
+  call psb_erractionsave(err_act)
+
+  ictxt = desc_a%get_context()
+  icomm = desc_a%get_mpic()
+  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.psb_is_asb_desc(desc_a)) then 
+    info=psb_err_invalid_cd_state_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  if (present(data)) then
+    data_ = data
+  else
+    data_ = psb_comm_halo_
+  end if
+  
+  call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) 
+  if (info /= psb_success_) then 
+    call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
+    goto 9999
+  end if
+
+  call  psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+    return
+  end subroutine psi_zswaptran_multivect
+
+
+
+!
+!
+! Subroutine: psi_ztran_vidx_vect
+!   Data exchange among processes.
+!
+!   Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
+!   of vectors. 
+!   
+!   The real workhorse: the outer routine will only choose the index list
+!   this one takes the index list and does the actual exchange. 
+!   
+!   
+! 
+subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
+     & totxch,totsnd,totrcv,work,info)
+
+  use psi_mod, psb_protect_name => psi_ztran_vidx_multivect
+  use psb_error_mod
+  use psb_desc_mod
+  use psb_penv_mod
+  use psb_z_base_vect_mod
+#ifdef MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef MPI_H
+  include 'mpif.h'
+#endif
+
+  integer(psb_ipk_), intent(in)      :: iictxt,iicomm,flag
+  integer(psb_ipk_), intent(out)     :: info
+  class(psb_z_base_multivect_type) :: y
+  complex(psb_dpk_)         :: beta
+  complex(psb_dpk_), target :: work(:)
+  class(psb_i_base_vect_type), intent(inout) :: idx
+  integer(psb_ipk_), intent(in)      :: totxch,totsnd, totrcv
+
+  ! locals
+  integer(psb_mpik_) :: ictxt, icomm, np, me,&
+       & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
+  integer(psb_mpik_), allocatable :: prcid(:)
+  integer(psb_ipk_) :: nesd, nerv,&
+       & err_act, i, idx_pt, totsnd_, totrcv_,&
+       & snd_pt, rcv_pt, pnti, n
+  integer(psb_ipk_) :: ierr(5)
+  logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
+       & albf,do_send,do_recv
+  logical, parameter :: usersend=.false., debug=.false.
+  character(len=20)  :: name
+
+  info=psb_success_
+  name='psi_swap_tran'
+  call psb_erractionsave(err_act)
+  ictxt = iictxt
+  icomm = iicomm
+
+  call psb_info(ictxt,me,np) 
+  if (np == -1) then
+    info=psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  n=1
+  swap_mpi  = iand(flag,psb_swap_mpi_) /= 0
+  swap_sync = iand(flag,psb_swap_sync_) /= 0
+  swap_send = iand(flag,psb_swap_send_) /= 0
+  swap_recv = iand(flag,psb_swap_recv_) /= 0
+  do_send = swap_mpi .or. swap_sync .or. swap_send
+  do_recv = swap_mpi .or. swap_sync .or. swap_recv
+
+  totrcv_ = totrcv * n
+  totsnd_ = totsnd * n
+
+  call idx%sync()
+
+  if (debug) write(*,*) me,'Internal buffer'
+  if (do_send) then 
+    if (allocated(y%comid)) then 
+      ! 
+      ! Unfinished communication? Something is wrong....
+      !
+      info=psb_err_mpi_error_
+      ierr(1) = -2
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,'do_send start'
+    call y%new_buffer(size(idx%v),info)
+    call y%new_comid(totxch,info)
+    call psb_realloc(totxch,prcid,info)
+    ! First I post all the non blocking receives
+    pnti   = 1
+    p2ptag = psb_dcomplex_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+      call psb_get_rank(prcid(i),ictxt,proc_to_comm)      
+      if ((nesd>0).and.(proc_to_comm /= me)) then 
+        if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
+        call mpi_irecv(y%combuf(snd_pt),nesd,&
+             & psb_mpi_c_dpk_,prcid(i),&
+             & p2ptag, icomm,y%comid(i,2),iret)
+      end if
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    if (debug) write(*,*) me,' Gather '
+    !
+    ! Then gather for sending.
+    !    
+    pnti   = 1
+    snd_pt = 1
+    do i=1, totxch
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      idx_pt = rcv_pt
+      call y%gth(idx_pt,nerv,idx)
+
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    !
+    ! Then wait 
+    !
+    call y%device_wait()
+
+    if (debug) write(*,*) me,' isend'
+
+    !
+    ! Then send
+    !
+
+    pnti   = 1
+    snd_pt = 1
+    rcv_pt = 1
+    p2ptag = psb_dcomplex_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if ((nerv>0).and.(proc_to_comm /= me)) then 
+        call mpi_isend(y%combuf(rcv_pt),nerv,&
+             & psb_mpi_c_dpk_,prcid(i),&
+             & p2ptag,icomm,y%comid(i,1),iret)
+      end if
+
+      if(iret /= mpi_success) then
+        ierr(1) = iret
+        info=psb_err_mpi_error_
+        call psb_errpush(info,name,i_err=ierr)
+        goto 9999
+      end if
+
+      pnti   = pnti + nerv + nesd + 3
+    end do
+  end if
+
+  if (do_recv) then 
+    if (debug) write(*,*) me,' do_Recv'
+    if (.not.allocated(y%comid)) then 
+      ! 
+      ! No matching send? Something is wrong....
+      !
+      info=psb_err_mpi_error_
+      ierr(1) = -2
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+    call psb_realloc(totxch,prcid,info)
+
+    if (debug) write(*,*) me,' wait'
+    pnti   = 1
+    p2ptag = psb_dcomplex_swap_tag
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if (proc_to_comm /= me)then 
+        if (nerv>0) then 
+          call mpi_wait(y%comid(i,1),p2pstat,iret)
+          if(iret /= mpi_success) then
+            ierr(1) = iret
+            info=psb_err_mpi_error_
+            call psb_errpush(info,name,i_err=ierr)
+            goto 9999
+          end if
+        end if
+        if (nesd>0) then 
+          call mpi_wait(y%comid(i,2),p2pstat,iret)
+          if(iret /= mpi_success) then
+            ierr(1) = iret
+            info=psb_err_mpi_error_
+            call psb_errpush(info,name,i_err=ierr)
+            goto 9999
+          end if
+        end if
+      else if (proc_to_comm == me) then 
+        if (nesd /= nerv) then 
+          write(psb_err_unit,*) &
+               & 'Fatal error in swapdata: mismatch on self send',&
+               & nerv,nesd
+        end if
+        y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) 
+      end if
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+    if (debug) write(*,*) me,' scatter'      
+    pnti   = 1
+    snd_pt = 1
+    rcv_pt = 1
+    do i=1, totxch
+      proc_to_comm = idx%v(pnti+psb_proc_id_)
+      nerv = idx%v(pnti+psb_n_elem_recv_)
+      nesd = idx%v(pnti+nerv+psb_n_elem_send_)
+      idx_pt = 1+pnti+psb_n_elem_recv_
+      snd_pt = 1+pnti+nerv+psb_n_elem_send_
+      rcv_pt = 1+pnti+psb_n_elem_recv_
+
+      if (debug) write(0,*)me,' Received from: ',prcid(i),&
+           & y%combuf(snd_pt:snd_pt+nesd-1)        
+      call y%sct(snd_pt,nesd,idx,beta)
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+  
+    !
+    ! Then wait 
+    !
+    if (debug) write(*,*) me,' wait'
+    call y%device_wait()
+    if (debug) write(*,*) me,' free buffer'
+    call y%free_buffer(info)
+    if (info == 0) call y%free_comid(info)
+    if (info /= 0) then 
+      call psb_errpush(psb_err_alloc_dealloc_,name)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,' done'
+  end if
+
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psi_ztran_vidx_multivect
+
+
+
 

base/modules/psb_c_base_vect_mod.f90

@@ -1308,7 +1308,6 @@ contains
 
   end subroutine c_base_sctb_x
 
-
   subroutine c_base_sctb_buf(i,n,idx,beta,y)
     use psi_serial_mod
     integer(psb_ipk_) :: i, n
@@ -1357,6 +1356,8 @@ module psb_c_base_multivect_mod
   type psb_c_base_multivect_type
     !> Values. 
     complex(psb_spk_), allocatable :: v(:,:)
+    complex(psb_spk_), allocatable :: combuf(:) 
+    integer(psb_ipk_), allocatable :: comid(:,:)
   contains
     !
     !  Constructors/allocators
@@ -1438,17 +1439,31 @@ module psb_c_base_multivect_mod
     procedure, pass(x) :: absval1  => c_base_mlv_absval1
     procedure, pass(x) :: absval2  => c_base_mlv_absval2
     generic, public    :: absval   => absval1, absval2
-!!$    !
+
-!!$    ! Gather/scatter. These are needed for MPI interfacing.
+    !
-!!$    ! May have to be reworked. 
+    ! These are for handling gather/scatter in new
-!!$    !
+    ! comm internals implementation.
+    !
+    procedure, nopass  :: use_buffer   => c_base_mlv_use_buffer
+    procedure, pass(x) :: new_buffer   => c_base_mlv_new_buffer
+    procedure, nopass  :: device_wait  => c_base_mlv_device_wait
+    procedure, pass(x) :: free_buffer  => c_base_mlv_free_buffer
+    procedure, pass(x) :: new_comid    => c_base_mlv_new_comid
+    procedure, pass(x) :: free_comid   => c_base_mlv_free_comid
+
+    !
+    ! Gather/scatter. These are needed for MPI interfacing.
+    ! May have to be reworked. 
+    !
     procedure, pass(x) :: gthab    => c_base_mlv_gthab
     procedure, pass(x) :: gthzv    => c_base_mlv_gthzv
     procedure, pass(x) :: gthzv_x  => c_base_mlv_gthzv_x
-    generic, public    :: gth      => gthab, gthzv, gthzv_x
+    procedure, pass(x) :: gthzbuf  => c_base_mlv_gthzbuf
+    generic, public    :: gth      => gthab, gthzv, gthzv_x, gthzbuf
     procedure, pass(y) :: sctb     => c_base_mlv_sctb
     procedure, pass(y) :: sctb_x   => c_base_mlv_sctb_x
-    generic, public    :: sct      => sctb, sctb_x
+    procedure, pass(y) :: sctb_buf => c_base_mlv_sctb_buf
+    generic, public    :: sct      => sctb, sctb_x, sctb_buf
   end type psb_c_base_multivect_type
 
   interface psb_c_base_multivect
@@ -2421,6 +2436,57 @@ contains
 
   end subroutine c_base_mlv_absval2
 
+
+  function c_base_mlv_use_buffer() result(res)
+    logical :: res
+    
+    res = .true.
+  end function c_base_mlv_use_buffer
+
+  subroutine c_base_mlv_new_buffer(n,x,info)
+    use psb_realloc_mod
+    implicit none 
+    class(psb_c_base_multivect_type), intent(inout) :: x
+    integer(psb_ipk_), intent(in)              :: n
+    integer(psb_ipk_), intent(out)             :: info
+
+    integer(psb_ipk_)               :: nc
+    nc = x%get_ncols()
+    call psb_realloc(n*nc,x%combuf,info)
+  end subroutine c_base_mlv_new_buffer
+
+  subroutine c_base_mlv_new_comid(n,x,info)
+    use psb_realloc_mod
+    implicit none 
+    class(psb_c_base_multivect_type), intent(inout) :: x
+    integer(psb_ipk_), intent(in)              :: n
+    integer(psb_ipk_), intent(out)             :: info
+
+    call psb_realloc(n,2,x%comid,info)
+  end subroutine c_base_mlv_new_comid
+
+
+  subroutine c_base_mlv_free_buffer(x,info)
+    use psb_realloc_mod
+    implicit none 
+    class(psb_c_base_multivect_type), intent(inout) :: x
+    integer(psb_ipk_), intent(out)             :: info
+
+    if (allocated(x%combuf)) &
+         &  deallocate(x%combuf,stat=info)
+  end subroutine c_base_mlv_free_buffer
+
+  subroutine c_base_mlv_free_comid(x,info)
+    use psb_realloc_mod
+    implicit none 
+    class(psb_c_base_multivect_type), intent(inout) :: x
+    integer(psb_ipk_), intent(out)             :: info
+
+    if (allocated(x%comid)) &
+         &  deallocate(x%comid,stat=info)
+  end subroutine c_base_mlv_free_comid
+
+
   !
   ! Gather: Y = beta * Y + alpha * X(IDX(:))
   !
@@ -2495,6 +2561,27 @@ contains
 
   end subroutine c_base_mlv_gthzv
 
+  !
+  ! New comm internals impl. 
+  !
+  subroutine c_base_mlv_gthzbuf(i,n,idx,x)
+    use psi_serial_mod
+    integer(psb_ipk_) :: i,n
+    class(psb_i_base_vect_type) :: idx
+    class(psb_c_base_multivect_type) :: x
+    integer(psb_ipk_) :: nc
+    
+    if (.not.allocated(x%combuf)) then 
+      call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf')
+      return
+    end if
+    if (idx%is_dev()) call idx%sync()
+    if (x%is_dev()) call x%sync()
+    nc = x%get_ncols()
+    call x%gth(n,idx%v(i:),x%combuf((i-1)*nc+1:))
+
+  end subroutine c_base_mlv_gthzbuf
+
   !
   ! Scatter: 
   ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:)
@@ -2533,5 +2620,36 @@ contains
 
   end subroutine c_base_mlv_sctb_x
 
+  subroutine c_base_mlv_sctb_buf(i,n,idx,beta,y)
+    use psi_serial_mod
+    integer(psb_ipk_) :: i, n
+    class(psb_i_base_vect_type) :: idx
+    complex(psb_spk_) :: beta
+    class(psb_c_base_multivect_type) :: y
+    integer(psb_ipk_) :: nc
+    
+    if (.not.allocated(y%combuf)) then 
+      call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf')
+      return
+    end if
+    if (y%is_dev()) call y%sync()
+    if (idx%is_dev()) call idx%sync()
+    nc = y%get_ncols()
+    call y%sct(n,idx%v(i:),y%combuf((i-1)*nc+1:),beta)
+    call y%set_host()
+    
+  end subroutine c_base_mlv_sctb_buf
+
+  !
+  !> Function  base_device_wait:
+  !! \memberof  psb_c_base_vect_type
+  !! \brief device_wait: base version is a no-op.
+  !!           
+  !
+  subroutine c_base_mlv_device_wait()
+    implicit none 
+    
+  end subroutine c_base_mlv_device_wait
+
 end module psb_c_base_multivect_mod
 

base/modules/psb_c_comm_mod.f90

@@ -34,6 +34,7 @@ module psb_c_comm_mod
   use psb_mat_mod, only  : psb_cspmat_type
   
   use psb_c_vect_mod, only : psb_c_vect_type, psb_c_base_vect_type
+  use psb_c_multivect_mod, only : psb_c_multivect_type, psb_c_base_multivect_type
 
   interface psb_ovrl
     subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode)
@@ -96,6 +97,16 @@ module psb_c_comm_mod
       integer(psb_ipk_), intent(in), optional           :: mode,data
       character, intent(in), optional         :: tran
     end subroutine psb_chalo_vect
+    subroutine psb_chalo_multivect(x,desc_a,info,work,tran,mode,data)
+      import
+      implicit none
+      type(psb_c_multivect_type), intent(inout)   :: x
+      type(psb_desc_type), intent(in)         :: desc_a
+      integer(psb_ipk_), intent(out)                    :: info
+      complex(psb_spk_), target, optional, intent(inout) :: work(:)
+      integer(psb_ipk_), intent(in), optional           :: mode,data
+      character, intent(in), optional         :: tran
+    end subroutine psb_chalo_multivect
   end interface psb_halo
 
 

base/modules/psb_c_tools_mod.f90

@@ -33,6 +33,7 @@ Module psb_c_tools_mod
   use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_
   use psb_c_vect_mod, only : psb_c_base_vect_type, psb_c_vect_type, psb_i_vect_type
   use psb_c_mat_mod, only : psb_cspmat_type, psb_c_base_sparse_mat
+  use psb_c_multivect_mod, only : psb_c_base_multivect_type, psb_c_multivect_type
 
   interface  psb_geall
     subroutine psb_calloc(x, desc_a, info, n, lb)
@@ -67,6 +68,14 @@ Module psb_c_tools_mod
       integer(psb_ipk_),intent(out)             :: info
       integer(psb_ipk_), optional, intent(in)   :: n, lb
     end subroutine psb_calloc_vect_r2
+    subroutine psb_calloc_multivect(x, desc_a,info,n)
+      import
+      implicit none
+      type(psb_c_multivect_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_calloc_multivect
   end interface
 
 
@@ -103,6 +112,16 @@ Module psb_c_tools_mod
       class(psb_c_base_vect_type), intent(in), optional :: mold
       logical, intent(in), optional        :: scratch
     end subroutine psb_casb_vect_r2
+    subroutine psb_casb_multivect(x, desc_a, info,mold, scratch, n)
+      import
+      implicit none
+      type(psb_desc_type), intent(in)      ::  desc_a
+      type(psb_c_multivect_type), intent(inout) :: x
+      integer(psb_ipk_), intent(out)                 ::  info
+      class(psb_c_base_multivect_type), intent(in), optional :: mold
+      logical, intent(in), optional        :: scratch
+      integer(psb_ipk_), optional, intent(in)   :: n
+    end subroutine psb_casb_multivect
   end interface
 
   interface psb_gefree
@@ -134,6 +153,13 @@ Module psb_c_tools_mod
       type(psb_c_vect_type), allocatable, intent(inout) :: x(:)
       integer(psb_ipk_), intent(out)             ::  info
     end subroutine psb_cfree_vect_r2
+    subroutine psb_cfree_multivect(x, desc_a, info)
+      import
+      implicit none
+      type(psb_desc_type), intent(in)  ::  desc_a
+      type(psb_c_multivect_type), intent(inout) :: x
+      integer(psb_ipk_), intent(out)             ::  info
+    end subroutine psb_cfree_multivect
   end interface
 
 
@@ -198,6 +224,18 @@ Module psb_c_tools_mod
       integer(psb_ipk_), optional, intent(in)    :: dupl
       logical, intent(in), optional        :: local
     end subroutine psb_cins_vect_r2
+    subroutine psb_cins_multivect(m,irw,val,x,desc_a,info,dupl,local)
+      import
+      implicit none
+      integer(psb_ipk_), intent(in)              :: m
+      type(psb_desc_type), intent(in)  :: desc_a
+      type(psb_c_multivect_type), intent(inout) :: x
+      integer(psb_ipk_), intent(in)              :: irw(:)
+      complex(psb_spk_), intent(in)    :: val(:,:)
+      integer(psb_ipk_), intent(out)             :: info
+      integer(psb_ipk_), optional, intent(in)    :: dupl
+      logical, intent(in), optional        :: local
+    end subroutine psb_cins_multivect
   end interface
 
   interface psb_cdbldext

base/modules/psb_c_vect_mod.F90

@@ -129,11 +129,11 @@ module psb_c_vect_mod
 
   interface psb_set_vect_default
     module procedure psb_c_set_vect_default
-  end interface
+  end interface psb_set_vect_default
 
   interface psb_get_vect_default
     module procedure psb_c_get_vect_default
-  end interface
+  end interface psb_get_vect_default
 
 
 contains
@@ -859,23 +859,24 @@ module psb_c_multivect_mod
   end type psb_c_multivect_type
 
   public  :: psb_c_multivect, psb_c_multivect_type,&
-       & psb_set_multivect_default, psb_get_multivect_default
+       & psb_set_multivect_default, psb_get_multivect_default, &
+       & psb_c_base_multivect_type
 
   private
   interface psb_c_multivect
     module procedure constructor, size_const
-  end interface
+  end interface psb_c_multivect
 
   class(psb_c_base_multivect_type), allocatable, target,&
        & save, private :: psb_c_base_multivect_default
 
   interface psb_set_multivect_default
     module procedure psb_c_set_multivect_default
-  end interface
+  end interface psb_set_multivect_default
 
   interface psb_get_vect_default
     module procedure psb_c_get_multivect_default
-  end interface
+  end interface psb_get_vect_default
 
 
 contains

base/modules/psb_d_base_vect_mod.f90

@@ -1308,7 +1308,6 @@ contains
 
   end subroutine d_base_sctb_x
 
-
   subroutine d_base_sctb_buf(i,n,idx,beta,y)
     use psi_serial_mod
     integer(psb_ipk_) :: i, n
@@ -1357,6 +1356,8 @@ module psb_d_base_multivect_mod
   type psb_d_base_multivect_type
     !> Values. 
     real(psb_dpk_), allocatable :: v(:,:)
+    real(psb_dpk_), allocatable :: combuf(:) 
+    integer(psb_ipk_), allocatable :: comid(:,:)
   contains
     !
     !  Constructors/allocators
@@ -1438,17 +1439,31 @@ module psb_d_base_multivect_mod
     procedure, pass(x) :: absval1  => d_base_mlv_absval1
     procedure, pass(x) :: absval2  => d_base_mlv_absval2
     generic, public    :: absval   => absval1, absval2
-!!$    !
+
-!!$    ! Gather/scatter. These are needed for MPI interfacing.
+    !
-!!$    ! May have to be reworked. 
+    ! These are for handling gather/scatter in new
-!!$    !
+    ! comm internals implementation.
+    !
+    procedure, nopass  :: use_buffer   => d_base_mlv_use_buffer
+    procedure, pass(x) :: new_buffer   => d_base_mlv_new_buffer
+    procedure, nopass  :: device_wait  => d_base_mlv_device_wait
+    procedure, pass(x) :: free_buffer  => d_base_mlv_free_buffer
+    procedure, pass(x) :: new_comid    => d_base_mlv_new_comid
+    procedure, pass(x) :: free_comid   => d_base_mlv_free_comid
+
+    !
+    ! Gather/scatter. These are needed for MPI interfacing.
+    ! May have to be reworked. 
+    !
     procedure, pass(x) :: gthab    => d_base_mlv_gthab
     procedure, pass(x) :: gthzv    => d_base_mlv_gthzv
     procedure, pass(x) :: gthzv_x  => d_base_mlv_gthzv_x
-    generic, public    :: gth      => gthab, gthzv, gthzv_x
+    procedure, pass(x) :: gthzbuf  => d_base_mlv_gthzbuf
+    generic, public    :: gth      => gthab, gthzv, gthzv_x, gthzbuf
     procedure, pass(y) :: sctb     => d_base_mlv_sctb
     procedure, pass(y) :: sctb_x   => d_base_mlv_sctb_x
-    generic, public    :: sct      => sctb, sctb_x
+    procedure, pass(y) :: sctb_buf => d_base_mlv_sctb_buf
+    generic, public    :: sct      => sctb, sctb_x, sctb_buf
   end type psb_d_base_multivect_type
 
   interface psb_d_base_multivect
@@ -2421,6 +2436,57 @@ contains
 
   end subroutine d_base_mlv_absval2
 
+
+  function d_base_mlv_use_buffer() result(res)
+    logical :: res
+    
+    res = .true.
+  end function d_base_mlv_use_buffer
+
+  subroutine d_base_mlv_new_buffer(n,x,info)
+    use psb_realloc_mod
+    implicit none 
+    class(psb_d_base_multivect_type), intent(inout) :: x
+    integer(psb_ipk_), intent(in)              :: n
+    integer(psb_ipk_), intent(out)             :: info
+
+    integer(psb_ipk_)               :: nc
+    nc = x%get_ncols()
+    call psb_realloc(n*nc,x%combuf,info)
+  end subroutine d_base_mlv_new_buffer
+
+  subroutine d_base_mlv_new_comid(n,x,info)
+    use psb_realloc_mod
+    implicit none 
+    class(psb_d_base_multivect_type), intent(inout) :: x
+    integer(psb_ipk_), intent(in)              :: n
+    integer(psb_ipk_), intent(out)             :: info
+
+    call psb_realloc(n,2,x%comid,info)
+  end subroutine d_base_mlv_new_comid
+
+
+  subroutine d_base_mlv_free_buffer(x,info)
+    use psb_realloc_mod
+    implicit none 
+    class(psb_d_base_multivect_type), intent(inout) :: x
+    integer(psb_ipk_), intent(out)             :: info
+
+    if (allocated(x%combuf)) &
+         &  deallocate(x%combuf,stat=info)
+  end subroutine d_base_mlv_free_buffer
+
+  subroutine d_base_mlv_free_comid(x,info)
+    use psb_realloc_mod
+    implicit none 
+    class(psb_d_base_multivect_type), intent(inout) :: x
+    integer(psb_ipk_), intent(out)             :: info
+
+    if (allocated(x%comid)) &
+         &  deallocate(x%comid,stat=info)
+  end subroutine d_base_mlv_free_comid
+
+
   !
   ! Gather: Y = beta * Y + alpha * X(IDX(:))
   !
@@ -2495,6 +2561,27 @@ contains
 
   end subroutine d_base_mlv_gthzv
 
+  !
+  ! New comm internals impl. 
+  !
+  subroutine d_base_mlv_gthzbuf(i,n,idx,x)
+    use psi_serial_mod
+    integer(psb_ipk_) :: i,n
+    class(psb_i_base_vect_type) :: idx
+    class(psb_d_base_multivect_type) :: x
+    integer(psb_ipk_) :: nc
+    
+    if (.not.allocated(x%combuf)) then 
+      call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf')
+      return
+    end if
+    if (idx%is_dev()) call idx%sync()
+    if (x%is_dev()) call x%sync()
+    nc = x%get_ncols()
+    call x%gth(n,idx%v(i:),x%combuf((i-1)*nc+1:))
+
+  end subroutine d_base_mlv_gthzbuf
+
   !
   ! Scatter: 
   ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:)
@@ -2533,5 +2620,36 @@ contains
 
   end subroutine d_base_mlv_sctb_x
 
+  subroutine d_base_mlv_sctb_buf(i,n,idx,beta,y)
+    use psi_serial_mod
+    integer(psb_ipk_) :: i, n
+    class(psb_i_base_vect_type) :: idx
+    real(psb_dpk_) :: beta
+    class(psb_d_base_multivect_type) :: y
+    integer(psb_ipk_) :: nc
+    
+    if (.not.allocated(y%combuf)) then 
+      call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf')
+      return
+    end if
+    if (y%is_dev()) call y%sync()
+    if (idx%is_dev()) call idx%sync()
+    nc = y%get_ncols()
+    call y%sct(n,idx%v(i:),y%combuf((i-1)*nc+1:),beta)
+    call y%set_host()
+    
+  end subroutine d_base_mlv_sctb_buf
+
+  !
+  !> Function  base_device_wait:
+  !! \memberof  psb_d_base_vect_type
+  !! \brief device_wait: base version is a no-op.
+  !!           
+  !
+  subroutine d_base_mlv_device_wait()
+    implicit none 
+    
+  end subroutine d_base_mlv_device_wait
+
 end module psb_d_base_multivect_mod
 

base/modules/psb_d_comm_mod.f90

@@ -34,6 +34,7 @@ module psb_d_comm_mod
   use psb_mat_mod, only  : psb_dspmat_type
   
   use psb_d_vect_mod, only : psb_d_vect_type, psb_d_base_vect_type
+  use psb_d_multivect_mod, only : psb_d_multivect_type, psb_d_base_multivect_type
 
   interface psb_ovrl
     subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode)
@@ -96,6 +97,16 @@ module psb_d_comm_mod
       integer(psb_ipk_), intent(in), optional           :: mode,data
       character, intent(in), optional         :: tran
     end subroutine psb_dhalo_vect
+    subroutine psb_dhalo_multivect(x,desc_a,info,work,tran,mode,data)
+      import
+      implicit none
+      type(psb_d_multivect_type), intent(inout)   :: x
+      type(psb_desc_type), intent(in)         :: desc_a
+      integer(psb_ipk_), intent(out)                    :: info
+      real(psb_dpk_), target, optional, intent(inout) :: work(:)
+      integer(psb_ipk_), intent(in), optional           :: mode,data
+      character, intent(in), optional         :: tran
+    end subroutine psb_dhalo_multivect
   end interface psb_halo
 
 

base/modules/psb_d_tools_mod.f90

@@ -33,6 +33,7 @@ Module psb_d_tools_mod
   use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_
   use psb_d_vect_mod, only : psb_d_base_vect_type, psb_d_vect_type, psb_i_vect_type
   use psb_d_mat_mod, only : psb_dspmat_type, psb_d_base_sparse_mat
+  use psb_d_multivect_mod, only : psb_d_base_multivect_type, psb_d_multivect_type
 
   interface  psb_geall
     subroutine psb_dalloc(x, desc_a, info, n, lb)
@@ -67,6 +68,14 @@ Module psb_d_tools_mod
       integer(psb_ipk_),intent(out)             :: info
       integer(psb_ipk_), optional, intent(in)   :: n, lb
     end subroutine psb_dalloc_vect_r2
+    subroutine psb_dalloc_multivect(x, desc_a,info,n)
+      import
+      implicit none
+      type(psb_d_multivect_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_dalloc_multivect
   end interface
 
 
@@ -103,6 +112,16 @@ Module psb_d_tools_mod
       class(psb_d_base_vect_type), intent(in), optional :: mold
       logical, intent(in), optional        :: scratch
     end subroutine psb_dasb_vect_r2
+    subroutine psb_dasb_multivect(x, desc_a, info,mold, scratch, n)
+      import
+      implicit none
+      type(psb_desc_type), intent(in)      ::  desc_a
+      type(psb_d_multivect_type), intent(inout) :: x
+      integer(psb_ipk_), intent(out)                 ::  info
+      class(psb_d_base_multivect_type), intent(in), optional :: mold
+      logical, intent(in), optional        :: scratch
+      integer(psb_ipk_), optional, intent(in)   :: n
+    end subroutine psb_dasb_multivect
   end interface
 
   interface psb_gefree
@@ -134,6 +153,13 @@ Module psb_d_tools_mod
       type(psb_d_vect_type), allocatable, intent(inout) :: x(:)
       integer(psb_ipk_), intent(out)             ::  info
     end subroutine psb_dfree_vect_r2
+    subroutine psb_dfree_multivect(x, desc_a, info)
+      import
+      implicit none
+      type(psb_desc_type), intent(in)  ::  desc_a
+      type(psb_d_multivect_type), intent(inout) :: x
+      integer(psb_ipk_), intent(out)             ::  info
+    end subroutine psb_dfree_multivect
   end interface
 
 
@@ -198,6 +224,18 @@ Module psb_d_tools_mod
       integer(psb_ipk_), optional, intent(in)    :: dupl
       logical, intent(in), optional        :: local
     end subroutine psb_dins_vect_r2
+    subroutine psb_dins_multivect(m,irw,val,x,desc_a,info,dupl,local)
+      import
+      implicit none
+      integer(psb_ipk_), intent(in)              :: m
+      type(psb_desc_type), intent(in)  :: desc_a
+      type(psb_d_multivect_type), intent(inout) :: x
+      integer(psb_ipk_), intent(in)              :: irw(:)
+      real(psb_dpk_), intent(in)    :: val(:,:)
+      integer(psb_ipk_), intent(out)             :: info
+      integer(psb_ipk_), optional, intent(in)    :: dupl
+      logical, intent(in), optional        :: local
+    end subroutine psb_dins_multivect
   end interface
 
   interface psb_cdbldext

base/modules/psb_d_vect_mod.F90

@@ -129,11 +129,11 @@ module psb_d_vect_mod
 
   interface psb_set_vect_default
     module procedure psb_d_set_vect_default
-  end interface
+  end interface psb_set_vect_default
 
   interface psb_get_vect_default
     module procedure psb_d_get_vect_default
-  end interface
+  end interface psb_get_vect_default
 
 
 contains
@@ -859,23 +859,24 @@ module psb_d_multivect_mod
   end type psb_d_multivect_type
 
   public  :: psb_d_multivect, psb_d_multivect_type,&
-       & psb_set_multivect_default, psb_get_multivect_default
+       & psb_set_multivect_default, psb_get_multivect_default, &
+       & psb_d_base_multivect_type
 
   private
   interface psb_d_multivect
     module procedure constructor, size_const
-  end interface
+  end interface psb_d_multivect
 
   class(psb_d_base_multivect_type), allocatable, target,&
        & save, private :: psb_d_base_multivect_default
 
   interface psb_set_multivect_default
     module procedure psb_d_set_multivect_default
-  end interface
+  end interface psb_set_multivect_default
 
   interface psb_get_vect_default
     module procedure psb_d_get_multivect_default
-  end interface
+  end interface psb_get_vect_default
 
 
 contains

base/modules/psb_i_base_vect_mod.f90

@@ -849,7 +849,6 @@ contains
 
   end subroutine i_base_sctb_x
 
-
   subroutine i_base_sctb_buf(i,n,idx,beta,y)
     use psi_serial_mod
     integer(psb_ipk_) :: i, n
@@ -898,6 +897,8 @@ module psb_i_base_multivect_mod
   type psb_i_base_multivect_type
     !> Values. 
     integer(psb_ipk_), allocatable :: v(:,:)
+    integer(psb_ipk_), allocatable :: combuf(:) 
+    integer(psb_ipk_), allocatable :: comid(:,:)
   contains
     !
     !  Constructors/allocators
@@ -946,17 +947,31 @@ module psb_i_base_multivect_mod
     procedure, pass(x) :: set_vect => i_base_mlv_set_vect
     generic, public    :: set      => set_vect, set_scal
 
-!!$    !
+
-!!$    ! Gather/scatter. These are needed for MPI interfacing.
+    !
-!!$    ! May have to be reworked. 
+    ! These are for handling gather/scatter in new
-!!$    !
+    ! comm internals implementation.
+    !
+    procedure, nopass  :: use_buffer   => i_base_mlv_use_buffer
+    procedure, pass(x) :: new_buffer   => i_base_mlv_new_buffer
+    procedure, nopass  :: device_wait  => i_base_mlv_device_wait
+    procedure, pass(x) :: free_buffer  => i_base_mlv_free_buffer
+    procedure, pass(x) :: new_comid    => i_base_mlv_new_comid
+    procedure, pass(x) :: free_comid   => i_base_mlv_free_comid
+
+    !
+    ! Gather/scatter. These are needed for MPI interfacing.
+    ! May have to be reworked. 
+    !
     procedure, pass(x) :: gthab    => i_base_mlv_gthab
     procedure, pass(x) :: gthzv    => i_base_mlv_gthzv
     procedure, pass(x) :: gthzv_x  => i_base_mlv_gthzv_x
-    generic, public    :: gth      => gthab, gthzv, gthzv_x
+    procedure, pass(x) :: gthzbuf  => i_base_mlv_gthzbuf
+    generic, public    :: gth      => gthab, gthzv, gthzv_x, gthzbuf
     procedure, pass(y) :: sctb     => i_base_mlv_sctb
     procedure, pass(y) :: sctb_x   => i_base_mlv_sctb_x
-    generic, public    :: sct      => sctb, sctb_x
+    procedure, pass(y) :: sctb_buf => i_base_mlv_sctb_buf
+    generic, public    :: sct      => sctb, sctb_x, sctb_buf
   end type psb_i_base_multivect_type
 
   interface psb_i_base_multivect
@@ -1450,6 +1465,57 @@ contains
 
   end subroutine i_base_mlv_set_vect
 
+
+  function i_base_mlv_use_buffer() result(res)
+    logical :: res
+    
+    res = .true.
+  end function i_base_mlv_use_buffer
+
+  subroutine i_base_mlv_new_buffer(n,x,info)
+    use psb_realloc_mod
+    implicit none 
+    class(psb_i_base_multivect_type), intent(inout) :: x
+    integer(psb_ipk_), intent(in)              :: n
+    integer(psb_ipk_), intent(out)             :: info
+
+    integer(psb_ipk_)               :: nc
+    nc = x%get_ncols()
+    call psb_realloc(n*nc,x%combuf,info)
+  end subroutine i_base_mlv_new_buffer
+
+  subroutine i_base_mlv_new_comid(n,x,info)
+    use psb_realloc_mod
+    implicit none 
+    class(psb_i_base_multivect_type), intent(inout) :: x
+    integer(psb_ipk_), intent(in)              :: n
+    integer(psb_ipk_), intent(out)             :: info
+
+    call psb_realloc(n,2,x%comid,info)
+  end subroutine i_base_mlv_new_comid
+
+
+  subroutine i_base_mlv_free_buffer(x,info)
+    use psb_realloc_mod
+    implicit none 
+    class(psb_i_base_multivect_type), intent(inout) :: x
+    integer(psb_ipk_), intent(out)             :: info
+
+    if (allocated(x%combuf)) &
+         &  deallocate(x%combuf,stat=info)
+  end subroutine i_base_mlv_free_buffer
+
+  subroutine i_base_mlv_free_comid(x,info)
+    use psb_realloc_mod
+    implicit none 
+    class(psb_i_base_multivect_type), intent(inout) :: x
+    integer(psb_ipk_), intent(out)             :: info
+
+    if (allocated(x%comid)) &
+         &  deallocate(x%comid,stat=info)
+  end subroutine i_base_mlv_free_comid
+
+
   !
   ! Gather: Y = beta * Y + alpha * X(IDX(:))
   !
@@ -1524,6 +1590,27 @@ contains
 
   end subroutine i_base_mlv_gthzv
 
+  !
+  ! New comm internals impl. 
+  !
+  subroutine i_base_mlv_gthzbuf(i,n,idx,x)
+    use psi_serial_mod
+    integer(psb_ipk_) :: i,n
+    class(psb_i_base_vect_type) :: idx
+    class(psb_i_base_multivect_type) :: x
+    integer(psb_ipk_) :: nc
+    
+    if (.not.allocated(x%combuf)) then 
+      call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf')
+      return
+    end if
+    if (idx%is_dev()) call idx%sync()
+    if (x%is_dev()) call x%sync()
+    nc = x%get_ncols()
+    call x%gth(n,idx%v(i:),x%combuf((i-1)*nc+1:))
+
+  end subroutine i_base_mlv_gthzbuf
+
   !
   ! Scatter: 
   ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:)
@@ -1562,5 +1649,36 @@ contains
 
   end subroutine i_base_mlv_sctb_x
 
+  subroutine i_base_mlv_sctb_buf(i,n,idx,beta,y)
+    use psi_serial_mod
+    integer(psb_ipk_) :: i, n
+    class(psb_i_base_vect_type) :: idx
+    integer(psb_ipk_) :: beta
+    class(psb_i_base_multivect_type) :: y
+    integer(psb_ipk_) :: nc
+    
+    if (.not.allocated(y%combuf)) then 
+      call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf')
+      return
+    end if
+    if (y%is_dev()) call y%sync()
+    if (idx%is_dev()) call idx%sync()
+    nc = y%get_ncols()
+    call y%sct(n,idx%v(i:),y%combuf((i-1)*nc+1:),beta)
+    call y%set_host()
+    
+  end subroutine i_base_mlv_sctb_buf
+
+  !
+  !> Function  base_device_wait:
+  !! \memberof  psb_i_base_vect_type
+  !! \brief device_wait: base version is a no-op.
+  !!           
+  !
+  subroutine i_base_mlv_device_wait()
+    implicit none 
+    
+  end subroutine i_base_mlv_device_wait
+
 end module psb_i_base_multivect_mod
 

base/modules/psb_i_comm_mod.f90

@@ -33,6 +33,7 @@ module psb_i_comm_mod
   use psb_desc_mod, only : psb_desc_type, psb_ipk_
   
   use psb_i_vect_mod, only : psb_i_vect_type, psb_i_base_vect_type
+  use psb_i_multivect_mod, only : psb_i_multivect_type, psb_i_base_multivect_type
 
   interface psb_ovrl
     subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode)
@@ -95,6 +96,16 @@ module psb_i_comm_mod
       integer(psb_ipk_), intent(in), optional           :: mode,data
       character, intent(in), optional         :: tran
     end subroutine psb_ihalo_vect
+    subroutine psb_ihalo_multivect(x,desc_a,info,work,tran,mode,data)
+      import
+      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
+    end subroutine psb_ihalo_multivect
   end interface psb_halo
 
 

base/modules/psb_i_tools_mod.f90

@@ -32,6 +32,7 @@
 Module psb_i_tools_mod
   use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_success_
   use psb_i_vect_mod, only : psb_i_base_vect_type, psb_i_vect_type
+  use psb_i_multivect_mod, only : psb_i_base_multivect_type, psb_i_multivect_type
 
   interface  psb_geall
     subroutine psb_ialloc(x, desc_a, info, n, lb)
@@ -66,6 +67,14 @@ Module psb_i_tools_mod
       integer(psb_ipk_),intent(out)             :: info
       integer(psb_ipk_), optional, intent(in)   :: n, lb
     end subroutine psb_ialloc_vect_r2
+    subroutine psb_ialloc_multivect(x, desc_a,info,n)
+      import
+      implicit none
+      type(psb_i_multivect_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_multivect
   end interface
 
 
@@ -102,6 +111,16 @@ Module psb_i_tools_mod
       class(psb_i_base_vect_type), intent(in), optional :: mold
       logical, intent(in), optional        :: scratch
     end subroutine psb_iasb_vect_r2
+    subroutine psb_iasb_multivect(x, desc_a, info,mold, scratch, n)
+      import
+      implicit none
+      type(psb_desc_type), intent(in)      ::  desc_a
+      type(psb_i_multivect_type), intent(inout) :: x
+      integer(psb_ipk_), intent(out)                 ::  info
+      class(psb_i_base_multivect_type), intent(in), optional :: mold
+      logical, intent(in), optional        :: scratch
+      integer(psb_ipk_), optional, intent(in)   :: n
+    end subroutine psb_iasb_multivect
   end interface
 
   interface psb_gefree
@@ -133,6 +152,13 @@ Module psb_i_tools_mod
       type(psb_i_vect_type), allocatable, intent(inout) :: x(:)
       integer(psb_ipk_), intent(out)             ::  info
     end subroutine psb_ifree_vect_r2
+    subroutine psb_ifree_multivect(x, desc_a, info)
+      import
+      implicit none
+      type(psb_desc_type), intent(in)  ::  desc_a
+      type(psb_i_multivect_type), intent(inout) :: x
+      integer(psb_ipk_), intent(out)             ::  info
+    end subroutine psb_ifree_multivect
   end interface
 
 
@@ -197,6 +223,18 @@ Module psb_i_tools_mod
       integer(psb_ipk_), optional, intent(in)    :: dupl
       logical, intent(in), optional        :: local
     end subroutine psb_iins_vect_r2
+    subroutine psb_iins_multivect(m,irw,val,x,desc_a,info,dupl,local)
+      import
+      implicit none
+      integer(psb_ipk_), intent(in)              :: m
+      type(psb_desc_type), intent(in)  :: desc_a
+      type(psb_i_multivect_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_multivect
   end interface
 
 

base/modules/psb_i_vect_mod.F90

@@ -102,11 +102,11 @@ module psb_i_vect_mod
 
   interface psb_set_vect_default
     module procedure psb_i_set_vect_default
-  end interface
+  end interface psb_set_vect_default
 
   interface psb_get_vect_default
     module procedure psb_i_get_vect_default
-  end interface
+  end interface psb_get_vect_default
 
 
 contains
@@ -588,23 +588,24 @@ module psb_i_multivect_mod
   end type psb_i_multivect_type
 
   public  :: psb_i_multivect, psb_i_multivect_type,&
-       & psb_set_multivect_default, psb_get_multivect_default
+       & psb_set_multivect_default, psb_get_multivect_default, &
+       & psb_i_base_multivect_type
 
   private
   interface psb_i_multivect
     module procedure constructor, size_const
-  end interface
+  end interface psb_i_multivect
 
   class(psb_i_base_multivect_type), allocatable, target,&
        & save, private :: psb_i_base_multivect_default
 
   interface psb_set_multivect_default
     module procedure psb_i_set_multivect_default
-  end interface
+  end interface psb_set_multivect_default
 
   interface psb_get_vect_default
     module procedure psb_i_get_multivect_default
-  end interface
+  end interface psb_get_vect_default
 
 
 contains

base/modules/psb_s_base_vect_mod.f90

@@ -1308,7 +1308,6 @@ contains
 
   end subroutine s_base_sctb_x
 
-
   subroutine s_base_sctb_buf(i,n,idx,beta,y)
     use psi_serial_mod
     integer(psb_ipk_) :: i, n
@@ -1357,6 +1356,8 @@ module psb_s_base_multivect_mod
   type psb_s_base_multivect_type
     !> Values. 
     real(psb_spk_), allocatable :: v(:,:)
+    real(psb_spk_), allocatable :: combuf(:) 
+    integer(psb_ipk_), allocatable :: comid(:,:)
   contains
     !
     !  Constructors/allocators
@@ -1438,17 +1439,31 @@ module psb_s_base_multivect_mod
     procedure, pass(x) :: absval1  => s_base_mlv_absval1
     procedure, pass(x) :: absval2  => s_base_mlv_absval2
     generic, public    :: absval   => absval1, absval2
-!!$    !
+
-!!$    ! Gather/scatter. These are needed for MPI interfacing.
+    !
-!!$    ! May have to be reworked. 
+    ! These are for handling gather/scatter in new
-!!$    !
+    ! comm internals implementation.
+    !
+    procedure, nopass  :: use_buffer   => s_base_mlv_use_buffer
+    procedure, pass(x) :: new_buffer   => s_base_mlv_new_buffer
+    procedure, nopass  :: device_wait  => s_base_mlv_device_wait
+    procedure, pass(x) :: free_buffer  => s_base_mlv_free_buffer
+    procedure, pass(x) :: new_comid    => s_base_mlv_new_comid
+    procedure, pass(x) :: free_comid   => s_base_mlv_free_comid
+
+    !
+    ! Gather/scatter. These are needed for MPI interfacing.
+    ! May have to be reworked. 
+    !
     procedure, pass(x) :: gthab    => s_base_mlv_gthab
     procedure, pass(x) :: gthzv    => s_base_mlv_gthzv
     procedure, pass(x) :: gthzv_x  => s_base_mlv_gthzv_x
-    generic, public    :: gth      => gthab, gthzv, gthzv_x
+    procedure, pass(x) :: gthzbuf  => s_base_mlv_gthzbuf
+    generic, public    :: gth      => gthab, gthzv, gthzv_x, gthzbuf
     procedure, pass(y) :: sctb     => s_base_mlv_sctb
     procedure, pass(y) :: sctb_x   => s_base_mlv_sctb_x
-    generic, public    :: sct      => sctb, sctb_x
+    procedure, pass(y) :: sctb_buf => s_base_mlv_sctb_buf
+    generic, public    :: sct      => sctb, sctb_x, sctb_buf
   end type psb_s_base_multivect_type
 
   interface psb_s_base_multivect
@@ -2421,6 +2436,57 @@ contains
 
   end subroutine s_base_mlv_absval2
 
+
+  function s_base_mlv_use_buffer() result(res)
+    logical :: res
+    
+    res = .true.
+  end function s_base_mlv_use_buffer
+
+  subroutine s_base_mlv_new_buffer(n,x,info)
+    use psb_realloc_mod
+    implicit none 
+    class(psb_s_base_multivect_type), intent(inout) :: x
+    integer(psb_ipk_), intent(in)              :: n
+    integer(psb_ipk_), intent(out)             :: info
+
+    integer(psb_ipk_)               :: nc
+    nc = x%get_ncols()
+    call psb_realloc(n*nc,x%combuf,info)
+  end subroutine s_base_mlv_new_buffer
+
+  subroutine s_base_mlv_new_comid(n,x,info)
+    use psb_realloc_mod
+    implicit none 
+    class(psb_s_base_multivect_type), intent(inout) :: x
+    integer(psb_ipk_), intent(in)              :: n
+    integer(psb_ipk_), intent(out)             :: info
+
+    call psb_realloc(n,2,x%comid,info)
+  end subroutine s_base_mlv_new_comid
+
+
+  subroutine s_base_mlv_free_buffer(x,info)
+    use psb_realloc_mod
+    implicit none 
+    class(psb_s_base_multivect_type), intent(inout) :: x
+    integer(psb_ipk_), intent(out)             :: info
+
+    if (allocated(x%combuf)) &
+         &  deallocate(x%combuf,stat=info)
+  end subroutine s_base_mlv_free_buffer
+
+  subroutine s_base_mlv_free_comid(x,info)
+    use psb_realloc_mod
+    implicit none 
+    class(psb_s_base_multivect_type), intent(inout) :: x
+    integer(psb_ipk_), intent(out)             :: info
+
+    if (allocated(x%comid)) &
+         &  deallocate(x%comid,stat=info)
+  end subroutine s_base_mlv_free_comid
+
+
   !
   ! Gather: Y = beta * Y + alpha * X(IDX(:))
   !
@@ -2495,6 +2561,27 @@ contains
 
   end subroutine s_base_mlv_gthzv
 
+  !
+  ! New comm internals impl. 
+  !
+  subroutine s_base_mlv_gthzbuf(i,n,idx,x)
+    use psi_serial_mod
+    integer(psb_ipk_) :: i,n
+    class(psb_i_base_vect_type) :: idx
+    class(psb_s_base_multivect_type) :: x
+    integer(psb_ipk_) :: nc
+    
+    if (.not.allocated(x%combuf)) then 
+      call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf')
+      return
+    end if
+    if (idx%is_dev()) call idx%sync()
+    if (x%is_dev()) call x%sync()
+    nc = x%get_ncols()
+    call x%gth(n,idx%v(i:),x%combuf((i-1)*nc+1:))
+
+  end subroutine s_base_mlv_gthzbuf
+
   !
   ! Scatter: 
   ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:)
@@ -2533,5 +2620,36 @@ contains
 
   end subroutine s_base_mlv_sctb_x
 
+  subroutine s_base_mlv_sctb_buf(i,n,idx,beta,y)
+    use psi_serial_mod
+    integer(psb_ipk_) :: i, n
+    class(psb_i_base_vect_type) :: idx
+    real(psb_spk_) :: beta
+    class(psb_s_base_multivect_type) :: y
+    integer(psb_ipk_) :: nc
+    
+    if (.not.allocated(y%combuf)) then 
+      call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf')
+      return
+    end if
+    if (y%is_dev()) call y%sync()
+    if (idx%is_dev()) call idx%sync()
+    nc = y%get_ncols()
+    call y%sct(n,idx%v(i:),y%combuf((i-1)*nc+1:),beta)
+    call y%set_host()
+    
+  end subroutine s_base_mlv_sctb_buf
+
+  !
+  !> Function  base_device_wait:
+  !! \memberof  psb_s_base_vect_type
+  !! \brief device_wait: base version is a no-op.
+  !!           
+  !
+  subroutine s_base_mlv_device_wait()
+    implicit none 
+    
+  end subroutine s_base_mlv_device_wait
+
 end module psb_s_base_multivect_mod
 

base/modules/psb_s_comm_mod.f90

@@ -34,6 +34,7 @@ module psb_s_comm_mod
   use psb_mat_mod, only  : psb_sspmat_type
   
   use psb_s_vect_mod, only : psb_s_vect_type, psb_s_base_vect_type
+  use psb_s_multivect_mod, only : psb_s_multivect_type, psb_s_base_multivect_type
 
   interface psb_ovrl
     subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode)
@@ -96,6 +97,16 @@ module psb_s_comm_mod
       integer(psb_ipk_), intent(in), optional           :: mode,data
       character, intent(in), optional         :: tran
     end subroutine psb_shalo_vect
+    subroutine psb_shalo_multivect(x,desc_a,info,work,tran,mode,data)
+      import
+      implicit none
+      type(psb_s_multivect_type), intent(inout)   :: x
+      type(psb_desc_type), intent(in)         :: desc_a
+      integer(psb_ipk_), intent(out)                    :: info
+      real(psb_spk_), target, optional, intent(inout) :: work(:)
+      integer(psb_ipk_), intent(in), optional           :: mode,data
+      character, intent(in), optional         :: tran
+    end subroutine psb_shalo_multivect
   end interface psb_halo
 
 

base/modules/psb_s_tools_mod.f90

@@ -33,6 +33,7 @@ Module psb_s_tools_mod
   use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_
   use psb_s_vect_mod, only : psb_s_base_vect_type, psb_s_vect_type, psb_i_vect_type
   use psb_s_mat_mod, only : psb_sspmat_type, psb_s_base_sparse_mat
+  use psb_s_multivect_mod, only : psb_s_base_multivect_type, psb_s_multivect_type
 
   interface  psb_geall
     subroutine psb_salloc(x, desc_a, info, n, lb)
@@ -67,6 +68,14 @@ Module psb_s_tools_mod
       integer(psb_ipk_),intent(out)             :: info
       integer(psb_ipk_), optional, intent(in)   :: n, lb
     end subroutine psb_salloc_vect_r2
+    subroutine psb_salloc_multivect(x, desc_a,info,n)
+      import
+      implicit none
+      type(psb_s_multivect_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_salloc_multivect
   end interface
 
 
@@ -103,6 +112,16 @@ Module psb_s_tools_mod
       class(psb_s_base_vect_type), intent(in), optional :: mold
       logical, intent(in), optional        :: scratch
     end subroutine psb_sasb_vect_r2
+    subroutine psb_sasb_multivect(x, desc_a, info,mold, scratch, n)
+      import
+      implicit none
+      type(psb_desc_type), intent(in)      ::  desc_a
+      type(psb_s_multivect_type), intent(inout) :: x
+      integer(psb_ipk_), intent(out)                 ::  info
+      class(psb_s_base_multivect_type), intent(in), optional :: mold
+      logical, intent(in), optional        :: scratch
+      integer(psb_ipk_), optional, intent(in)   :: n
+    end subroutine psb_sasb_multivect
   end interface
 
   interface psb_gefree
@@ -134,6 +153,13 @@ Module psb_s_tools_mod
       type(psb_s_vect_type), allocatable, intent(inout) :: x(:)
       integer(psb_ipk_), intent(out)             ::  info
     end subroutine psb_sfree_vect_r2
+    subroutine psb_sfree_multivect(x, desc_a, info)
+      import
+      implicit none
+      type(psb_desc_type), intent(in)  ::  desc_a
+      type(psb_s_multivect_type), intent(inout) :: x
+      integer(psb_ipk_), intent(out)             ::  info
+    end subroutine psb_sfree_multivect
   end interface
 
 
@@ -198,6 +224,18 @@ Module psb_s_tools_mod
       integer(psb_ipk_), optional, intent(in)    :: dupl
       logical, intent(in), optional        :: local
     end subroutine psb_sins_vect_r2
+    subroutine psb_sins_multivect(m,irw,val,x,desc_a,info,dupl,local)
+      import
+      implicit none
+      integer(psb_ipk_), intent(in)              :: m
+      type(psb_desc_type), intent(in)  :: desc_a
+      type(psb_s_multivect_type), intent(inout) :: x
+      integer(psb_ipk_), intent(in)              :: irw(:)
+      real(psb_spk_), intent(in)    :: val(:,:)
+      integer(psb_ipk_), intent(out)             :: info
+      integer(psb_ipk_), optional, intent(in)    :: dupl
+      logical, intent(in), optional        :: local
+    end subroutine psb_sins_multivect
   end interface
 
   interface psb_cdbldext

base/modules/psb_s_vect_mod.F90

@@ -129,11 +129,11 @@ module psb_s_vect_mod
 
   interface psb_set_vect_default
     module procedure psb_s_set_vect_default
-  end interface
+  end interface psb_set_vect_default
 
   interface psb_get_vect_default
     module procedure psb_s_get_vect_default
-  end interface
+  end interface psb_get_vect_default
 
 
 contains
@@ -859,23 +859,24 @@ module psb_s_multivect_mod
   end type psb_s_multivect_type
 
   public  :: psb_s_multivect, psb_s_multivect_type,&
-       & psb_set_multivect_default, psb_get_multivect_default
+       & psb_set_multivect_default, psb_get_multivect_default, &
+       & psb_s_base_multivect_type
 
   private
   interface psb_s_multivect
     module procedure constructor, size_const
-  end interface
+  end interface psb_s_multivect
 
   class(psb_s_base_multivect_type), allocatable, target,&
        & save, private :: psb_s_base_multivect_default
 
   interface psb_set_multivect_default
     module procedure psb_s_set_multivect_default
-  end interface
+  end interface psb_set_multivect_default
 
   interface psb_get_vect_default
     module procedure psb_s_get_multivect_default
-  end interface
+  end interface psb_get_vect_default
 
 
 contains

base/modules/psb_z_base_vect_mod.f90

@@ -1308,7 +1308,6 @@ contains
 
   end subroutine z_base_sctb_x
 
-
   subroutine z_base_sctb_buf(i,n,idx,beta,y)
     use psi_serial_mod
     integer(psb_ipk_) :: i, n
@@ -1357,6 +1356,8 @@ module psb_z_base_multivect_mod
   type psb_z_base_multivect_type
     !> Values. 
     complex(psb_dpk_), allocatable :: v(:,:)
+    complex(psb_dpk_), allocatable :: combuf(:) 
+    integer(psb_ipk_), allocatable :: comid(:,:)
   contains
     !
     !  Constructors/allocators
@@ -1438,17 +1439,31 @@ module psb_z_base_multivect_mod
     procedure, pass(x) :: absval1  => z_base_mlv_absval1
     procedure, pass(x) :: absval2  => z_base_mlv_absval2
     generic, public    :: absval   => absval1, absval2
-!!$    !
+
-!!$    ! Gather/scatter. These are needed for MPI interfacing.
+    !
-!!$    ! May have to be reworked. 
+    ! These are for handling gather/scatter in new
-!!$    !
+    ! comm internals implementation.
+    !
+    procedure, nopass  :: use_buffer   => z_base_mlv_use_buffer
+    procedure, pass(x) :: new_buffer   => z_base_mlv_new_buffer
+    procedure, nopass  :: device_wait  => z_base_mlv_device_wait
+    procedure, pass(x) :: free_buffer  => z_base_mlv_free_buffer
+    procedure, pass(x) :: new_comid    => z_base_mlv_new_comid
+    procedure, pass(x) :: free_comid   => z_base_mlv_free_comid
+
+    !
+    ! Gather/scatter. These are needed for MPI interfacing.
+    ! May have to be reworked. 
+    !
     procedure, pass(x) :: gthab    => z_base_mlv_gthab
     procedure, pass(x) :: gthzv    => z_base_mlv_gthzv
     procedure, pass(x) :: gthzv_x  => z_base_mlv_gthzv_x
-    generic, public    :: gth      => gthab, gthzv, gthzv_x
+    procedure, pass(x) :: gthzbuf  => z_base_mlv_gthzbuf
+    generic, public    :: gth      => gthab, gthzv, gthzv_x, gthzbuf
     procedure, pass(y) :: sctb     => z_base_mlv_sctb
     procedure, pass(y) :: sctb_x   => z_base_mlv_sctb_x
-    generic, public    :: sct      => sctb, sctb_x
+    procedure, pass(y) :: sctb_buf => z_base_mlv_sctb_buf
+    generic, public    :: sct      => sctb, sctb_x, sctb_buf
   end type psb_z_base_multivect_type
 
   interface psb_z_base_multivect
@@ -2421,6 +2436,57 @@ contains
 
   end subroutine z_base_mlv_absval2
 
+
+  function z_base_mlv_use_buffer() result(res)
+    logical :: res
+    
+    res = .true.
+  end function z_base_mlv_use_buffer
+
+  subroutine z_base_mlv_new_buffer(n,x,info)
+    use psb_realloc_mod
+    implicit none 
+    class(psb_z_base_multivect_type), intent(inout) :: x
+    integer(psb_ipk_), intent(in)              :: n
+    integer(psb_ipk_), intent(out)             :: info
+
+    integer(psb_ipk_)               :: nc
+    nc = x%get_ncols()
+    call psb_realloc(n*nc,x%combuf,info)
+  end subroutine z_base_mlv_new_buffer
+
+  subroutine z_base_mlv_new_comid(n,x,info)
+    use psb_realloc_mod
+    implicit none 
+    class(psb_z_base_multivect_type), intent(inout) :: x
+    integer(psb_ipk_), intent(in)              :: n
+    integer(psb_ipk_), intent(out)             :: info
+
+    call psb_realloc(n,2,x%comid,info)
+  end subroutine z_base_mlv_new_comid
+
+
+  subroutine z_base_mlv_free_buffer(x,info)
+    use psb_realloc_mod
+    implicit none 
+    class(psb_z_base_multivect_type), intent(inout) :: x
+    integer(psb_ipk_), intent(out)             :: info
+
+    if (allocated(x%combuf)) &
+         &  deallocate(x%combuf,stat=info)
+  end subroutine z_base_mlv_free_buffer
+
+  subroutine z_base_mlv_free_comid(x,info)
+    use psb_realloc_mod
+    implicit none 
+    class(psb_z_base_multivect_type), intent(inout) :: x
+    integer(psb_ipk_), intent(out)             :: info
+
+    if (allocated(x%comid)) &
+         &  deallocate(x%comid,stat=info)
+  end subroutine z_base_mlv_free_comid
+
+
   !
   ! Gather: Y = beta * Y + alpha * X(IDX(:))
   !
@@ -2495,6 +2561,27 @@ contains
 
   end subroutine z_base_mlv_gthzv
 
+  !
+  ! New comm internals impl. 
+  !
+  subroutine z_base_mlv_gthzbuf(i,n,idx,x)
+    use psi_serial_mod
+    integer(psb_ipk_) :: i,n
+    class(psb_i_base_vect_type) :: idx
+    class(psb_z_base_multivect_type) :: x
+    integer(psb_ipk_) :: nc
+    
+    if (.not.allocated(x%combuf)) then 
+      call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf')
+      return
+    end if
+    if (idx%is_dev()) call idx%sync()
+    if (x%is_dev()) call x%sync()
+    nc = x%get_ncols()
+    call x%gth(n,idx%v(i:),x%combuf((i-1)*nc+1:))
+
+  end subroutine z_base_mlv_gthzbuf
+
   !
   ! Scatter: 
   ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:)
@@ -2533,5 +2620,36 @@ contains
 
   end subroutine z_base_mlv_sctb_x
 
+  subroutine z_base_mlv_sctb_buf(i,n,idx,beta,y)
+    use psi_serial_mod
+    integer(psb_ipk_) :: i, n
+    class(psb_i_base_vect_type) :: idx
+    complex(psb_dpk_) :: beta
+    class(psb_z_base_multivect_type) :: y
+    integer(psb_ipk_) :: nc
+    
+    if (.not.allocated(y%combuf)) then 
+      call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf')
+      return
+    end if
+    if (y%is_dev()) call y%sync()
+    if (idx%is_dev()) call idx%sync()
+    nc = y%get_ncols()
+    call y%sct(n,idx%v(i:),y%combuf((i-1)*nc+1:),beta)
+    call y%set_host()
+    
+  end subroutine z_base_mlv_sctb_buf
+
+  !
+  !> Function  base_device_wait:
+  !! \memberof  psb_z_base_vect_type
+  !! \brief device_wait: base version is a no-op.
+  !!           
+  !
+  subroutine z_base_mlv_device_wait()
+    implicit none 
+    
+  end subroutine z_base_mlv_device_wait
+
 end module psb_z_base_multivect_mod
 

base/modules/psb_z_comm_mod.f90

@@ -34,6 +34,7 @@ module psb_z_comm_mod
   use psb_mat_mod, only  : psb_zspmat_type
   
   use psb_z_vect_mod, only : psb_z_vect_type, psb_z_base_vect_type
+  use psb_z_multivect_mod, only : psb_z_multivect_type, psb_z_base_multivect_type
 
   interface psb_ovrl
     subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode)
@@ -96,6 +97,16 @@ module psb_z_comm_mod
       integer(psb_ipk_), intent(in), optional           :: mode,data
       character, intent(in), optional         :: tran
     end subroutine psb_zhalo_vect
+    subroutine psb_zhalo_multivect(x,desc_a,info,work,tran,mode,data)
+      import
+      implicit none
+      type(psb_z_multivect_type), intent(inout)   :: x
+      type(psb_desc_type), intent(in)         :: desc_a
+      integer(psb_ipk_), intent(out)                    :: info
+      complex(psb_dpk_), target, optional, intent(inout) :: work(:)
+      integer(psb_ipk_), intent(in), optional           :: mode,data
+      character, intent(in), optional         :: tran
+    end subroutine psb_zhalo_multivect
   end interface psb_halo
 
 

base/modules/psb_z_tools_mod.f90

@@ -33,6 +33,7 @@ Module psb_z_tools_mod
   use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_
   use psb_z_vect_mod, only : psb_z_base_vect_type, psb_z_vect_type, psb_i_vect_type
   use psb_z_mat_mod, only : psb_zspmat_type, psb_z_base_sparse_mat
+  use psb_z_multivect_mod, only : psb_z_base_multivect_type, psb_z_multivect_type
 
   interface  psb_geall
     subroutine psb_zalloc(x, desc_a, info, n, lb)
@@ -67,6 +68,14 @@ Module psb_z_tools_mod
       integer(psb_ipk_),intent(out)             :: info
       integer(psb_ipk_), optional, intent(in)   :: n, lb
     end subroutine psb_zalloc_vect_r2
+    subroutine psb_zalloc_multivect(x, desc_a,info,n)
+      import
+      implicit none
+      type(psb_z_multivect_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_zalloc_multivect
   end interface
 
 
@@ -103,6 +112,16 @@ Module psb_z_tools_mod
       class(psb_z_base_vect_type), intent(in), optional :: mold
       logical, intent(in), optional        :: scratch
     end subroutine psb_zasb_vect_r2
+    subroutine psb_zasb_multivect(x, desc_a, info,mold, scratch, n)
+      import
+      implicit none
+      type(psb_desc_type), intent(in)      ::  desc_a
+      type(psb_z_multivect_type), intent(inout) :: x
+      integer(psb_ipk_), intent(out)                 ::  info
+      class(psb_z_base_multivect_type), intent(in), optional :: mold
+      logical, intent(in), optional        :: scratch
+      integer(psb_ipk_), optional, intent(in)   :: n
+    end subroutine psb_zasb_multivect
   end interface
 
   interface psb_gefree
@@ -134,6 +153,13 @@ Module psb_z_tools_mod
       type(psb_z_vect_type), allocatable, intent(inout) :: x(:)
       integer(psb_ipk_), intent(out)             ::  info
     end subroutine psb_zfree_vect_r2
+    subroutine psb_zfree_multivect(x, desc_a, info)
+      import
+      implicit none
+      type(psb_desc_type), intent(in)  ::  desc_a
+      type(psb_z_multivect_type), intent(inout) :: x
+      integer(psb_ipk_), intent(out)             ::  info
+    end subroutine psb_zfree_multivect
   end interface
 
 
@@ -198,6 +224,18 @@ Module psb_z_tools_mod
       integer(psb_ipk_), optional, intent(in)    :: dupl
       logical, intent(in), optional        :: local
     end subroutine psb_zins_vect_r2
+    subroutine psb_zins_multivect(m,irw,val,x,desc_a,info,dupl,local)
+      import
+      implicit none
+      integer(psb_ipk_), intent(in)              :: m
+      type(psb_desc_type), intent(in)  :: desc_a
+      type(psb_z_multivect_type), intent(inout) :: x
+      integer(psb_ipk_), intent(in)              :: irw(:)
+      complex(psb_dpk_), intent(in)    :: val(:,:)
+      integer(psb_ipk_), intent(out)             :: info
+      integer(psb_ipk_), optional, intent(in)    :: dupl
+      logical, intent(in), optional        :: local
+    end subroutine psb_zins_multivect
   end interface
 
   interface psb_cdbldext

base/modules/psb_z_vect_mod.F90

@@ -129,11 +129,11 @@ module psb_z_vect_mod
 
   interface psb_set_vect_default
     module procedure psb_z_set_vect_default
-  end interface
+  end interface psb_set_vect_default
 
   interface psb_get_vect_default
     module procedure psb_z_get_vect_default
-  end interface
+  end interface psb_get_vect_default
 
 
 contains
@@ -859,23 +859,24 @@ module psb_z_multivect_mod
   end type psb_z_multivect_type
 
   public  :: psb_z_multivect, psb_z_multivect_type,&
-       & psb_set_multivect_default, psb_get_multivect_default
+       & psb_set_multivect_default, psb_get_multivect_default, &
+       & psb_z_base_multivect_type
 
   private
   interface psb_z_multivect
     module procedure constructor, size_const
-  end interface
+  end interface psb_z_multivect
 
   class(psb_z_base_multivect_type), allocatable, target,&
        & save, private :: psb_z_base_multivect_default
 
   interface psb_set_multivect_default
     module procedure psb_z_set_multivect_default
-  end interface
+  end interface psb_set_multivect_default
 
   interface psb_get_vect_default
     module procedure psb_z_get_multivect_default
-  end interface
+  end interface psb_get_vect_default
 
 
 contains

base/tools/psb_callc.f90

@@ -420,3 +420,97 @@ subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb)
   return
 
 end subroutine psb_calloc_vect_r2
+
+
+subroutine psb_calloc_multivect(x, desc_a,info,n)
+  use psb_base_mod, psb_protect_name => psb_calloc_multivect
+  use psi_mod
+  implicit none
+
+  !....parameters...
+  type(psb_c_multivect_type), allocatable, 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, n_, lb_
+  integer(psb_ipk_) :: ictxt, int_err(5), exch(1)
+  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
+
+  if (present(n)) then 
+    n_ = n
+  else
+    n_ = 1
+  endif
+
+  !global check on n parameters
+  if (me == psb_root_) then
+    exch(1)=n_
+    call psb_bcast(ictxt,exch(1),root=psb_root_)
+  else
+    call psb_bcast(ictxt,exch(1),root=psb_root_)
+    if (exch(1) /= n_) then
+      info=psb_err_parm_differs_among_procs_
+      int_err(1)=1
+      call psb_errpush(info,name,int_err)
+      goto 9999
+    endif
+  endif
+  ! As this is a rank-1 array, optional parameter N is actually ignored.
+
+  !....allocate x .....
+  if (desc_a%is_asb().or.desc_a%is_upd()) then
+    nr = max(1,desc_a%get_local_cols())
+  else if (desc_a%is_bld()) 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_c_base_multivect_type :: x%v, stat=info) 
+  if (info == 0) call x%all(nr,n_,info)
+  if (info == 0) call x%zero()
+  
+  if (psb_errstatus_fatal()) then 
+    info=psb_err_alloc_request_
+    int_err(1)=nr
+    call psb_errpush(info,name,int_err,a_err='real(psb_spk_)')
+    goto 9999
+  endif
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_calloc_multivect

base/tools/psb_casb.f90

@@ -400,3 +400,93 @@ subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch)
   return
 
 end subroutine psb_casb_vect_r2
+
+
+subroutine psb_casb_multivect(x, desc_a, info, mold, scratch,n)
+  use psb_base_mod, psb_protect_name => psb_casb_multivect
+  implicit none
+
+  type(psb_desc_type), intent(in)      ::  desc_a
+  type(psb_c_multivect_type), intent(inout) ::  x
+  integer(psb_ipk_), intent(out)                 ::  info
+  class(psb_c_base_multivect_type), intent(in), optional :: mold
+  integer(psb_ipk_), optional, intent(in)   :: n    
+  logical, intent(in), optional        :: scratch
+
+  ! local variables
+  integer(psb_ipk_) :: ictxt,np,me
+  integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act, n_
+  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_cgeasb'
+
+  ictxt       = desc_a%get_context()
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+
+  scratch_ = .false.
+  if (present(scratch)) scratch_ = scratch
+
+  if (present(n)) then 
+    n_ = n
+  else
+    if (allocated(x%v)) then
+      n_ = x%v%get_ncols()
+    else
+      n_ = 1
+    end if
+  endif
+
+  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,n_,mold=mold)
+  else
+    call x%asb(ncol,n_,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 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_casb_multivect
+

base/tools/psb_dallc.f90

@@ -420,3 +420,97 @@ subroutine psb_dalloc_vect_r2(x, desc_a,info,n,lb)
   return
 
 end subroutine psb_dalloc_vect_r2
+
+
+subroutine psb_dalloc_multivect(x, desc_a,info,n)
+  use psb_base_mod, psb_protect_name => psb_dalloc_multivect
+  use psi_mod
+  implicit none
+
+  !....parameters...
+  type(psb_d_multivect_type), allocatable, 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, n_, lb_
+  integer(psb_ipk_) :: ictxt, int_err(5), exch(1)
+  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
+
+  if (present(n)) then 
+    n_ = n
+  else
+    n_ = 1
+  endif
+
+  !global check on n parameters
+  if (me == psb_root_) then
+    exch(1)=n_
+    call psb_bcast(ictxt,exch(1),root=psb_root_)
+  else
+    call psb_bcast(ictxt,exch(1),root=psb_root_)
+    if (exch(1) /= n_) then
+      info=psb_err_parm_differs_among_procs_
+      int_err(1)=1
+      call psb_errpush(info,name,int_err)
+      goto 9999
+    endif
+  endif
+  ! As this is a rank-1 array, optional parameter N is actually ignored.
+
+  !....allocate x .....
+  if (desc_a%is_asb().or.desc_a%is_upd()) then
+    nr = max(1,desc_a%get_local_cols())
+  else if (desc_a%is_bld()) 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_d_base_multivect_type :: x%v, stat=info) 
+  if (info == 0) call x%all(nr,n_,info)
+  if (info == 0) call x%zero()
+  
+  if (psb_errstatus_fatal()) then 
+    info=psb_err_alloc_request_
+    int_err(1)=nr
+    call psb_errpush(info,name,int_err,a_err='real(psb_spk_)')
+    goto 9999
+  endif
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_dalloc_multivect

base/tools/psb_dasb.f90

@@ -400,3 +400,93 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch)
   return
 
 end subroutine psb_dasb_vect_r2
+
+
+subroutine psb_dasb_multivect(x, desc_a, info, mold, scratch,n)
+  use psb_base_mod, psb_protect_name => psb_dasb_multivect
+  implicit none
+
+  type(psb_desc_type), intent(in)      ::  desc_a
+  type(psb_d_multivect_type), intent(inout) ::  x
+  integer(psb_ipk_), intent(out)                 ::  info
+  class(psb_d_base_multivect_type), intent(in), optional :: mold
+  integer(psb_ipk_), optional, intent(in)   :: n    
+  logical, intent(in), optional        :: scratch
+
+  ! local variables
+  integer(psb_ipk_) :: ictxt,np,me
+  integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act, n_
+  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_dgeasb'
+
+  ictxt       = desc_a%get_context()
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+
+  scratch_ = .false.
+  if (present(scratch)) scratch_ = scratch
+
+  if (present(n)) then 
+    n_ = n
+  else
+    if (allocated(x%v)) then
+      n_ = x%v%get_ncols()
+    else
+      n_ = 1
+    end if
+  endif
+
+  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,n_,mold=mold)
+  else
+    call x%asb(ncol,n_,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 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_dasb_multivect
+

base/tools/psb_iallc.f90

@@ -420,3 +420,97 @@ subroutine psb_ialloc_vect_r2(x, desc_a,info,n,lb)
   return
 
 end subroutine psb_ialloc_vect_r2
+
+
+subroutine psb_ialloc_multivect(x, desc_a,info,n)
+  use psb_base_mod, psb_protect_name => psb_ialloc_multivect
+  use psi_mod
+  implicit none
+
+  !....parameters...
+  type(psb_i_multivect_type), allocatable, 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, n_, lb_
+  integer(psb_ipk_) :: ictxt, int_err(5), exch(1)
+  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
+
+  if (present(n)) then 
+    n_ = n
+  else
+    n_ = 1
+  endif
+
+  !global check on n parameters
+  if (me == psb_root_) then
+    exch(1)=n_
+    call psb_bcast(ictxt,exch(1),root=psb_root_)
+  else
+    call psb_bcast(ictxt,exch(1),root=psb_root_)
+    if (exch(1) /= n_) then
+      info=psb_err_parm_differs_among_procs_
+      int_err(1)=1
+      call psb_errpush(info,name,int_err)
+      goto 9999
+    endif
+  endif
+  ! As this is a rank-1 array, optional parameter N is actually ignored.
+
+  !....allocate x .....
+  if (desc_a%is_asb().or.desc_a%is_upd()) then
+    nr = max(1,desc_a%get_local_cols())
+  else if (desc_a%is_bld()) 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_multivect_type :: x%v, stat=info) 
+  if (info == 0) call x%all(nr,n_,info)
+  if (info == 0) call x%zero()
+  
+  if (psb_errstatus_fatal()) then 
+    info=psb_err_alloc_request_
+    int_err(1)=nr
+    call psb_errpush(info,name,int_err,a_err='real(psb_spk_)')
+    goto 9999
+  endif
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_ialloc_multivect

base/tools/psb_iasb.f90

@@ -400,3 +400,93 @@ subroutine psb_iasb_vect_r2(x, desc_a, info, mold, scratch)
   return
 
 end subroutine psb_iasb_vect_r2
+
+
+subroutine psb_iasb_multivect(x, desc_a, info, mold, scratch,n)
+  use psb_base_mod, psb_protect_name => psb_iasb_multivect
+  implicit none
+
+  type(psb_desc_type), intent(in)      ::  desc_a
+  type(psb_i_multivect_type), intent(inout) ::  x
+  integer(psb_ipk_), intent(out)                 ::  info
+  class(psb_i_base_multivect_type), intent(in), optional :: mold
+  integer(psb_ipk_), optional, intent(in)   :: n    
+  logical, intent(in), optional        :: scratch
+
+  ! local variables
+  integer(psb_ipk_) :: ictxt,np,me
+  integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act, n_
+  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'
+
+  ictxt       = desc_a%get_context()
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+
+  scratch_ = .false.
+  if (present(scratch)) scratch_ = scratch
+
+  if (present(n)) then 
+    n_ = n
+  else
+    if (allocated(x%v)) then
+      n_ = x%v%get_ncols()
+    else
+      n_ = 1
+    end if
+  endif
+
+  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,n_,mold=mold)
+  else
+    call x%asb(ncol,n_,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 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_iasb_multivect
+

base/tools/psb_sallc.f90

@@ -420,3 +420,97 @@ subroutine psb_salloc_vect_r2(x, desc_a,info,n,lb)
   return
 
 end subroutine psb_salloc_vect_r2
+
+
+subroutine psb_salloc_multivect(x, desc_a,info,n)
+  use psb_base_mod, psb_protect_name => psb_salloc_multivect
+  use psi_mod
+  implicit none
+
+  !....parameters...
+  type(psb_s_multivect_type), allocatable, 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, n_, lb_
+  integer(psb_ipk_) :: ictxt, int_err(5), exch(1)
+  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
+
+  if (present(n)) then 
+    n_ = n
+  else
+    n_ = 1
+  endif
+
+  !global check on n parameters
+  if (me == psb_root_) then
+    exch(1)=n_
+    call psb_bcast(ictxt,exch(1),root=psb_root_)
+  else
+    call psb_bcast(ictxt,exch(1),root=psb_root_)
+    if (exch(1) /= n_) then
+      info=psb_err_parm_differs_among_procs_
+      int_err(1)=1
+      call psb_errpush(info,name,int_err)
+      goto 9999
+    endif
+  endif
+  ! As this is a rank-1 array, optional parameter N is actually ignored.
+
+  !....allocate x .....
+  if (desc_a%is_asb().or.desc_a%is_upd()) then
+    nr = max(1,desc_a%get_local_cols())
+  else if (desc_a%is_bld()) 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_s_base_multivect_type :: x%v, stat=info) 
+  if (info == 0) call x%all(nr,n_,info)
+  if (info == 0) call x%zero()
+  
+  if (psb_errstatus_fatal()) then 
+    info=psb_err_alloc_request_
+    int_err(1)=nr
+    call psb_errpush(info,name,int_err,a_err='real(psb_spk_)')
+    goto 9999
+  endif
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_salloc_multivect

base/tools/psb_sasb.f90

@@ -400,3 +400,93 @@ subroutine psb_sasb_vect_r2(x, desc_a, info, mold, scratch)
   return
 
 end subroutine psb_sasb_vect_r2
+
+
+subroutine psb_sasb_multivect(x, desc_a, info, mold, scratch,n)
+  use psb_base_mod, psb_protect_name => psb_sasb_multivect
+  implicit none
+
+  type(psb_desc_type), intent(in)      ::  desc_a
+  type(psb_s_multivect_type), intent(inout) ::  x
+  integer(psb_ipk_), intent(out)                 ::  info
+  class(psb_s_base_multivect_type), intent(in), optional :: mold
+  integer(psb_ipk_), optional, intent(in)   :: n    
+  logical, intent(in), optional        :: scratch
+
+  ! local variables
+  integer(psb_ipk_) :: ictxt,np,me
+  integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act, n_
+  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_sgeasb'
+
+  ictxt       = desc_a%get_context()
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+
+  scratch_ = .false.
+  if (present(scratch)) scratch_ = scratch
+
+  if (present(n)) then 
+    n_ = n
+  else
+    if (allocated(x%v)) then
+      n_ = x%v%get_ncols()
+    else
+      n_ = 1
+    end if
+  endif
+
+  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,n_,mold=mold)
+  else
+    call x%asb(ncol,n_,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 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_sasb_multivect
+

base/tools/psb_zallc.f90

@@ -420,3 +420,97 @@ subroutine psb_zalloc_vect_r2(x, desc_a,info,n,lb)
   return
 
 end subroutine psb_zalloc_vect_r2
+
+
+subroutine psb_zalloc_multivect(x, desc_a,info,n)
+  use psb_base_mod, psb_protect_name => psb_zalloc_multivect
+  use psi_mod
+  implicit none
+
+  !....parameters...
+  type(psb_z_multivect_type), allocatable, 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, n_, lb_
+  integer(psb_ipk_) :: ictxt, int_err(5), exch(1)
+  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
+
+  if (present(n)) then 
+    n_ = n
+  else
+    n_ = 1
+  endif
+
+  !global check on n parameters
+  if (me == psb_root_) then
+    exch(1)=n_
+    call psb_bcast(ictxt,exch(1),root=psb_root_)
+  else
+    call psb_bcast(ictxt,exch(1),root=psb_root_)
+    if (exch(1) /= n_) then
+      info=psb_err_parm_differs_among_procs_
+      int_err(1)=1
+      call psb_errpush(info,name,int_err)
+      goto 9999
+    endif
+  endif
+  ! As this is a rank-1 array, optional parameter N is actually ignored.
+
+  !....allocate x .....
+  if (desc_a%is_asb().or.desc_a%is_upd()) then
+    nr = max(1,desc_a%get_local_cols())
+  else if (desc_a%is_bld()) 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_z_base_multivect_type :: x%v, stat=info) 
+  if (info == 0) call x%all(nr,n_,info)
+  if (info == 0) call x%zero()
+  
+  if (psb_errstatus_fatal()) then 
+    info=psb_err_alloc_request_
+    int_err(1)=nr
+    call psb_errpush(info,name,int_err,a_err='real(psb_spk_)')
+    goto 9999
+  endif
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_zalloc_multivect

base/tools/psb_zasb.f90

@@ -400,3 +400,93 @@ subroutine psb_zasb_vect_r2(x, desc_a, info, mold, scratch)
   return
 
 end subroutine psb_zasb_vect_r2
+
+
+subroutine psb_zasb_multivect(x, desc_a, info, mold, scratch,n)
+  use psb_base_mod, psb_protect_name => psb_zasb_multivect
+  implicit none
+
+  type(psb_desc_type), intent(in)      ::  desc_a
+  type(psb_z_multivect_type), intent(inout) ::  x
+  integer(psb_ipk_), intent(out)                 ::  info
+  class(psb_z_base_multivect_type), intent(in), optional :: mold
+  integer(psb_ipk_), optional, intent(in)   :: n    
+  logical, intent(in), optional        :: scratch
+
+  ! local variables
+  integer(psb_ipk_) :: ictxt,np,me
+  integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act, n_
+  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_zgeasb'
+
+  ictxt       = desc_a%get_context()
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+
+  scratch_ = .false.
+  if (present(scratch)) scratch_ = scratch
+
+  if (present(n)) then 
+    n_ = n
+  else
+    if (allocated(x%v)) then
+      n_ = x%v%get_ncols()
+    else
+      n_ = 1
+    end if
+  endif
+
+  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,n_,mold=mold)
+  else
+    call x%asb(ncol,n_,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 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_zasb_multivect
+

test/fileread/runs/dfs.inp

@@ -1,11 +1,11 @@
 11                  Number of inputs
-matrix_0000_of_0001.mtx  !  kivap005.mtx        This (and others) from: http://math.nist.gov/MatrixMarket/  or 
+kivap005.mtx        This (and others) from: http://math.nist.gov/MatrixMarket/  or 
 NONE                  sherman3_b.mtx      http://www.cise.ufl.edu/research/sparse/matrices/index.html
 MM                  File format: MM: Matrix Market  HB: Harwell-Boeing.
-BiCG                Iterative method: BiCGSTAB CGS RGMRES BiCGSTABL BICG CG
+BiCGSTAB            Iterative method: BiCGSTAB CGS RGMRES BiCGSTABL BICG CG
 BJAC                Preconditioner NONE  DIAG  BJAC 
 CSR                 Storage format CSR COO JAD 
-3                   IPART: Partition method 0: BLK   2: graph (with Metis) 
+2                   IPART: Partition method 0: BLK   2: graph (with Metis) 
 2                   ISTOPC
 02100               ITMAX
 -1                  ITRACE