psblas3:

base/internals/psb_indx_map_fnd_owner.F90
 base/modules/psb_base_tools_mod.f90
 base/modules/psb_desc_const_mod.f90
 base/modules/psb_indx_map_mod.f90
 base/tools/psb_cd_inloc.f90
 base/tools/psb_cdall.f90
 base/tools/psb_cdals.f90
 base/tools/psb_cdalv.f90
 base/tools/psb_cdcpy.F90
 base/tools/psb_icdasb.F90
 util/psb_mat_dist_impl.f90

Added tempvg and parts components in indxmap. 
Revised declaration of PARTS subroutine.

base/internals/psb_indx_map_fnd_owner.F90

@@ -70,7 +70,7 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
        & sdsz(:),sdidx(:), rvsz(:), rvidx(:),answers(:,:),idxsrch(:,:)
 
   integer(psb_ipk_) :: i,n_row,n_col,err_act,ih,icomm,hsize,ip,isz,k,j,&
-       & last_ih, last_j, nv
+       & last_ih, last_j, nv, mglob, nresp
   integer(psb_ipk_) :: ictxt,np,me
   logical, parameter  :: gettime=.false.
   real(psb_dpk_)      :: t0, t1, t2, t3, t4, tamx, tidx
@@ -82,6 +82,7 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
 
   ictxt   = idxmap%get_ctxt()
   icomm   = idxmap%get_mpic()
+  mglob   = idxmap%get_gr()
   n_row   = idxmap%get_lr()
   n_col   = idxmap%get_lc()
 
@@ -104,6 +105,38 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
   end if
 
   nv = size(idx)
+  call psb_realloc(nv,iprc,info)
+  if (info /= psb_success_) then 
+    call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_realloc')
+    goto 9999      
+  end if
+
+  if (associated(idxmap%parts)) then 
+    ! Use function shortcut
+!!$    write(0,*) me,trim(name),' indxmap%parts shortcut'
+    Allocate(hidx(np), stat=info)
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') 
+      goto 9999      
+    end if
+    do i=1, nv
+      call idxmap%parts(idx(i),mglob,np,hidx,nresp)
+      if (nresp > 0) then
+        iprc(i) = hidx(1)
+      else
+        iprc(i) = -1 
+      end if
+    end do
+
+  else if (allocated(idxmap%tempvg)) then 
+!!$    write(0,*) me,trim(name),' indxmap%tempvg shortcut'
+    ! Use temporary vector 
+    do i=1, nv 
+      iprc(i) = idxmap%tempvg(idx(i))
+    end do
+
+  else
+
     !
     ! The basic idea is very simple. 
     ! First we collect (to all) all the requests. 
@@ -213,11 +246,6 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
     call psb_msort(idxsrch(1:nv,1),ix=idxsrch(1:nv,2))
 
     ! Now  extract the answers for our local query
-  call psb_realloc(nv,iprc,info)
-  if (info /= psb_success_) then 
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_realloc')
-    goto 9999      
-  end if
     last_ih = -1 
     last_j  = -1
     j = 1
@@ -267,6 +295,7 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
         end do
       end if
     end do
+  end if
 
   if (gettime) then 
     call psb_barrier(ictxt)

base/modules/psb_base_tools_mod.f90

@@ -423,9 +423,9 @@ module psb_cd_tools_mod
   interface psb_cdall
 
     subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalcheck)
-      import :: psb_ipk_, psb_desc_type
+      import :: psb_ipk_, psb_desc_type, psb_parts
       implicit None
-      include 'parts.fh'
+      procedure(psb_parts)                :: parts
       integer(psb_ipk_), intent(in)       :: mg,ng,ictxt, vg(:), vl(:),nl
       integer(psb_ipk_), intent(in)       :: flag
       logical, intent(in)                 :: repl, globalcheck

base/modules/psb_desc_const_mod.f90

@@ -119,4 +119,12 @@ module psb_desc_const_mod
   integer(psb_ipk_), parameter :: psb_ovrlp_elem_to_=2, psb_ovrlp_elem_=0
   integer(psb_ipk_), parameter :: psb_n_dom_ovr_=1
 
+  interface 
+    subroutine psb_parts(glob_index,nrow,np,pv,nv)
+      import :: psb_ipk_
+      integer(psb_ipk_), intent (in)  :: glob_index,np,nrow
+      integer(psb_ipk_), intent (out) :: nv, pv(*)
+    end subroutine psb_parts
+  end interface
+  
 end module psb_desc_const_mod

base/modules/psb_indx_map_mod.f90

@@ -96,6 +96,10 @@ module psb_indx_map_mod
     integer(psb_ipk_) :: local_rows     = -1
     integer(psb_ipk_) :: local_cols     = -1
     
+    procedure(psb_parts), nopass, pointer  :: parts => null()
+    integer(psb_ipk_), allocatable :: tempvg(:)
+    integer(psb_ipk_), allocatable :: oracle(:,:)
+    
   contains
 
     procedure, pass(idxmap)  :: get_state => base_get_state

base/tools/psb_cd_inloc.f90

@@ -289,7 +289,6 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck)
        & stat=info)
   if (info == psb_success_) then 
     desc%lprm(1)        = 0   
-!!$    desc%matrix_data(:) = 0
   end if
   if (info /= psb_success_) then     
     info=psb_err_alloc_request_
@@ -299,11 +298,6 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck)
   endif
 
   temp_ovrlap(:) = -1
-!!$  desc%matrix_data(psb_m_)        = m
-!!$  desc%matrix_data(psb_n_)        = n
-!!$  ! This has to be set BEFORE any call to SET_BLD
-!!$  desc%matrix_data(psb_ctxt_)     = ictxt
-!!$  call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_))
 
 
   if (debug_level >= psb_debug_ext_) &
@@ -371,31 +365,6 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck)
     goto 9999
   endif
 
-!!$  ! set fields in desc%MATRIX_DATA....
-!!$  desc%matrix_data(psb_n_row_)  = loc_row
-!!$  desc%matrix_data(psb_n_col_)  = loc_row
-
-!!$  call psb_realloc(max(1,loc_row/2),desc%halo_index, info)
-!!$  if (info == psb_success_) call psb_realloc(1,desc%ext_index, info)
-!!$  if (info /= psb_success_) then
-!!$    info=psb_err_from_subroutine_
-!!$    call psb_errpush(info,name,a_err='psb_realloc')
-!!$    Goto 9999
-!!$  end if
-!!$  desc%matrix_data(psb_pnt_h_) = 1
-!!$  desc%halo_index(:)           = -1
-!!$  desc%ext_index(:)            = -1
-!!$
-!!$  if (debug_level >= psb_debug_ext_) &
-!!$       & write(debug_unit,*) me,' ',trim(name),': end'
-!!$
-!!$  call psb_cd_set_bld(desc,info)
-!!$  if (info /= psb_success_) then
-!!$    info=psb_err_from_subroutine_
-!!$    call psb_errpush(info,name,a_err='psb_cd_set_bld')
-!!$    Goto 9999
-!!$  end if
-
   call psb_erractionrestore(err_act)
   return
 

base/tools/psb_cdall.f90

@@ -7,7 +7,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche
   use psb_base_tools_mod, psb_protect_name => psb_cdall
   use psi_mod
   implicit None
-  include 'parts.fh'
+  procedure(psb_parts)               :: parts
   integer(psb_ipk_), intent(in)               :: mg,ng,ictxt, vg(:), vl(:),nl
   integer(psb_ipk_), intent(in)               :: flag
   logical, intent(in)               :: repl, globalcheck
@@ -19,7 +19,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche
   interface 
     subroutine psb_cdals(m, n, parts, ictxt, desc, info)
       use psb_descriptor_type
-      include 'parts.fh'
+      procedure(psb_parts)               :: parts
       integer(psb_ipk_), intent(in)                 :: m,n,ictxt
       Type(psb_desc_type), intent(out)    :: desc
       integer(psb_ipk_), intent(out)                :: info
@@ -168,12 +168,9 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche
     call psb_errpush(info,name,a_err='psb_realloc')
     Goto 999
   end if
-!!$  desc%matrix_data(psb_pnt_h_) = 1
   desc%halo_index(:)           = -1
   desc%ext_index(:)            = -1
   call psb_cd_set_bld(desc,info)
-!!$  desc%matrix_data(psb_n_row_) = desc%indxmap%get_lr()
-!!$  desc%matrix_data(psb_n_col_) = desc%indxmap%get_lc()
   if (info /= psb_success_) goto 999
 
   call psb_erractionrestore(err_act)

base/tools/psb_cdals.f90

@@ -50,7 +50,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
   use psb_list_map_mod
   use psb_hash_map_mod
   implicit None
-  include 'parts.fh'
+  procedure(psb_parts)               :: parts
   !....Parameters...
   integer(psb_ipk_), intent(in)                 :: M,N,ictxt
   Type(psb_desc_type), intent(out)    :: desc
@@ -125,9 +125,6 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
   ! count local rows number
   loc_row = max(1,(m+np-1)/np) 
   ! allocate work vector
-!!$  allocate(desc%matrix_data(psb_mdata_size_),&
-!!$       & temp_ovrlap(max(1,2*loc_row)), prc_v(np),stat=info)
-!!$  desc%matrix_data(:) = 0
   allocate(temp_ovrlap(max(1,2*loc_row)), prc_v(np),stat=info)
 
   if (info /= psb_success_) then     
@@ -137,12 +134,6 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
     call psb_errpush(err,name,int_err,a_err='integer')
     goto 9999
   endif
-!!$  desc%matrix_data(psb_m_)        = m
-!!$  desc%matrix_data(psb_n_)        = n
-!!$  ! This has to be set BEFORE any call to SET_BLD
-!!$  desc%matrix_data(psb_ctxt_)     = ictxt
-!!$  call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_))
-
 
   if (debug_level >= psb_debug_ext_) &
        & write(debug_unit,*) me,' ',trim(name),':  starting main loop' ,info
@@ -171,6 +162,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
       allocate(psb_repl_map :: desc%indxmap, stat=info)
     else
       allocate(psb_hash_map :: desc%indxmap, stat=info)
+      desc%indxmap%parts => parts
     end if
   end if
 
@@ -289,15 +281,6 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
     Goto 9999
   endif
 
-!!$  ! set fields in desc%MATRIX_DATA....
-!!$  desc%matrix_data(psb_n_row_)  = loc_row
-!!$  desc%matrix_data(psb_n_col_)  = loc_row
-
-!!$  write(0,*) me,'CDALS: after init ', &
-!!$       & desc%indxmap%get_gr(), &
-!!$       & desc%indxmap%get_gc(), &
-!!$       & desc%indxmap%get_lr(), &
-!!$       & desc%indxmap%get_lc() 
 
   if (debug_level >= psb_debug_ext_) &
        & write(debug_unit,*) me,' ',trim(name),': end'

base/tools/psb_cdalv.f90

@@ -144,11 +144,6 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag)
     call psb_errpush(info,name,i_err=int_err,a_err='integer')
     goto 9999
   endif
-!!$  desc%matrix_data(psb_m_)        = m
-!!$  desc%matrix_data(psb_n_)        = n
-!!$  ! This has to be set BEFORE any call to SET_BLD
-!!$  desc%matrix_data(psb_ctxt_)     = ictxt
-!!$  call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_))
 
   if (debug_level >= psb_debug_ext_) &
        & write(debug_unit,*) me,' ',trim(name),':  starting main loop' ,info
@@ -181,6 +176,8 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag)
   else
     if (psb_cd_choose_large_state(ictxt,m)) then 
       allocate(psb_hash_map :: desc%indxmap, stat=info)
+      if (info == 0) allocate(desc%indxmap%tempvg(m),stat=info)
+      if (info ==0) desc%indxmap%tempvg(1:m) = v(1:m) - flag_
     else 
       allocate(psb_glist_map :: desc%indxmap, stat=info)
     end if
@@ -211,10 +208,6 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag)
     goto 9999
   endif
 
-!!$  ! set fields in desc%MATRIX_DATA....
-!!$  desc%matrix_data(psb_n_row_)  = loc_row
-!!$  desc%matrix_data(psb_n_col_)  = loc_row
-!!$
   if (debug_level >= psb_debug_ext_) &
        & write(debug_unit,*) me,' ',trim(name),': end'
 

base/tools/psb_cdcpy.F90

@@ -86,12 +86,6 @@ subroutine psb_cdcpy(desc_in, desc_out, info)
 
   if (allocated(desc_in%indxmap)) then 
 
-!!$    if (allocated(desc_out%indxmap)) then 
-!!$      ! This should never happen
-!!$      call desc_out%indxmap%free()
-!!$      deallocate(desc_out%indxmap)
-!!$    end if
-!!$    write(debug_unit,*) me,' ',trim(name),': Calling allocate(SOURCE = )'
 #ifdef SOURCE_WORKAROUND
     call desc_in%indxmap%clone(desc_out%indxmap,info)
 #else 

base/tools/psb_icdasb.F90

@@ -36,13 +36,13 @@
 !   The user callable routine is defined in the psb_tools_mod module.
 ! 
 ! Arguments: 
-!    desc_a  - type(psb_desc_type).    The communication descriptor.
+!    desc  - type(psb_desc_type).    The communication descriptor.
 !    info    - integer.                return code.
 !    ext_hv  - logical                 Essentially this distinguishes a call 
 !                                      coming from the build of an extended
 !                                      halo descriptor with respect to a normal call. 
 !
-subroutine psb_icdasb(desc_a,info,ext_hv)
+subroutine psb_icdasb(desc,info,ext_hv)
   use psb_base_mod, psb_protect_name => psb_icdasb
   use psi_mod
 #ifdef MPI_MOD
@@ -53,7 +53,7 @@ subroutine psb_icdasb(desc_a,info,ext_hv)
   include 'mpif.h'
 #endif
   !...Parameters....
-  type(psb_desc_type), intent(inout) :: desc_a
+  type(psb_desc_type), intent(inout) :: desc
   integer(psb_ipk_), intent(out)               :: info
   logical, intent(in), optional      :: ext_hv
 
@@ -75,10 +75,10 @@ subroutine psb_icdasb(desc_a,info,ext_hv)
   debug_unit  = psb_get_debug_unit()
   debug_level = psb_get_debug_level()
 
-  ictxt   = desc_a%get_context()
-  dectype = desc_a%get_dectype()
-  n_row   = desc_a%get_local_rows()
-  n_col   = desc_a%get_local_cols()
+  ictxt   = desc%get_context()
+  dectype = desc%get_dectype()
+  n_row   = desc%get_local_rows()
+  n_col   = desc%get_local_cols()
   call psb_get_mpicomm(ictxt,icomm )
 
   ! check on blacs grid 
@@ -89,7 +89,7 @@ subroutine psb_icdasb(desc_a,info,ext_hv)
     goto 9999
   endif
 
-  if (.not.psb_is_ok_desc(desc_a)) then 
+  if (.not.psb_is_ok_desc(desc)) then 
     info = psb_err_spmat_invalid_state_
     int_err(1) = dectype
     call psb_errpush(info,name)
@@ -113,22 +113,22 @@ subroutine psb_icdasb(desc_a,info,ext_hv)
   if (debug_level >= psb_debug_ext_) &
        & write(debug_unit, *) me,' ',trim(name),': start'
 
-  if (allocated(desc_a%indxmap)) then 
-    call psi_ldsc_pre_halo(desc_a,ext_hv_,info)
+  if (allocated(desc%indxmap)) then 
+    call psi_ldsc_pre_halo(desc,ext_hv_,info)
     if (info /= psb_success_) then
       call psb_errpush(psb_err_from_subroutine_,name,a_err='ldsc_pre_halo')
       goto 9999
     end if
 
     ! Take out the lists for ovrlap, halo and ext...
-    call psb_move_alloc(desc_a%ovrlap_index,ovrlap_index,info)
-    call psb_move_alloc(desc_a%halo_index,halo_index,info)
-    call psb_move_alloc(desc_a%ext_index,ext_index,info)
+    call psb_move_alloc(desc%ovrlap_index,ovrlap_index,info)
+    call psb_move_alloc(desc%halo_index,halo_index,info)
+    call psb_move_alloc(desc%ext_index,ext_index,info)
 
     if (debug_level >= psb_debug_ext_) &
          & write(debug_unit,*) me,' ',trim(name),': Final conversion'
     ! Then convert and put them back where they belong.    
-    call psi_cnv_dsc(halo_index,ovrlap_index,ext_index,desc_a,info) 
+    call psi_cnv_dsc(halo_index,ovrlap_index,ext_index,desc,info) 
 
     if (info /= psb_success_) then
       call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_cnv_dsc')
@@ -142,17 +142,16 @@ subroutine psb_icdasb(desc_a,info,ext_hv)
       goto 9999
     end if
 
-    call desc_a%indxmap%asb(info)
+    call desc%indxmap%asb(info)
+    if (info == psb_success_) then 
+      if (allocated(desc%indxmap%tempvg)) &
+           & deallocate(desc%indxmap%tempvg,stat=info)
+    end if
     if (info /= psb_success_) then 
       write(0,*) 'Error from internal indxmap asb ',info
       info = psb_success_
     end if
 
-!!$    desc_a%matrix_data(psb_n_row_) = desc_a%indxmap%get_lr()    
-!!$    desc_a%matrix_data(psb_n_col_) = desc_a%indxmap%get_lc()
-!!$    ! Ok, register into MATRIX_DATA 
-!!$    desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_
-
   else
     info = psb_err_spmat_invalid_state_
     call psb_errpush(info,name)