psblas3:

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/psi_i_mod.f90

New error handling.

base/internals/psi_cswapdata.F90

@@ -147,13 +147,9 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_cswapdatam
 
 subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
@@ -519,13 +515,9 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_cswapidxm
 
 !
@@ -645,13 +637,9 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_cswapdatav
 
 
@@ -1005,13 +993,9 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_cswapidxv
 
 subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data)
@@ -1082,13 +1066,9 @@ subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_cswapdata_vect
 
 
@@ -1444,13 +1424,9 @@ subroutine psi_cswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_cswapidx_vect
 
 
@@ -1807,12 +1783,8 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrc
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_cswap_vidx_vect
 

base/internals/psi_cswaptran.F90

@@ -152,13 +152,9 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_cswaptranm
 
 subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
@@ -526,13 +522,9 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_ctranidxm
 !
 !
@@ -655,13 +647,9 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_cswaptranv
 
 
@@ -1031,13 +1019,9 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_ctranidxv
 
 
@@ -1107,13 +1091,9 @@ subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_cswaptran_vect
 
 
@@ -1480,13 +1460,9 @@ subroutine psi_ctranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_ctranidx_vect
 
 

base/internals/psi_dswapdata.F90

@@ -147,13 +147,9 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_dswapdatam
 
 subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
@@ -519,13 +515,9 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_dswapidxm
 
 !
@@ -645,13 +637,9 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_dswapdatav
 
 
@@ -1005,13 +993,9 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_dswapidxv
 
 subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
@@ -1082,13 +1066,9 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_dswapdata_vect
 
 
@@ -1444,13 +1424,9 @@ subroutine psi_dswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_dswapidx_vect
 
 
@@ -1807,12 +1783,8 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrc
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_dswap_vidx_vect
 

base/internals/psi_dswaptran.F90

@@ -152,13 +152,9 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_dswaptranm
 
 subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
@@ -526,13 +522,9 @@ subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_dtranidxm
 !
 !
@@ -655,13 +647,9 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_dswaptranv
 
 
@@ -1031,13 +1019,9 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_dtranidxv
 
 
@@ -1107,13 +1091,9 @@ subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_dswaptran_vect
 
 
@@ -1480,13 +1460,9 @@ subroutine psi_dtranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_dtranidx_vect
 
 

base/internals/psi_iswapdata.F90

@@ -147,13 +147,9 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_iswapdatam
 
 subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
@@ -519,13 +515,9 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_iswapidxm
 
 !
@@ -645,13 +637,9 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_iswapdatav
 
 
@@ -1005,13 +993,9 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_iswapidxv
 
 subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data)
@@ -1040,6 +1024,7 @@ subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data)
   ! locals
   integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
   integer(psb_ipk_), pointer :: d_idx(:)
+  class(psb_i_base_vect_type), pointer :: d_vidx
   character(len=20)  :: name
 
   info=psb_success_
@@ -1068,25 +1053,22 @@ subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data)
     data_ = psb_comm_halo_
   end if
 
-  call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) 
+!!$  call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) 
+  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_idx,totxch,idxs,idxr,work,info)
+  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 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_iswapdata_vect
 
 
@@ -1442,12 +1424,367 @@ subroutine psi_iswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
+end subroutine psi_iswapidx_vect
+
+
+subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
+
+  use psi_mod, psb_protect_name => psi_iswap_vidx_vect
+  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_vect_type) :: y
+  integer(psb_ipk_)           :: beta
+  integer(psb_ipk_), target   :: work(:)
+  class(psb_i_base_vect_type), intent(in) :: 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, dimension(:) :: bsdidx, brvidx,&
+       & sdsz, rvsz, prcid, rvhd, sdhd
+  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.
+
+  integer(psb_ipk_), pointer, dimension(:) :: sndbuf, rcvbuf
+#ifdef HAVE_VOLATILE
+  volatile :: sndbuf, rcvbuf
+#endif
+  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
+
+  if (swap_mpi) then 
+    allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
+         & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
+         & stat=info)    
+    if(info /= psb_success_) then
+      call psb_errpush(psb_err_alloc_dealloc_,name)
+      goto 9999
+    end if
+
+    rvhd(:) = mpi_request_null
+    sdsz(:) = 0 
+    rvsz(:) = 0 
+
+    ! prepare info for communications
+
+    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_)
+      call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
+
+      brvidx(proc_to_comm) = rcv_pt
+      rvsz(proc_to_comm)   = nerv
+
+      bsdidx(proc_to_comm) = snd_pt
+      sdsz(proc_to_comm)   = nesd
+
+      rcv_pt = rcv_pt + nerv
+      snd_pt = snd_pt + nesd
+      pnti   = pnti + nerv + nesd + 3
+
+    end do
+
+  else
+    allocate(rvhd(totxch),prcid(totxch),stat=info) 
+    if(info /= psb_success_) then
+      call psb_errpush(psb_err_alloc_dealloc_,name)
+      goto 9999
+    end if
   end if
+
+
+  totrcv_ = max(totrcv_,1)
+  totsnd_ = max(totsnd_,1)
+  if((totrcv_+totsnd_) < size(work)) then
+    sndbuf => work(1:totsnd_)
+    rcvbuf => work(totsnd_+1:totsnd_+totrcv_)
+    albf=.false.
+  else
+    allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
+    if(info /= psb_success_) then
+      call psb_errpush(psb_err_alloc_dealloc_,name)
+      goto 9999
+    end if
+    albf=.true.
+  end if
+
+
+  if (do_send) then
+
+    ! Pack send buffers
+    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_)
+      idx_pt = 1+pnti+nerv+psb_n_elem_send_
+      call y%gth(idx_pt,nesd,idx,&
+           & sndbuf(snd_pt:snd_pt+nesd-1))
+      snd_pt = snd_pt + nesd 
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+  end if
+
+  ! Case SWAP_MPI
+  if (swap_mpi) then
+
+    ! swap elements using mpi_alltoallv
+    call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
+         & psb_mpi_ipk_integer,rcvbuf,rvsz,&
+         & brvidx,psb_mpi_ipk_integer,icomm,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
+
+  else if (swap_sync) then
+
+    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_)
+
+      if (proc_to_comm  <  me) then
+        if (nesd>0) call psb_snd(ictxt,&
+             & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
+        if (nerv>0) call psb_rcv(ictxt,&
+             & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
+      else if (proc_to_comm  >  me) then
+        if (nerv>0) call psb_rcv(ictxt,&
+             & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
+        if (nesd>0) call psb_snd(ictxt,&
+             & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
+      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
+        rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
+      end if
+      rcv_pt = rcv_pt + nerv
+      snd_pt = snd_pt + nesd
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+
+  else if (swap_send .and. swap_recv) then
+
+    ! First I post all the non blocking receives
+    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_)
+
+      call psb_get_rank(prcid(i),ictxt,proc_to_comm)      
+      if ((nerv>0).and.(proc_to_comm /= me)) then 
+        p2ptag = psb_int_swap_tag
+        call mpi_irecv(rcvbuf(rcv_pt),nerv,&
+             & psb_mpi_ipk_integer,prcid(i),&
+             & p2ptag, icomm,rvhd(i),iret)
+      end if
+      rcv_pt = rcv_pt + nerv
+      snd_pt = snd_pt + nesd
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+
+    ! Then I post all the blocking sends
+    if (usersend)  call mpi_barrier(icomm,iret)
+
+    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_)
+
+      p2ptag = psb_int_swap_tag
+
+      if ((nesd>0).and.(proc_to_comm /= me)) then 
+        if (usersend) then 
+          call mpi_rsend(sndbuf(snd_pt),nesd,&
+               & psb_mpi_ipk_integer,prcid(i),&
+               & p2ptag,icomm,iret)
+        else
+          call mpi_send(sndbuf(snd_pt),nesd,&
+               & psb_mpi_ipk_integer,prcid(i),&
+               & p2ptag,icomm,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
+      end if
+      rcv_pt = rcv_pt + nerv
+      snd_pt = snd_pt + nesd
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+
+    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_)
+
+      p2ptag = psb_int_swap_tag
+
+      if ((proc_to_comm /= me).and.(nerv>0)) then
+        call mpi_wait(rvhd(i),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
+      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
+        rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
+      end if
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+
+  else if (swap_send) then
+
+    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_)
+      if (nesd>0) call psb_snd(ictxt,&
+           & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
+      rcv_pt = rcv_pt + nerv
+      snd_pt = snd_pt + nesd
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+  else if (swap_recv) then
+
+    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_)
+      if (nerv>0) call psb_rcv(ictxt,&
+           & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
+      rcv_pt = rcv_pt + nerv
+      snd_pt = snd_pt + nesd
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+  end if
+
+  if (do_recv) then 
+
+    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_
+      call y%sct(idx_pt,nerv,idx,&
+           & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta)
+      rcv_pt = rcv_pt + nerv
+      snd_pt = snd_pt + nesd
+      pnti   = pnti + nerv + nesd + 3
+    end do
+
+  end if
+
+  if (swap_mpi) then 
+    deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,&
+         & stat=info)
+  else
+    deallocate(rvhd,prcid,stat=info)
+  end if
+  if(info /= psb_success_) then
+    call psb_errpush(psb_err_alloc_dealloc_,name)
+    goto 9999
+  end if
+  if(albf) deallocate(sndbuf,rcvbuf,stat=info)
+  if(info /= psb_success_) then
+    call psb_errpush(psb_err_alloc_dealloc_,name)
+    goto 9999
+  end if
+
+  call psb_erractionrestore(err_act)
   return
-end subroutine psi_iswapidx_vect
+
+9999 call psb_error_handler(ictxt,err_act)
+
+    return
+end subroutine psi_iswap_vidx_vect
 

base/internals/psi_iswaptran.F90

@@ -152,13 +152,9 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_iswaptranm
 
 subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
@@ -526,13 +522,9 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_itranidxm
 !
 !
@@ -655,13 +647,9 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_iswaptranv
 
 
@@ -1031,13 +1019,9 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_itranidxv
 
 
@@ -1107,13 +1091,9 @@ subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_iswaptran_vect
 
 
@@ -1480,13 +1460,9 @@ subroutine psi_itranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_itranidx_vect
 
 

base/internals/psi_sswapdata.F90

@@ -147,13 +147,9 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_sswapdatam
 
 subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
@@ -519,13 +515,9 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_sswapidxm
 
 !
@@ -645,13 +637,9 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_sswapdatav
 
 
@@ -1005,13 +993,9 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_sswapidxv
 
 subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data)
@@ -1082,13 +1066,9 @@ subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_sswapdata_vect
 
 
@@ -1444,13 +1424,9 @@ subroutine psi_sswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_sswapidx_vect
 
 
@@ -1807,12 +1783,8 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrc
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_sswap_vidx_vect
 

base/internals/psi_sswaptran.F90

@@ -152,13 +152,9 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_sswaptranm
 
 subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
@@ -526,13 +522,9 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_stranidxm
 !
 !
@@ -655,13 +647,9 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_sswaptranv
 
 
@@ -1031,13 +1019,9 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_stranidxv
 
 
@@ -1107,13 +1091,9 @@ subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_sswaptran_vect
 
 
@@ -1480,13 +1460,9 @@ subroutine psi_stranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_stranidx_vect
 
 

base/internals/psi_zswapdata.F90

@@ -147,13 +147,9 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_zswapdatam
 
 subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
@@ -519,13 +515,9 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_zswapidxm
 
 !
@@ -645,13 +637,9 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_zswapdatav
 
 
@@ -1005,13 +993,9 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_zswapidxv
 
 subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data)
@@ -1082,13 +1066,9 @@ subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_zswapdata_vect
 
 
@@ -1444,13 +1424,9 @@ subroutine psi_zswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_zswapidx_vect
 
 
@@ -1807,12 +1783,8 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrc
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_zswap_vidx_vect
 

base/internals/psi_zswaptran.F90

@@ -152,13 +152,9 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_zswaptranm
 
 subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
@@ -526,13 +522,9 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_ztranidxm
 !
 !
@@ -655,13 +647,9 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_zswaptranv
 
 
@@ -1031,13 +1019,9 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_ztranidxv
 
 
@@ -1107,13 +1091,9 @@ subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data)
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_zswaptran_vect
 
 
@@ -1480,13 +1460,9 @@ subroutine psi_ztranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
   call psb_erractionrestore(err_act)
   return
 
-9999 continue
+9999 call psb_error_handler(ictxt,err_act)
-  call psb_erractionrestore(err_act)
+
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
     return
-  end if
-  return
 end subroutine psi_ztranidx_vect
 
 

base/modules/psi_i_mod.f90

@@ -251,6 +251,16 @@ module psi_i_mod
       integer(psb_ipk_),target :: work(:)
       integer(psb_ipk_), intent(in)   :: idx(:),totxch,totsnd,totrcv
     end subroutine psi_iswapidx_vect
+    subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
+      import :: psb_desc_type, psb_ipk_, psb_i_base_vect_type
+      integer(psb_ipk_), intent(in)           :: iictxt,iicomm,flag
+      integer(psb_ipk_), intent(out)          :: info
+      class(psb_i_base_vect_type)             :: y
+      integer(psb_ipk_)                       :: beta
+      integer(psb_ipk_), target               :: work(:)
+      class(psb_i_base_vect_type), intent(in) :: idx
+      integer(psb_ipk_), intent(in)           :: totxch,totsnd, totrcv
+    end subroutine psi_iswap_vidx_vect
   end interface