Created new internal to set bld status of descriptor.

Fixed glob_to_loc actions (and their description).

docs/pdf/toolsrout.tex

@@ -777,8 +777,8 @@ Specified as: Integer scalar.\\
 %
 \subroutine{psb\_glob\_to\_loc}{Global to local indices convertion}
 
-\syntax{call psb\_glob\_to\_loc}{x, y, desc\_a, info, iact}
+\syntax{call psb\_glob\_to\_loc}{x, y, desc\_a, info, iact,owned}
-\syntax*{call psb\_glob\_to\_loc}{x, desc\_a, info, iact}
+\syntax*{call psb\_glob\_to\_loc}{x, desc\_a, info, iact,owned}
 
 \begin{description}
 \item[\bf On Entry]
@@ -793,7 +793,14 @@ Specified as: a structured data of type \descdata.
 \item[iact] specifies action to be taken in case of range errors. 
 Scope: {\bf global} \\
 Type: {\bf optional}\\
-Specified as: a character variable  \verb|E|, \verb|W| or \verb|A|. 
+Specified as: a character variable  \verb|I|gnore, \verb|W|arning or
+\verb|A|bort, default \verb|I|gnore.
+\item[owned] Specfies valid range of input 
+Scope: {\bf global} \\
+Type: {\bf optional}\\
+If true, then only indices strictly owned by the current process are
+considered valid, if false then halo indices are also
+accepted. Default: false. 
 \end{description}
 
 \begin{description}
@@ -803,7 +810,7 @@ Specified as: a character variable  \verb|E|, \verb|W| or \verb|A|.
 Scope: {\bf global} \\
 Type: {\bf required}\\
 Specified as: a rank one integer array.
-\item[y] If $y$ is not present,
+\item[y] If $y$ is  present,
   then $y$ is overwritten with the translated integer indices, and $x$
   is left unchanged. 
 Scope: {\bf global} \\
@@ -815,6 +822,13 @@ Type: {\bf required}\\
 Specified as: an integer variable.
 \end{description}
 
+\section*{Notes}
+\begin{enumerate}
+\item If an input index is out of range, then the corresponding output
+  index is set to a negative number;
+\item The default \verb|I|gnore means that the negative output is the
+  only action taken on an out-of-range input.
+\end{enumerate}
 
 
 %

src/modules/Makefile

@@ -21,7 +21,7 @@ psb_spmat_type.o : psb_realloc_mod.o psb_const_mod.o psb_string_mod.o
 psb_error_mod.o: psb_const_mod.o
 psb_penv_mod.o: psb_const_mod.o psb_error_mod.o
 psi_mod.o: psb_penv_mod.o psb_error_mod.o psb_desc_type.o
-psb_desc_type.o: psb_const_mod.o
+psb_desc_type.o: psb_const_mod.o psb_error_mod.o psb_penv_mod.o
 psb_check_mod.o: psb_desc_type.o
 psb_methd_mod.o: psb_serial_mod.o psb_desc_type.o psb_prec_type.o
 psb_tools_mod.o: psb_spmat_type.o psb_desc_type.o psi_mod.o 

src/modules/psb_desc_type.f90

@@ -227,5 +227,64 @@ contains
 
   end function psb_is_large_dec
 
+  subroutine psb_cd_set_bld(desc,info)
+    use psb_const_mod
+    use psb_error_mod
+    use psb_penv_mod
+
+    implicit none
+    type(psb_desc_type), intent(inout) :: desc
+    integer                            :: info
+    !locals
+    integer             :: np,me,ictxt, isz, err_act,idx,gidx,lidx
+    logical, parameter  :: debug=.false.,debugprt=.false.
+    character(len=20)   :: name, char_err
+    if (debug) write(0,*) me,'Entered CDCPY'
+    if (psb_get_errstatus() /= 0) return 
+    info = 0
+    call psb_erractionsave(err_act)
+    name = 'psb_cdcpy'
+
+    ictxt = psb_cd_get_context(desc)
+
+    ! check on blacs grid 
+    call psb_info(ictxt, me, np)
+    if (debug) write(0,*) me,'Entered CDCPY'
+
+    if (psb_is_large_desc(desc)) then 
+      if (.not.allocated(desc%ptree)) then 
+        allocate(desc%ptree(2),stat=info)
+        if (info /= 0) then 
+          info=4000
+          goto 9999
+        endif
+        call InitPairSearchTree(desc%ptree,info)
+        do idx=1, psb_cd_get_local_cols(desc)
+          gidx = desc%loc_to_glob(idx)
+          call SearchInsKeyVal(desc%ptree,gidx,idx,lidx,info)        
+          if (lidx /= idx) then 
+            write(0,*) 'Warning from cdset: mismatch in PTREE ',idx,lidx
+          endif
+        enddo
+      end if
+      desc%matrix_data(psb_dec_type_) = psb_desc_large_bld_ 
+
+    else
+      desc%matrix_data(psb_dec_type_) = psb_desc_bld_ 
+    end if
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 continue
+    call psb_erractionrestore(err_act)
+
+    if (err_act == act_ret) then
+      return
+    else
+      call psb_error(ictxt)
+    end if
+    return
+  end subroutine psb_cd_set_bld
     
 end module psb_descriptor_type

src/modules/psb_error_mod.f90

@@ -351,6 +351,8 @@ contains
       write (0,'("indices in input array are not within problem dimension ",2(i0,2x))')i_e_d(1:2)
     case(150)
       write (0,'("indices in input array are not belonging to the calling process ",i0)')i_e_d(1)
+    case(151)
+      write (0,'("indices in input array are not belonging to the calling process ")')
     case(290)
       write (0,'("To call this routine you must first call psb_geall on the same matrix")')
     case(295)

src/modules/psb_tools_mod.f90

@@ -557,20 +557,22 @@ Module psb_tools_mod
 
 
   interface psb_glob_to_loc
-     subroutine psb_glob_to_loc2(x,y,desc_a,info,iact)
+     subroutine psb_glob_to_loc2(x,y,desc_a,info,iact,owned)
        use psb_descriptor_type
        type(psb_desc_type), intent(in) ::  desc_a
        integer,intent(in)              ::  x(:)  
        integer,intent(out)             ::  y(:)  
        integer, intent(out)            ::  info
        character, intent(in), optional ::  iact
+       logical, intent(in), optional   :: owned
      end subroutine psb_glob_to_loc2
-     subroutine psb_glob_to_loc(x,desc_a,info,iact)
+     subroutine psb_glob_to_loc(x,desc_a,info,iact,owned)
        use psb_descriptor_type
        type(psb_desc_type), intent(in) ::  desc_a
        integer,intent(inout)           ::  x(:)  
        integer, intent(out)            ::  info
        character, intent(in), optional ::  iact
+       logical, intent(in), optional   :: owned
      end subroutine psb_glob_to_loc
   end interface
 

src/tools/psb_cdall.f90

@@ -387,6 +387,7 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info)
   ! set fields in desc_a%MATRIX_DATA....
   desc_a%matrix_data(psb_n_row_)  = loc_row
   desc_a%matrix_data(psb_n_col_)  = loc_row
+  call psb_cd_set_bld(desc_a,info)
 
   call psb_realloc(1,desc_a%halo_index, info)
   if (info /= no_err) then

src/tools/psb_cdasb.f90

@@ -130,6 +130,16 @@ subroutine psb_cdasb(desc_a,info)
     end if
 
     if (psb_is_large_dec(dectype) ) then 
+      if (allocated(desc_a%ptree)) then 
+        call FreePairSearchTree(desc_a%ptree)   
+        deallocate(desc_a%ptree,stat=info)
+        if (info /= 0) then 
+          info=2059
+          call psb_errpush(info,name)
+          goto 9999
+        end if
+      end if
+      
       desc_a%matrix_data(psb_dec_type_) = psb_desc_large_asb_
 !!$      write(0,*) 'Done large dec asmbly',desc_a%matrix_data(psb_dec_type_),&
 !!$           & psb_desc_large_asb_,psb_is_asb_dec(desc_a%matrix_data(psb_dec_type_))

src/tools/psb_dcdovr.f90

@@ -157,36 +157,13 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info)
   l_tmp_ovr_idx = novr*(3*Max(2*index_dim,1)+1)
   l_tmp_halo    = novr*(3*Size(desc_a%halo_index))
 
-  if (psb_is_large_desc(desc_a)) then
+  call psb_cd_set_bld(desc_ov,info)
-    desc_ov%matrix_data(psb_dec_type_) = psb_desc_large_bld_ 
-  else
-    desc_ov%matrix_data(psb_dec_type_) = psb_desc_bld_ 
-  end if
-  If(debug) then
-    Write(0,*)'Start cdovrbld',me,lworks,lworkr
-    call psb_barrier(ictxt)
-  endif
-
-  if (.false.) then 
-    !
-    ! The real work goes on in here....
-    !
-    Call psb_cdovrbld(novr,desc_ov,desc_a,a,&
-         & l_tmp_halo,l_tmp_ovr_idx,lworks,lworkr,info) 
-
-    if (info /= 0) then
-      info=4010
-      ch_err='psb_cdovrbld'
-      call psb_errpush(info,name,a_err=ch_err)
-      goto 9999
-    end if
 
   If(debug) then
-      Write(0,*)'Done cdovrbld',me,lworks,lworkr
+    Write(0,*)'Start cdovrbld',me,lworks,lworkr
     call psb_barrier(ictxt)
   endif
 
-  else
 
 
   Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info)
@@ -358,6 +335,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info)
         tmp_ovr_idx(counter_o+2)=gidx
         tmp_ovr_idx(counter_o+3)=-1
         counter_o=counter_o+3
+
         if (.not.psb_is_large_desc(desc_ov)) then 
           call psb_check_size((counter_h+3),tmp_halo,info,pad=-1)
           if (info /= 0) then
@@ -694,7 +672,6 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info)
     goto 9999
   end if
 
-  end if
 
   call psb_erractionrestore(err_act)
   return

src/tools/psb_glob_to_loc.f90

@@ -40,7 +40,7 @@
 !    info     - integer.                  Eventually returns an error code.
 !    iact     - integer(optional).        A character defining the behaviour of this subroutine when is found an index not belonging to the calling process
 !
-subroutine psb_glob_to_loc2(x,y,desc_a,info,iact)
+subroutine psb_glob_to_loc2(x,y,desc_a,info,iact,owned)
 
   use psb_descriptor_type
   use psb_const_mod
@@ -55,6 +55,7 @@ subroutine psb_glob_to_loc2(x,y,desc_a,info,iact)
   integer, intent(in)             :: x(:)  
   integer, intent(out)            :: y(:), info
   character, intent(in), optional :: iact
+  logical, intent(in), optional   :: owned
 
   !....locals....
   integer                         :: n, i, tmp
@@ -62,40 +63,51 @@ subroutine psb_glob_to_loc2(x,y,desc_a,info,iact)
   integer                         :: int_err(5), err_act
   real(kind(1.d0))                :: real_val
   integer, parameter              :: zero=0
+  logical                         :: owned_
   character(len=20)   :: name
+  integer             :: ictxt, iam, np
 
   if(psb_get_errstatus() /= 0) return 
   info=0
   name = 'glob_to_loc'
+  ictxt = psb_cd_get_context(desc_a)
+  call psb_info(ictxt,iam,np)
   call psb_erractionsave(err_act)
 
   if (present(iact)) then
     act=iact
   else
-    act='A'
+    act='I'
   endif
   act = toupper(act)
+  if (present(owned)) then 
+    owned_ = owned
+  else
+    owned_ = .false.
+  end if
 
   int_err=0
   real_val = 0.d0
 
   n = size(x)
-  call psi_idx_cnv(n,x,y,desc_a,info)
+  call psi_idx_cnv(n,x,y,desc_a,info,owned=owned_)
 
   select case(act)
-  case('E','I')
+  case('I')
-    call psb_erractionrestore(err_act)
-    return
   case('W')
-    if ((info /= 0).or.(count(y(1:n)<0) >0)) then
+    if (count(y(1:n)<0) >0) then
-      write(0,'("Error ",i5," in subroutine glob_to_loc")') info
+      write(0,'("Out of bounds input  in subroutine glob_to_loc")') 
     end if
-  case('A')
+    
-    if ((info /= 0).or.(count(y(1:n)<0) >0)) then
+  case('E','A')
+    if (count(y(1:n)<0) >0) then
+      info = 151
+    end if
+  end select
+  if (info /= 0) then 
     call psb_errpush(info,name)
     goto 9999
   end if
-  end select
   
   call psb_erractionrestore(err_act)
   return
@@ -153,7 +165,7 @@ end subroutine psb_glob_to_loc2
 !    info     - integer.                  Eventually returns an error code.
 !    iact     - integer(optional).        A character defining the behaviour of this subroutine when is found an index not belonging to the calling process
 !
-subroutine psb_glob_to_loc(x,desc_a,info,iact)
+subroutine psb_glob_to_loc(x,desc_a,info,iact,owned)
 
   use psb_penv_mod
   use psb_descriptor_type
@@ -168,50 +180,57 @@ subroutine psb_glob_to_loc(x,desc_a,info,iact)
   integer, intent(inout)           :: x(:)  
   integer, intent(out)             :: info
   character, intent(in), optional  :: iact
+  logical, intent(in), optional   :: owned
 
   !....locals....
   integer                          :: n, i, tmp, nk, key, idx, ih, nh, lb, ub, lm
   character                        :: act
-  integer                          :: int_err(5), err_act, dectype
+  integer                          :: int_err(5), err_act
   real(kind(1.d0))                 :: real_val, t0, t1,t2
   integer, parameter               :: zero=0
+  logical                         :: owned_
   character(len=20)   :: name
   integer             :: ictxt, iam, np
 
   if(psb_get_errstatus() /= 0) return 
   info=0
   name = 'glob_to_loc'
-  ictxt = desc_a%matrix_data(psb_ctxt_)
+  ictxt = psb_cd_get_context(desc_a)
   call psb_info(ictxt,iam,np)
   call psb_erractionsave(err_act)
 
-  dectype  = desc_a%matrix_data(psb_dec_type_)
   if (present(iact)) then
     act=iact
   else
-    act='A'
+    act='I'
   endif
 
   act = toupper(act)
+  if (present(owned)) then 
+    owned_ = owned
+  else
+    owned_ = .false.
+  end if
 
   n = size(x)
-  call psi_idx_cnv(n,x,desc_a,info)
+  call psi_idx_cnv(n,x,desc_a,info,owned=owned_)
 
   select case(act)
-  case('E','I')
+  case('I')
-    call psb_erractionrestore(err_act)
-    return
   case('W')
-    if ((info /= 0).or.(count(x(1:n)<0) >0)) then
+    if (count(x(1:n)<0) >0) then
-      write(0,'("Error ",i5," in subroutine glob_to_loc")') info
+      write(0,'("Out of bounds input  in subroutine glob_to_loc")') 
+    end if
+    
+  case('E','A')
+    if (count(x(1:n)<0) >0) then
+      info = 151
     end if
-  case('A')
+  end select
-    if ((info /= 0).or.(count(x(1:n)<0) >0)) then
+  if (info /= 0) then 
-      write(0,*) count(x(1:n)<0)
     call psb_errpush(info,name)
     goto 9999
   end if
-  end select
  
   call psb_erractionrestore(err_act)
   return
@@ -226,69 +245,69 @@ subroutine psb_glob_to_loc(x,desc_a,info,iact)
   end if
   return
 
-contains 
+!!$contains 
-
+!!$
-  subroutine inlbsrch(ipos,key,n,v)
+!!$  subroutine inlbsrch(ipos,key,n,v)
-    implicit none
+!!$    implicit none
-    integer ipos, key, n
+!!$    integer ipos, key, n
-    integer v(n)
+!!$    integer v(n)
-
+!!$
-    integer lb, ub, m
+!!$    integer lb, ub, m
-
+!!$
-
+!!$
-    lb = 1 
+!!$    lb = 1 
-    ub = n
+!!$    ub = n
-    ipos = -1 
+!!$    ipos = -1 
-
+!!$
-    do 
+!!$    do 
-      if (lb > ub) return
+!!$      if (lb > ub) return
-      m = (lb+ub)/2
+!!$      m = (lb+ub)/2
-      if (key.eq.v(m))  then
+!!$      if (key.eq.v(m))  then
-        ipos = m 
+!!$        ipos = m 
-        return
+!!$        return
-      else if (key.lt.v(m))  then
+!!$      else if (key.lt.v(m))  then
-        ub = m-1
+!!$        ub = m-1
-      else 
+!!$      else 
-        lb = m + 1
+!!$        lb = m + 1
-      end if
+!!$      end if
-    enddo
+!!$    enddo
-    return
+!!$    return
-  end subroutine inlbsrch
+!!$  end subroutine inlbsrch
-
+!!$
-  subroutine inner_cnv(n,x,hashsize,hashmask,hashv,glb_lc)
+!!$  subroutine inner_cnv(n,x,hashsize,hashmask,hashv,glb_lc)
-    integer :: n, hashsize,hashmask,x(:), hashv(0:),glb_lc(:,:)
+!!$    integer :: n, hashsize,hashmask,x(:), hashv(0:),glb_lc(:,:)
-    integer :: i, ih, key, idx,nh,tmp,lb,ub,lm
+!!$    integer :: i, ih, key, idx,nh,tmp,lb,ub,lm
-    do i=1, n
+!!$    do i=1, n
-      key = x(i) 
+!!$      key = x(i) 
-      ih  = iand(key,hashmask)
+!!$      ih  = iand(key,hashmask)
-      idx = hashv(ih)
+!!$      idx = hashv(ih)
-      nh  = hashv(ih+1) - hashv(ih) 
+!!$      nh  = hashv(ih+1) - hashv(ih) 
-      if (nh > 0) then 
+!!$      if (nh > 0) then 
-        tmp = -1 
+!!$        tmp = -1 
-        lb = idx
+!!$        lb = idx
-        ub = idx+nh-1
+!!$        ub = idx+nh-1
-        do 
+!!$        do 
-          if (lb>ub) exit
+!!$          if (lb>ub) exit
-          lm = (lb+ub)/2
+!!$          lm = (lb+ub)/2
-          if (key==glb_lc(lm,1)) then 
+!!$          if (key==glb_lc(lm,1)) then 
-            tmp = lm
+!!$            tmp = lm
-            exit
+!!$            exit
-          else if (key<glb_lc(lm,1)) then 
+!!$          else if (key<glb_lc(lm,1)) then 
-            ub = lm - 1
+!!$            ub = lm - 1
-          else
+!!$          else
-            lb = lm + 1
+!!$            lb = lm + 1
-          end if
+!!$          end if
-        end do
+!!$        end do
-      else 
+!!$      else 
-        tmp = -1
+!!$        tmp = -1
-      end if
+!!$      end if
-      if (tmp > 0) then 
+!!$      if (tmp > 0) then 
-        x(i) = glb_lc(tmp,2)
+!!$        x(i) = glb_lc(tmp,2)
-      else         
+!!$      else         
-        x(i) = tmp 
+!!$        x(i) = tmp 
-      end if
+!!$      end if
-    end do
+!!$    end do
-  end subroutine inner_cnv
+!!$  end subroutine inner_cnv
 
 end subroutine psb_glob_to_loc
 

src/tools/psb_loc_to_glob.f90

@@ -100,12 +100,12 @@ subroutine psb_loc_to_glob2(x,y,desc_a,info,iact)
 
   if (info /= 0) then
     select case(act)
-    case('E')
+    case('I')
       call psb_erractionrestore(err_act)
       return
     case('W')
       write(0,'("Error ",i5," in subroutine glob_to_loc")') info
-    case('A')
+    case('E','A')
       call psb_errpush(info,name)
       goto 9999
     end select
@@ -223,12 +223,12 @@ subroutine psb_loc_to_glob(x,desc_a,info,iact)
 
   if (info /= 0) then
     select case(act)
-    case('E')
+    case('I')
       call psb_erractionrestore(err_act)
       return
     case('W')
       write(0,'("Error ",i5," in subroutine glob_to_loc")') info
-    case('A')
+    case('A','E')
       call psb_errpush(info,name)
       goto 9999
     end select

src/tools/psb_zcdovr.f90

@@ -156,37 +156,17 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info)
   l_tmp_ovr_idx = novr*(3*Max(2*index_dim,1)+1)
   l_tmp_halo    = novr*(3*Size(desc_a%halo_index))
 
-  if (psb_is_large_desc(desc_a)) then
+  call psb_cd_set_bld(desc_ov,info)
-    desc_ov%matrix_data(psb_dec_type_) = psb_desc_large_bld_ 
+!!$  if (psb_is_large_desc(desc_a)) then
-  else
+!!$    desc_ov%matrix_data(psb_dec_type_) = psb_desc_large_bld_ 
-    desc_ov%matrix_data(psb_dec_type_) = psb_desc_bld_ 
+!!$  else
-  end if
+!!$    desc_ov%matrix_data(psb_dec_type_) = psb_desc_bld_ 
+!!$  end if
   If(debug) then
     Write(0,*)'Start cdovrbld',me,lworks,lworkr
     call psb_barrier(ictxt)
   endif
 
-  if (.false.) then 
-    !
-    ! The real work goes on in here....
-    !
-    Call psb_cdovrbld(novr,desc_ov,desc_a,a,&
-         & l_tmp_halo,l_tmp_ovr_idx,lworks,lworkr,info) 
-
-    if (info /= 0) then
-      info=4010
-      ch_err='psb_cdovrbld'
-      call psb_errpush(info,name,a_err=ch_err)
-      goto 9999
-    end if
-
-    If(debug) then
-      Write(0,*)'Done cdovrbld',me,lworks,lworkr
-      call psb_barrier(ictxt)
-    endif
-
-  else
-
 
   Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info)
   if (info /= 0) then 
@@ -693,7 +673,6 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info)
     goto 9999
   end if
 
-  end if
 
   call psb_erractionrestore(err_act)
   return