psblas:

base/comm/psb_cgather.f90
 base/comm/psb_dgather.f90
 base/comm/psb_igather.f90
 base/comm/psb_sgather.f90
 base/comm/psb_zgather.f90
 base/modules/psb_c_comm_mod.f90
 base/modules/psb_d_comm_mod.f90
 base/modules/psb_i_comm_mod.f90
 base/modules/psb_s_comm_mod.f90
 base/modules/psb_z_comm_mod.f90
 base/tools/psb_cfree.f90
 base/tools/psb_cins.f90
 base/tools/psb_dfree.f90
 base/tools/psb_dins.f90
 base/tools/psb_ifree.f90
 base/tools/psb_iins.f90
 base/tools/psb_sfree.f90
 base/tools/psb_sins.f90
 base/tools/psb_zfree.f90
 base/tools/psb_zins.f90

Multivectors: gather/geins/gefree

base/comm/psb_cgather.f90

@@ -441,3 +441,115 @@ subroutine  psb_cgather_vect(globx, locx, desc_a, info, iroot)
   return
 
 end subroutine psb_cgather_vect
+
+
+subroutine  psb_cgather_multivect(globx, locx, desc_a, info, iroot)
+  use psb_base_mod, psb_protect_name => psb_cgather_multivect
+  implicit none
+
+  type(psb_c_multivect_type), intent(inout) :: locx
+  complex(psb_spk_), intent(out), allocatable   :: globx(:,:)
+  type(psb_desc_type), intent(in)   :: desc_a
+  integer(psb_ipk_), intent(out)              :: info
+  integer(psb_ipk_), intent(in), optional     :: iroot
+
+
+  ! locals
+  integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
+  integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
+       & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
+  complex(psb_spk_), allocatable :: llocx(:,:)
+  character(len=20)        :: name, ch_err
+
+  name='psb_cgatherv'
+  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 (present(iroot)) then
+    root = iroot
+    if((root < -1).or.(root > np)) then
+      info=psb_err_input_value_invalid_i_
+      ierr(1)=5; ierr(2)=root;
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+  else
+    root = -1
+  end if
+
+  jglobx=1
+  iglobx = 1
+  jlocx=1
+  ilocx = 1
+
+
+  m = desc_a%get_global_rows()
+  n = desc_a%get_global_cols()
+  lda_globx = m
+  lda_locx  = locx%get_nrows()
+  k = locx%get_ncols()
+
+
+  !  there should be a global check on k here!!!
+
+  call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
+  if (info == psb_success_) &
+       & call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx)
+  if(info /= psb_success_) then
+    info=psb_err_from_subroutine_
+    ch_err='psb_chk(glob)vect'
+    call psb_errpush(info,name,a_err=ch_err)
+    goto 9999
+  end if
+
+  if ((ilx /= 1).or.(iglobx /= 1)) then
+    info=psb_err_ix_n1_iy_n1_unsupported_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+  
+  call psb_realloc(m,k,globx,info)
+  if (info /= psb_success_) then 
+    info=psb_err_alloc_dealloc_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+  
+  globx(:,:) = czero
+  llocx    = locx%get_vect()
+
+  do i=1,desc_a%get_local_rows()
+    call psb_loc_to_glob(i,idx,desc_a,info)
+    globx(idx,:) = llocx(i,:)
+  end do
+  
+  ! adjust overlapped elements
+  do i=1, size(desc_a%ovrlap_elem,1)
+    if (me /= desc_a%ovrlap_elem(i,3)) then 
+      idx = desc_a%ovrlap_elem(i,1)
+      call psb_loc_to_glob(idx,desc_a,info)
+      globx(idx,:) = czero
+    end if
+  end do
+  
+  call psb_sum(ictxt,globx(1:m,1:k),root=root)
+
+  call psb_erractionrestore(err_act)
+  return  
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_cgather_multivect

base/comm/psb_dgather.f90

@@ -441,3 +441,115 @@ subroutine  psb_dgather_vect(globx, locx, desc_a, info, iroot)
   return
 
 end subroutine psb_dgather_vect
+
+
+subroutine  psb_dgather_multivect(globx, locx, desc_a, info, iroot)
+  use psb_base_mod, psb_protect_name => psb_dgather_multivect
+  implicit none
+
+  type(psb_d_multivect_type), intent(inout) :: locx
+  real(psb_dpk_), intent(out), allocatable   :: globx(:,:)
+  type(psb_desc_type), intent(in)   :: desc_a
+  integer(psb_ipk_), intent(out)              :: info
+  integer(psb_ipk_), intent(in), optional     :: iroot
+
+
+  ! locals
+  integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
+  integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
+       & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
+  real(psb_dpk_), allocatable :: llocx(:,:)
+  character(len=20)        :: name, ch_err
+
+  name='psb_cgatherv'
+  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 (present(iroot)) then
+    root = iroot
+    if((root < -1).or.(root > np)) then
+      info=psb_err_input_value_invalid_i_
+      ierr(1)=5; ierr(2)=root;
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+  else
+    root = -1
+  end if
+
+  jglobx=1
+  iglobx = 1
+  jlocx=1
+  ilocx = 1
+
+
+  m = desc_a%get_global_rows()
+  n = desc_a%get_global_cols()
+  lda_globx = m
+  lda_locx  = locx%get_nrows()
+  k = locx%get_ncols()
+
+
+  !  there should be a global check on k here!!!
+
+  call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
+  if (info == psb_success_) &
+       & call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx)
+  if(info /= psb_success_) then
+    info=psb_err_from_subroutine_
+    ch_err='psb_chk(glob)vect'
+    call psb_errpush(info,name,a_err=ch_err)
+    goto 9999
+  end if
+
+  if ((ilx /= 1).or.(iglobx /= 1)) then
+    info=psb_err_ix_n1_iy_n1_unsupported_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+  
+  call psb_realloc(m,k,globx,info)
+  if (info /= psb_success_) then 
+    info=psb_err_alloc_dealloc_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+  
+  globx(:,:) = dzero
+  llocx    = locx%get_vect()
+
+  do i=1,desc_a%get_local_rows()
+    call psb_loc_to_glob(i,idx,desc_a,info)
+    globx(idx,:) = llocx(i,:)
+  end do
+  
+  ! adjust overlapped elements
+  do i=1, size(desc_a%ovrlap_elem,1)
+    if (me /= desc_a%ovrlap_elem(i,3)) then 
+      idx = desc_a%ovrlap_elem(i,1)
+      call psb_loc_to_glob(idx,desc_a,info)
+      globx(idx,:) = dzero
+    end if
+  end do
+  
+  call psb_sum(ictxt,globx(1:m,1:k),root=root)
+
+  call psb_erractionrestore(err_act)
+  return  
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_dgather_multivect

base/comm/psb_igather.f90

@@ -441,3 +441,115 @@ subroutine  psb_igather_vect(globx, locx, desc_a, info, iroot)
   return
 
 end subroutine psb_igather_vect
+
+
+subroutine  psb_igather_multivect(globx, locx, desc_a, info, iroot)
+  use psb_base_mod, psb_protect_name => psb_igather_multivect
+  implicit none
+
+  type(psb_i_multivect_type), intent(inout) :: locx
+  integer(psb_ipk_), intent(out), allocatable   :: globx(:,:)
+  type(psb_desc_type), intent(in)   :: desc_a
+  integer(psb_ipk_), intent(out)              :: info
+  integer(psb_ipk_), intent(in), optional     :: iroot
+
+
+  ! locals
+  integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
+  integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
+       & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
+  integer(psb_ipk_), allocatable :: llocx(:,:)
+  character(len=20)        :: name, ch_err
+
+  name='psb_cgatherv'
+  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 (present(iroot)) then
+    root = iroot
+    if((root < -1).or.(root > np)) then
+      info=psb_err_input_value_invalid_i_
+      ierr(1)=5; ierr(2)=root;
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+  else
+    root = -1
+  end if
+
+  jglobx=1
+  iglobx = 1
+  jlocx=1
+  ilocx = 1
+
+
+  m = desc_a%get_global_rows()
+  n = desc_a%get_global_cols()
+  lda_globx = m
+  lda_locx  = locx%get_nrows()
+  k = locx%get_ncols()
+
+
+  !  there should be a global check on k here!!!
+
+  call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
+  if (info == psb_success_) &
+       & call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx)
+  if(info /= psb_success_) then
+    info=psb_err_from_subroutine_
+    ch_err='psb_chk(glob)vect'
+    call psb_errpush(info,name,a_err=ch_err)
+    goto 9999
+  end if
+
+  if ((ilx /= 1).or.(iglobx /= 1)) then
+    info=psb_err_ix_n1_iy_n1_unsupported_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+  
+  call psb_realloc(m,k,globx,info)
+  if (info /= psb_success_) then 
+    info=psb_err_alloc_dealloc_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+  
+  globx(:,:) = izero
+  llocx    = locx%get_vect()
+
+  do i=1,desc_a%get_local_rows()
+    call psb_loc_to_glob(i,idx,desc_a,info)
+    globx(idx,:) = llocx(i,:)
+  end do
+  
+  ! adjust overlapped elements
+  do i=1, size(desc_a%ovrlap_elem,1)
+    if (me /= desc_a%ovrlap_elem(i,3)) then 
+      idx = desc_a%ovrlap_elem(i,1)
+      call psb_loc_to_glob(idx,desc_a,info)
+      globx(idx,:) = izero
+    end if
+  end do
+  
+  call psb_sum(ictxt,globx(1:m,1:k),root=root)
+
+  call psb_erractionrestore(err_act)
+  return  
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_igather_multivect

base/comm/psb_sgather.f90

@@ -441,3 +441,115 @@ subroutine  psb_sgather_vect(globx, locx, desc_a, info, iroot)
   return
 
 end subroutine psb_sgather_vect
+
+
+subroutine  psb_sgather_multivect(globx, locx, desc_a, info, iroot)
+  use psb_base_mod, psb_protect_name => psb_sgather_multivect
+  implicit none
+
+  type(psb_s_multivect_type), intent(inout) :: locx
+  real(psb_spk_), intent(out), allocatable   :: globx(:,:)
+  type(psb_desc_type), intent(in)   :: desc_a
+  integer(psb_ipk_), intent(out)              :: info
+  integer(psb_ipk_), intent(in), optional     :: iroot
+
+
+  ! locals
+  integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
+  integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
+       & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
+  real(psb_spk_), allocatable :: llocx(:,:)
+  character(len=20)        :: name, ch_err
+
+  name='psb_cgatherv'
+  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 (present(iroot)) then
+    root = iroot
+    if((root < -1).or.(root > np)) then
+      info=psb_err_input_value_invalid_i_
+      ierr(1)=5; ierr(2)=root;
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+  else
+    root = -1
+  end if
+
+  jglobx=1
+  iglobx = 1
+  jlocx=1
+  ilocx = 1
+
+
+  m = desc_a%get_global_rows()
+  n = desc_a%get_global_cols()
+  lda_globx = m
+  lda_locx  = locx%get_nrows()
+  k = locx%get_ncols()
+
+
+  !  there should be a global check on k here!!!
+
+  call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
+  if (info == psb_success_) &
+       & call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx)
+  if(info /= psb_success_) then
+    info=psb_err_from_subroutine_
+    ch_err='psb_chk(glob)vect'
+    call psb_errpush(info,name,a_err=ch_err)
+    goto 9999
+  end if
+
+  if ((ilx /= 1).or.(iglobx /= 1)) then
+    info=psb_err_ix_n1_iy_n1_unsupported_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+  
+  call psb_realloc(m,k,globx,info)
+  if (info /= psb_success_) then 
+    info=psb_err_alloc_dealloc_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+  
+  globx(:,:) = szero
+  llocx    = locx%get_vect()
+
+  do i=1,desc_a%get_local_rows()
+    call psb_loc_to_glob(i,idx,desc_a,info)
+    globx(idx,:) = llocx(i,:)
+  end do
+  
+  ! adjust overlapped elements
+  do i=1, size(desc_a%ovrlap_elem,1)
+    if (me /= desc_a%ovrlap_elem(i,3)) then 
+      idx = desc_a%ovrlap_elem(i,1)
+      call psb_loc_to_glob(idx,desc_a,info)
+      globx(idx,:) = szero
+    end if
+  end do
+  
+  call psb_sum(ictxt,globx(1:m,1:k),root=root)
+
+  call psb_erractionrestore(err_act)
+  return  
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_sgather_multivect

base/comm/psb_zgather.f90

@@ -441,3 +441,115 @@ subroutine  psb_zgather_vect(globx, locx, desc_a, info, iroot)
   return
 
 end subroutine psb_zgather_vect
+
+
+subroutine  psb_zgather_multivect(globx, locx, desc_a, info, iroot)
+  use psb_base_mod, psb_protect_name => psb_zgather_multivect
+  implicit none
+
+  type(psb_z_multivect_type), intent(inout) :: locx
+  complex(psb_dpk_), intent(out), allocatable   :: globx(:,:)
+  type(psb_desc_type), intent(in)   :: desc_a
+  integer(psb_ipk_), intent(out)              :: info
+  integer(psb_ipk_), intent(in), optional     :: iroot
+
+
+  ! locals
+  integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
+  integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
+       & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
+  complex(psb_dpk_), allocatable :: llocx(:,:)
+  character(len=20)        :: name, ch_err
+
+  name='psb_cgatherv'
+  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 (present(iroot)) then
+    root = iroot
+    if((root < -1).or.(root > np)) then
+      info=psb_err_input_value_invalid_i_
+      ierr(1)=5; ierr(2)=root;
+      call psb_errpush(info,name,i_err=ierr)
+      goto 9999
+    end if
+  else
+    root = -1
+  end if
+
+  jglobx=1
+  iglobx = 1
+  jlocx=1
+  ilocx = 1
+
+
+  m = desc_a%get_global_rows()
+  n = desc_a%get_global_cols()
+  lda_globx = m
+  lda_locx  = locx%get_nrows()
+  k = locx%get_ncols()
+
+
+  !  there should be a global check on k here!!!
+
+  call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
+  if (info == psb_success_) &
+       & call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx)
+  if(info /= psb_success_) then
+    info=psb_err_from_subroutine_
+    ch_err='psb_chk(glob)vect'
+    call psb_errpush(info,name,a_err=ch_err)
+    goto 9999
+  end if
+
+  if ((ilx /= 1).or.(iglobx /= 1)) then
+    info=psb_err_ix_n1_iy_n1_unsupported_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+  
+  call psb_realloc(m,k,globx,info)
+  if (info /= psb_success_) then 
+    info=psb_err_alloc_dealloc_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+  
+  globx(:,:) = zzero
+  llocx    = locx%get_vect()
+
+  do i=1,desc_a%get_local_rows()
+    call psb_loc_to_glob(i,idx,desc_a,info)
+    globx(idx,:) = llocx(i,:)
+  end do
+  
+  ! adjust overlapped elements
+  do i=1, size(desc_a%ovrlap_elem,1)
+    if (me /= desc_a%ovrlap_elem(i,3)) then 
+      idx = desc_a%ovrlap_elem(i,1)
+      call psb_loc_to_glob(idx,desc_a,info)
+      globx(idx,:) = zzero
+    end if
+  end do
+  
+  call psb_sum(ictxt,globx(1:m,1:k),root=root)
+
+  call psb_erractionrestore(err_act)
+  return  
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_zgather_multivect

base/modules/psb_c_comm_mod.f90

@@ -178,6 +178,15 @@ module psb_c_comm_mod
       integer(psb_ipk_), intent(out)            :: info
       integer(psb_ipk_), intent(in), optional   :: root
     end subroutine psb_cgather_vect
+    subroutine psb_cgather_multivect(globx, locx, desc_a, info, root)
+      import
+      implicit none
+      type(psb_c_multivect_type), intent(inout) :: locx
+      complex(psb_spk_), intent(out), allocatable :: globx(:)
+      type(psb_desc_type), intent(in) :: desc_a
+      integer(psb_ipk_), intent(out)            :: info
+      integer(psb_ipk_), intent(in), optional   :: root
+    end subroutine psb_cgather_multivect
   end interface psb_gather
 
 end module psb_c_comm_mod

base/modules/psb_d_comm_mod.f90

@@ -178,6 +178,15 @@ module psb_d_comm_mod
       integer(psb_ipk_), intent(out)            :: info
       integer(psb_ipk_), intent(in), optional   :: root
     end subroutine psb_dgather_vect
+    subroutine psb_dgather_multivect(globx, locx, desc_a, info, root)
+      import
+      implicit none
+      type(psb_d_multivect_type), intent(inout) :: locx
+      real(psb_dpk_), intent(out), allocatable :: globx(:)
+      type(psb_desc_type), intent(in) :: desc_a
+      integer(psb_ipk_), intent(out)            :: info
+      integer(psb_ipk_), intent(in), optional   :: root
+    end subroutine psb_dgather_multivect
   end interface psb_gather
 
 end module psb_d_comm_mod

base/modules/psb_i_comm_mod.f90

@@ -167,6 +167,15 @@ module psb_i_comm_mod
       integer(psb_ipk_), intent(out)            :: info
       integer(psb_ipk_), intent(in), optional   :: root
     end subroutine psb_igather_vect
+    subroutine psb_igather_multivect(globx, locx, desc_a, info, root)
+      import
+      implicit none
+      type(psb_i_multivect_type), intent(inout) :: locx
+      integer(psb_ipk_), intent(out), allocatable :: globx(:)
+      type(psb_desc_type), intent(in) :: desc_a
+      integer(psb_ipk_), intent(out)            :: info
+      integer(psb_ipk_), intent(in), optional   :: root
+    end subroutine psb_igather_multivect
   end interface psb_gather
 
 end module psb_i_comm_mod

base/modules/psb_s_comm_mod.f90

@@ -178,6 +178,15 @@ module psb_s_comm_mod
       integer(psb_ipk_), intent(out)            :: info
       integer(psb_ipk_), intent(in), optional   :: root
     end subroutine psb_sgather_vect
+    subroutine psb_sgather_multivect(globx, locx, desc_a, info, root)
+      import
+      implicit none
+      type(psb_s_multivect_type), intent(inout) :: locx
+      real(psb_spk_), intent(out), allocatable :: globx(:)
+      type(psb_desc_type), intent(in) :: desc_a
+      integer(psb_ipk_), intent(out)            :: info
+      integer(psb_ipk_), intent(in), optional   :: root
+    end subroutine psb_sgather_multivect
   end interface psb_gather
 
 end module psb_s_comm_mod

base/modules/psb_z_comm_mod.f90

@@ -178,6 +178,15 @@ module psb_z_comm_mod
       integer(psb_ipk_), intent(out)            :: info
       integer(psb_ipk_), intent(in), optional   :: root
     end subroutine psb_zgather_vect
+    subroutine psb_zgather_multivect(globx, locx, desc_a, info, root)
+      import
+      implicit none
+      type(psb_z_multivect_type), intent(inout) :: locx
+      complex(psb_dpk_), intent(out), allocatable :: globx(:)
+      type(psb_desc_type), intent(in) :: desc_a
+      integer(psb_ipk_), intent(out)            :: info
+      integer(psb_ipk_), intent(in), optional   :: root
+    end subroutine psb_zgather_multivect
   end interface psb_gather
 
 end module psb_z_comm_mod

base/tools/psb_cfree.f90

@@ -265,3 +265,58 @@ subroutine psb_cfree_vect_r2(x, desc_a, info)
   return
 
 end subroutine psb_cfree_vect_r2
+
+
+subroutine psb_cfree_multivect(x, desc_a, info)
+  use psb_base_mod, psb_protect_name => psb_cfree_multivect
+  implicit none
+  !....parameters...
+  type(psb_c_multivect_type), intent(inout) :: x
+  type(psb_desc_type), intent(in)  :: desc_a
+  integer(psb_ipk_), intent(out)             :: info 
+  !...locals....
+  integer(psb_ipk_) :: ictxt,np,me,err_act
+  character(len=20)   :: name
+
+
+  info=psb_success_
+  if (psb_errstatus_fatal()) return 
+  call psb_erractionsave(err_act)
+  name='psb_cfree'
+
+  if (.not.desc_a%is_ok()) then
+    info = psb_err_invalid_cd_state_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+  ictxt = desc_a%get_context()
+
+  call psb_info(ictxt, me, np)
+  if (np == -1) then
+    info = psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  if (.not.allocated(x%v)) then 
+    info = psb_err_invalid_vect_state_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+
+  call x%free(info)
+
+  if (info /= psb_no_err_) then
+    info=psb_err_alloc_dealloc_
+    call psb_errpush(info,name)
+  endif
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_cfree_multivect

base/tools/psb_cins.f90

@@ -713,3 +713,119 @@ subroutine psb_cinsi(m, irw, val, x, desc_a, info, dupl,local)
 end subroutine psb_cinsi
 
 
+
+subroutine psb_cins_multivect(m, irw, val, x, desc_a, info, dupl,local)
+  use psb_base_mod, psb_protect_name => psb_cins_multivect
+  use psi_mod
+  implicit none
+
+  ! m rows number of submatrix belonging to val to be inserted
+  ! ix  x global-row corresponding to position at which val submatrix
+  !     must be inserted
+
+  !....parameters...
+  integer(psb_ipk_), intent(in)                  :: m
+  integer(psb_ipk_), intent(in)                  :: irw(:)
+  complex(psb_spk_), intent(in)        :: val(:,:)
+  type(psb_c_multivect_type), intent(inout) :: x
+  type(psb_desc_type), intent(in)      :: desc_a
+  integer(psb_ipk_), intent(out)                 :: info
+  integer(psb_ipk_), optional, intent(in)        :: dupl
+  logical, intent(in), optional        :: local
+
+  !locals.....
+  integer(psb_ipk_) :: ictxt,i,&
+       & loc_rows,loc_cols,mglob,err_act, int_err(5)
+  integer(psb_ipk_) :: np, me, dupl_
+  integer(psb_ipk_), allocatable   :: irl(:)
+  logical :: local_
+  character(len=20)      :: name
+
+  if (psb_errstatus_fatal()) return 
+  info=psb_success_
+  call psb_erractionsave(err_act)
+  name = 'psb_cinsvi'
+
+  if (.not.desc_a%is_ok()) then
+    info = psb_err_invalid_cd_state_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+
+  ictxt = desc_a%get_context()
+
+  call psb_info(ictxt, me, np)
+  if (np == -1) then
+    info = psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  !... check parameters....
+  if (m < 0) then
+    info = psb_err_iarg_neg_
+    int_err(1) = 1
+    int_err(2) = m
+    call psb_errpush(info,name,int_err)
+    goto 9999
+  else if (x%get_nrows() < desc_a%get_local_rows()) then
+    info = 310
+    int_err(1) = 5
+    int_err(2) = 4
+    call psb_errpush(info,name,int_err)
+    goto 9999
+  endif
+
+  if (m == 0) return  
+  loc_rows = desc_a%get_local_rows()
+  loc_cols = desc_a%get_local_cols()
+  mglob    = desc_a%get_global_rows()
+
+  if (.not.allocated(x%v)) then 
+    info = psb_err_invalid_vect_state_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+
+
+  allocate(irl(m),stat=info) 
+  if (info /= psb_success_) then 
+    info = psb_err_alloc_dealloc_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  if (present(dupl)) then 
+    dupl_ = dupl
+  else
+    dupl_ = psb_dupl_ovwrt_
+  endif
+  if (present(local)) then 
+    local_ = local
+  else
+    local_ = .false.
+  endif
+
+  if (local_) then 
+    irl(1:m) = irw(1:m)
+  else
+    call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
+  end if
+  call x%ins(m,irl,val,dupl_,info) 
+  if (info /= 0) then 
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+  deallocate(irl)
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_cins_multivect
+
+

base/tools/psb_dfree.f90

@@ -265,3 +265,58 @@ subroutine psb_dfree_vect_r2(x, desc_a, info)
   return
 
 end subroutine psb_dfree_vect_r2
+
+
+subroutine psb_dfree_multivect(x, desc_a, info)
+  use psb_base_mod, psb_protect_name => psb_dfree_multivect
+  implicit none
+  !....parameters...
+  type(psb_d_multivect_type), intent(inout) :: x
+  type(psb_desc_type), intent(in)  :: desc_a
+  integer(psb_ipk_), intent(out)             :: info 
+  !...locals....
+  integer(psb_ipk_) :: ictxt,np,me,err_act
+  character(len=20)   :: name
+
+
+  info=psb_success_
+  if (psb_errstatus_fatal()) return 
+  call psb_erractionsave(err_act)
+  name='psb_dfree'
+
+  if (.not.desc_a%is_ok()) then
+    info = psb_err_invalid_cd_state_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+  ictxt = desc_a%get_context()
+
+  call psb_info(ictxt, me, np)
+  if (np == -1) then
+    info = psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  if (.not.allocated(x%v)) then 
+    info = psb_err_invalid_vect_state_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+
+  call x%free(info)
+
+  if (info /= psb_no_err_) then
+    info=psb_err_alloc_dealloc_
+    call psb_errpush(info,name)
+  endif
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_dfree_multivect

base/tools/psb_dins.f90

@@ -713,3 +713,119 @@ subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl,local)
 end subroutine psb_dinsi
 
 
+
+subroutine psb_dins_multivect(m, irw, val, x, desc_a, info, dupl,local)
+  use psb_base_mod, psb_protect_name => psb_dins_multivect
+  use psi_mod
+  implicit none
+
+  ! m rows number of submatrix belonging to val to be inserted
+  ! ix  x global-row corresponding to position at which val submatrix
+  !     must be inserted
+
+  !....parameters...
+  integer(psb_ipk_), intent(in)                  :: m
+  integer(psb_ipk_), intent(in)                  :: irw(:)
+  real(psb_dpk_), intent(in)        :: val(:,:)
+  type(psb_d_multivect_type), intent(inout) :: x
+  type(psb_desc_type), intent(in)      :: desc_a
+  integer(psb_ipk_), intent(out)                 :: info
+  integer(psb_ipk_), optional, intent(in)        :: dupl
+  logical, intent(in), optional        :: local
+
+  !locals.....
+  integer(psb_ipk_) :: ictxt,i,&
+       & loc_rows,loc_cols,mglob,err_act, int_err(5)
+  integer(psb_ipk_) :: np, me, dupl_
+  integer(psb_ipk_), allocatable   :: irl(:)
+  logical :: local_
+  character(len=20)      :: name
+
+  if (psb_errstatus_fatal()) return 
+  info=psb_success_
+  call psb_erractionsave(err_act)
+  name = 'psb_dinsvi'
+
+  if (.not.desc_a%is_ok()) then
+    info = psb_err_invalid_cd_state_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+
+  ictxt = desc_a%get_context()
+
+  call psb_info(ictxt, me, np)
+  if (np == -1) then
+    info = psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  !... check parameters....
+  if (m < 0) then
+    info = psb_err_iarg_neg_
+    int_err(1) = 1
+    int_err(2) = m
+    call psb_errpush(info,name,int_err)
+    goto 9999
+  else if (x%get_nrows() < desc_a%get_local_rows()) then
+    info = 310
+    int_err(1) = 5
+    int_err(2) = 4
+    call psb_errpush(info,name,int_err)
+    goto 9999
+  endif
+
+  if (m == 0) return  
+  loc_rows = desc_a%get_local_rows()
+  loc_cols = desc_a%get_local_cols()
+  mglob    = desc_a%get_global_rows()
+
+  if (.not.allocated(x%v)) then 
+    info = psb_err_invalid_vect_state_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+
+
+  allocate(irl(m),stat=info) 
+  if (info /= psb_success_) then 
+    info = psb_err_alloc_dealloc_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  if (present(dupl)) then 
+    dupl_ = dupl
+  else
+    dupl_ = psb_dupl_ovwrt_
+  endif
+  if (present(local)) then 
+    local_ = local
+  else
+    local_ = .false.
+  endif
+
+  if (local_) then 
+    irl(1:m) = irw(1:m)
+  else
+    call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
+  end if
+  call x%ins(m,irl,val,dupl_,info) 
+  if (info /= 0) then 
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+  deallocate(irl)
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_dins_multivect
+
+

base/tools/psb_ifree.f90

@@ -265,3 +265,58 @@ subroutine psb_ifree_vect_r2(x, desc_a, info)
   return
 
 end subroutine psb_ifree_vect_r2
+
+
+subroutine psb_ifree_multivect(x, desc_a, info)
+  use psb_base_mod, psb_protect_name => psb_ifree_multivect
+  implicit none
+  !....parameters...
+  type(psb_i_multivect_type), intent(inout) :: x
+  type(psb_desc_type), intent(in)  :: desc_a
+  integer(psb_ipk_), intent(out)             :: info 
+  !...locals....
+  integer(psb_ipk_) :: ictxt,np,me,err_act
+  character(len=20)   :: name
+
+
+  info=psb_success_
+  if (psb_errstatus_fatal()) return 
+  call psb_erractionsave(err_act)
+  name='psb_ifree'
+
+  if (.not.desc_a%is_ok()) then
+    info = psb_err_invalid_cd_state_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+  ictxt = desc_a%get_context()
+
+  call psb_info(ictxt, me, np)
+  if (np == -1) then
+    info = psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  if (.not.allocated(x%v)) then 
+    info = psb_err_invalid_vect_state_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+
+  call x%free(info)
+
+  if (info /= psb_no_err_) then
+    info=psb_err_alloc_dealloc_
+    call psb_errpush(info,name)
+  endif
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_ifree_multivect

base/tools/psb_iins.f90

@@ -713,3 +713,119 @@ subroutine psb_iinsi(m, irw, val, x, desc_a, info, dupl,local)
 end subroutine psb_iinsi
 
 
+
+subroutine psb_iins_multivect(m, irw, val, x, desc_a, info, dupl,local)
+  use psb_base_mod, psb_protect_name => psb_iins_multivect
+  use psi_mod
+  implicit none
+
+  ! m rows number of submatrix belonging to val to be inserted
+  ! ix  x global-row corresponding to position at which val submatrix
+  !     must be inserted
+
+  !....parameters...
+  integer(psb_ipk_), intent(in)                  :: m
+  integer(psb_ipk_), intent(in)                  :: irw(:)
+  integer(psb_ipk_), intent(in)        :: val(:,:)
+  type(psb_i_multivect_type), intent(inout) :: x
+  type(psb_desc_type), intent(in)      :: desc_a
+  integer(psb_ipk_), intent(out)                 :: info
+  integer(psb_ipk_), optional, intent(in)        :: dupl
+  logical, intent(in), optional        :: local
+
+  !locals.....
+  integer(psb_ipk_) :: ictxt,i,&
+       & loc_rows,loc_cols,mglob,err_act, int_err(5)
+  integer(psb_ipk_) :: np, me, dupl_
+  integer(psb_ipk_), allocatable   :: irl(:)
+  logical :: local_
+  character(len=20)      :: name
+
+  if (psb_errstatus_fatal()) return 
+  info=psb_success_
+  call psb_erractionsave(err_act)
+  name = 'psb_iinsvi'
+
+  if (.not.desc_a%is_ok()) then
+    info = psb_err_invalid_cd_state_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+
+  ictxt = desc_a%get_context()
+
+  call psb_info(ictxt, me, np)
+  if (np == -1) then
+    info = psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  !... check parameters....
+  if (m < 0) then
+    info = psb_err_iarg_neg_
+    int_err(1) = 1
+    int_err(2) = m
+    call psb_errpush(info,name,int_err)
+    goto 9999
+  else if (x%get_nrows() < desc_a%get_local_rows()) then
+    info = 310
+    int_err(1) = 5
+    int_err(2) = 4
+    call psb_errpush(info,name,int_err)
+    goto 9999
+  endif
+
+  if (m == 0) return  
+  loc_rows = desc_a%get_local_rows()
+  loc_cols = desc_a%get_local_cols()
+  mglob    = desc_a%get_global_rows()
+
+  if (.not.allocated(x%v)) then 
+    info = psb_err_invalid_vect_state_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+
+
+  allocate(irl(m),stat=info) 
+  if (info /= psb_success_) then 
+    info = psb_err_alloc_dealloc_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  if (present(dupl)) then 
+    dupl_ = dupl
+  else
+    dupl_ = psb_dupl_ovwrt_
+  endif
+  if (present(local)) then 
+    local_ = local
+  else
+    local_ = .false.
+  endif
+
+  if (local_) then 
+    irl(1:m) = irw(1:m)
+  else
+    call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
+  end if
+  call x%ins(m,irl,val,dupl_,info) 
+  if (info /= 0) then 
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+  deallocate(irl)
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_iins_multivect
+
+

base/tools/psb_sfree.f90

@@ -265,3 +265,58 @@ subroutine psb_sfree_vect_r2(x, desc_a, info)
   return
 
 end subroutine psb_sfree_vect_r2
+
+
+subroutine psb_sfree_multivect(x, desc_a, info)
+  use psb_base_mod, psb_protect_name => psb_sfree_multivect
+  implicit none
+  !....parameters...
+  type(psb_s_multivect_type), intent(inout) :: x
+  type(psb_desc_type), intent(in)  :: desc_a
+  integer(psb_ipk_), intent(out)             :: info 
+  !...locals....
+  integer(psb_ipk_) :: ictxt,np,me,err_act
+  character(len=20)   :: name
+
+
+  info=psb_success_
+  if (psb_errstatus_fatal()) return 
+  call psb_erractionsave(err_act)
+  name='psb_sfree'
+
+  if (.not.desc_a%is_ok()) then
+    info = psb_err_invalid_cd_state_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+  ictxt = desc_a%get_context()
+
+  call psb_info(ictxt, me, np)
+  if (np == -1) then
+    info = psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  if (.not.allocated(x%v)) then 
+    info = psb_err_invalid_vect_state_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+
+  call x%free(info)
+
+  if (info /= psb_no_err_) then
+    info=psb_err_alloc_dealloc_
+    call psb_errpush(info,name)
+  endif
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_sfree_multivect

base/tools/psb_sins.f90

@@ -713,3 +713,119 @@ subroutine psb_sinsi(m, irw, val, x, desc_a, info, dupl,local)
 end subroutine psb_sinsi
 
 
+
+subroutine psb_sins_multivect(m, irw, val, x, desc_a, info, dupl,local)
+  use psb_base_mod, psb_protect_name => psb_sins_multivect
+  use psi_mod
+  implicit none
+
+  ! m rows number of submatrix belonging to val to be inserted
+  ! ix  x global-row corresponding to position at which val submatrix
+  !     must be inserted
+
+  !....parameters...
+  integer(psb_ipk_), intent(in)                  :: m
+  integer(psb_ipk_), intent(in)                  :: irw(:)
+  real(psb_spk_), intent(in)        :: val(:,:)
+  type(psb_s_multivect_type), intent(inout) :: x
+  type(psb_desc_type), intent(in)      :: desc_a
+  integer(psb_ipk_), intent(out)                 :: info
+  integer(psb_ipk_), optional, intent(in)        :: dupl
+  logical, intent(in), optional        :: local
+
+  !locals.....
+  integer(psb_ipk_) :: ictxt,i,&
+       & loc_rows,loc_cols,mglob,err_act, int_err(5)
+  integer(psb_ipk_) :: np, me, dupl_
+  integer(psb_ipk_), allocatable   :: irl(:)
+  logical :: local_
+  character(len=20)      :: name
+
+  if (psb_errstatus_fatal()) return 
+  info=psb_success_
+  call psb_erractionsave(err_act)
+  name = 'psb_sinsvi'
+
+  if (.not.desc_a%is_ok()) then
+    info = psb_err_invalid_cd_state_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+
+  ictxt = desc_a%get_context()
+
+  call psb_info(ictxt, me, np)
+  if (np == -1) then
+    info = psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  !... check parameters....
+  if (m < 0) then
+    info = psb_err_iarg_neg_
+    int_err(1) = 1
+    int_err(2) = m
+    call psb_errpush(info,name,int_err)
+    goto 9999
+  else if (x%get_nrows() < desc_a%get_local_rows()) then
+    info = 310
+    int_err(1) = 5
+    int_err(2) = 4
+    call psb_errpush(info,name,int_err)
+    goto 9999
+  endif
+
+  if (m == 0) return  
+  loc_rows = desc_a%get_local_rows()
+  loc_cols = desc_a%get_local_cols()
+  mglob    = desc_a%get_global_rows()
+
+  if (.not.allocated(x%v)) then 
+    info = psb_err_invalid_vect_state_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+
+
+  allocate(irl(m),stat=info) 
+  if (info /= psb_success_) then 
+    info = psb_err_alloc_dealloc_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  if (present(dupl)) then 
+    dupl_ = dupl
+  else
+    dupl_ = psb_dupl_ovwrt_
+  endif
+  if (present(local)) then 
+    local_ = local
+  else
+    local_ = .false.
+  endif
+
+  if (local_) then 
+    irl(1:m) = irw(1:m)
+  else
+    call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
+  end if
+  call x%ins(m,irl,val,dupl_,info) 
+  if (info /= 0) then 
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+  deallocate(irl)
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_sins_multivect
+
+

base/tools/psb_zfree.f90

@@ -265,3 +265,58 @@ subroutine psb_zfree_vect_r2(x, desc_a, info)
   return
 
 end subroutine psb_zfree_vect_r2
+
+
+subroutine psb_zfree_multivect(x, desc_a, info)
+  use psb_base_mod, psb_protect_name => psb_zfree_multivect
+  implicit none
+  !....parameters...
+  type(psb_z_multivect_type), intent(inout) :: x
+  type(psb_desc_type), intent(in)  :: desc_a
+  integer(psb_ipk_), intent(out)             :: info 
+  !...locals....
+  integer(psb_ipk_) :: ictxt,np,me,err_act
+  character(len=20)   :: name
+
+
+  info=psb_success_
+  if (psb_errstatus_fatal()) return 
+  call psb_erractionsave(err_act)
+  name='psb_zfree'
+
+  if (.not.desc_a%is_ok()) then
+    info = psb_err_invalid_cd_state_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+  ictxt = desc_a%get_context()
+
+  call psb_info(ictxt, me, np)
+  if (np == -1) then
+    info = psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  if (.not.allocated(x%v)) then 
+    info = psb_err_invalid_vect_state_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+
+  call x%free(info)
+
+  if (info /= psb_no_err_) then
+    info=psb_err_alloc_dealloc_
+    call psb_errpush(info,name)
+  endif
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_zfree_multivect

base/tools/psb_zins.f90

@@ -713,3 +713,119 @@ subroutine psb_zinsi(m, irw, val, x, desc_a, info, dupl,local)
 end subroutine psb_zinsi
 
 
+
+subroutine psb_zins_multivect(m, irw, val, x, desc_a, info, dupl,local)
+  use psb_base_mod, psb_protect_name => psb_zins_multivect
+  use psi_mod
+  implicit none
+
+  ! m rows number of submatrix belonging to val to be inserted
+  ! ix  x global-row corresponding to position at which val submatrix
+  !     must be inserted
+
+  !....parameters...
+  integer(psb_ipk_), intent(in)                  :: m
+  integer(psb_ipk_), intent(in)                  :: irw(:)
+  complex(psb_dpk_), intent(in)        :: val(:,:)
+  type(psb_z_multivect_type), intent(inout) :: x
+  type(psb_desc_type), intent(in)      :: desc_a
+  integer(psb_ipk_), intent(out)                 :: info
+  integer(psb_ipk_), optional, intent(in)        :: dupl
+  logical, intent(in), optional        :: local
+
+  !locals.....
+  integer(psb_ipk_) :: ictxt,i,&
+       & loc_rows,loc_cols,mglob,err_act, int_err(5)
+  integer(psb_ipk_) :: np, me, dupl_
+  integer(psb_ipk_), allocatable   :: irl(:)
+  logical :: local_
+  character(len=20)      :: name
+
+  if (psb_errstatus_fatal()) return 
+  info=psb_success_
+  call psb_erractionsave(err_act)
+  name = 'psb_zinsvi'
+
+  if (.not.desc_a%is_ok()) then
+    info = psb_err_invalid_cd_state_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+
+  ictxt = desc_a%get_context()
+
+  call psb_info(ictxt, me, np)
+  if (np == -1) then
+    info = psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  !... check parameters....
+  if (m < 0) then
+    info = psb_err_iarg_neg_
+    int_err(1) = 1
+    int_err(2) = m
+    call psb_errpush(info,name,int_err)
+    goto 9999
+  else if (x%get_nrows() < desc_a%get_local_rows()) then
+    info = 310
+    int_err(1) = 5
+    int_err(2) = 4
+    call psb_errpush(info,name,int_err)
+    goto 9999
+  endif
+
+  if (m == 0) return  
+  loc_rows = desc_a%get_local_rows()
+  loc_cols = desc_a%get_local_cols()
+  mglob    = desc_a%get_global_rows()
+
+  if (.not.allocated(x%v)) then 
+    info = psb_err_invalid_vect_state_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+
+
+  allocate(irl(m),stat=info) 
+  if (info /= psb_success_) then 
+    info = psb_err_alloc_dealloc_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  if (present(dupl)) then 
+    dupl_ = dupl
+  else
+    dupl_ = psb_dupl_ovwrt_
+  endif
+  if (present(local)) then 
+    local_ = local
+  else
+    local_ = .false.
+  endif
+
+  if (local_) then 
+    irl(1:m) = irw(1:m)
+  else
+    call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
+  end if
+  call x%ins(m,irl,val,dupl_,info) 
+  if (info /= 0) then 
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+  deallocate(irl)
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ictxt,err_act)
+
+  return
+
+end subroutine psb_zins_multivect
+
+