New version of PSB_CDPRT. Must be called by all processes.

base/modules/tools/psb_cd_tools_mod.f90

@@ -81,12 +81,13 @@ module psb_cd_tools_mod
 
 
   interface psb_cdprt
-    subroutine psb_cdprt(iout,desc_p,glob,short)
+    subroutine psb_cdprt(iout,desc_p,glob,short,verbosity)
       import :: psb_ipk_, psb_desc_type
       implicit none 
       type(psb_desc_type), intent(in)    :: desc_p
       integer(psb_ipk_), intent(in)                :: iout
       logical, intent(in), optional      :: glob,short
+      integer(psb_ipk_), intent(in), optional      :: verbosity
     end subroutine psb_cdprt
   end interface
 

base/tools/psb_cdprt.f90

@@ -40,211 +40,142 @@
 !    glob          - logical(otpional).      Wheter to print out global or local data.
 !    short         - logical(optional).      Used to choose a verbose output.
 !
-subroutine psb_cdprt(iout,desc_p,glob,short)
+subroutine psb_cdprt(iout,desc_p,glob,short, verbosity)
   use psb_base_mod, psb_protect_name => psb_cdprt
   implicit none 
   type(psb_desc_type), intent(in)  :: desc_p
   integer(psb_ipk_), intent(in)                :: iout
+  integer(psb_ipk_), intent(in), optional     :: verbosity
   logical, intent(in), optional      :: glob,short
-  logical :: lshort, lglob
+  logical :: short_, glob_
 
-  integer(psb_ipk_) :: m, n_row, n_col,counter,idx,n_elem_recv,n_elem_send,&
+  integer(psb_ipk_) :: m, n_row, n_col,counter,idx,&
-       & proc,i
+       & n_elem_recv,n_elem_send,proc,i, verb_
+  integer(psb_ipk_) :: ictxt, me, np
+  integer(psb_ipk_) :: total_snd, total_rcv, total_xhcg, global_halo, global_points
+  integer(psb_ipk_) :: local_snd, local_rcv, local_xhcg, local_halo, local_points
   
   if (present(glob)) then 
-    lglob = glob
+    glob_ = glob
   else
-    lglob = .false.
+    glob_ = .false.
   endif
   if (present(short)) then 
-    lshort = short
+    short_ = short
   else
-    lshort = .true.
+    short_ = .true.
   endif
-  write(0,*) 'To be reimplemented ye'
+  if (present(verbosity)) then 
+    verb_ = verbosity
+  else
+    verb_ = 1
+  endif
+
+  ictxt = desc_p%get_ctxt()
+  call psb_info(ictxt, me,np)
+  
+  !
+  ! Level 1: Print global info
+  !
+  global_points = desc_p%get_global_rows()
+  local_points  = desc_p%get_local_rows()
+  local_halo    = desc_p%get_local_cols() - desc_p%get_local_rows()
+  global_halo   = local_halo
+  call psb_sum(ictxt, global_halo)
+  if (me == psb_root_) then
+    write(iout,*) ' Communication descriptor detailed info.'
+    write(iout,*) '               Descriptor format:       ',desc_p%get_fmt()    
+    write(iout,*) ' Global descriptor data: points:',global_points,' halo:',global_halo
+    write(iout,*)
+  end if
+  call psb_barrier(ictxt)
+  do i=0, np-1
+    if (me == i)  &
+       &  write(iout,*) me,': Local descriptor data: points:',local_points,' halo:',local_halo
+
+  end do
+
+  
+  !
+  ! Level 2: Statistics at process level
+  !
+  if (me==psb_root_) write(iout,*) 'Communication data for : comm_halo'
+  do i=0, np-1
+    if (me == i)  &
+       &  call  print_my_xchg(iout,desc_p,verbosity=verb_,data=psb_comm_halo_)
+    call psb_barrier(ictxt)
+  end do
+  
+  if (me==psb_root_) write(iout,*) 'Communication data for : comm_ext'
+  do i=0, np-1
+    if (me == i)  &
+       &  call  print_my_xchg(iout,desc_p,verbosity=verb_,data=psb_comm_ext_)
+    call psb_barrier(ictxt)
+  end do
+  
+  
+  
+
+
+  
   return
 
-  if (.not.lglob) then
+contains
-!!$    write(iout,*) 'Communication descriptor:',desc_p%matrix_data(1:10)
+  subroutine print_my_xchg(iout,desc_p,data,glob,short, verbosity)
-!!$    m=desc_p%matrix_data(psb_m_)
+    implicit none 
-!!$    n_row=desc_p%matrix_data(psb_n_row_)
+    type(psb_desc_type), intent(in), target   :: desc_p
-!!$    n_col=desc_p%matrix_data(psb_n_col_)
+    integer(psb_ipk_), intent(in)             :: iout
-
+    integer(psb_ipk_), intent(in), optional   :: verbosity, data
-!!$    if (.not.lshort) &
+    logical, intent(in), optional      :: glob,short
-!!$         & write(iout,*) 'Loc_to_glob ',desc_p%idxmap%loc_to_glob(1:n_row), ': ',&
+    logical :: short_, glob_
-!!$         & desc_p%idxmap%loc_to_glob(n_row+1:n_col)
-
-!!$    if (.not.lshort) write(iout,*) 'glob_to_loc ',desc_p%idxmap%glob_to_loc(1:m) 
-    write(iout,*) 'Halo_index'
-    counter      = 1
-    Do
-      proc=desc_p%halo_index(counter+psb_proc_id_)
-      if (proc == -1) exit
-      n_elem_recv=desc_p%halo_index(counter+psb_n_elem_recv_)
-      n_elem_send=desc_p%halo_index(counter+n_elem_recv+psb_n_elem_send_)
-      write(iout,*) 'Halo_index Receive',proc,n_elem_recv
-      if (.not.lshort) write(iout,*) &
-           & desc_p%halo_index(counter+psb_n_elem_recv_+1:counter+psb_n_elem_recv_+n_elem_recv)
-      write(iout,*) 'Halo_index Send',proc,n_elem_send
-      if (.not.lshort) write(iout,*) &
-           & desc_p%halo_index(counter+n_elem_recv+psb_n_elem_send_+1: &
-           &                   counter+n_elem_recv+psb_n_elem_send_+n_elem_send)
-
-      counter   = counter+n_elem_recv+n_elem_send+3
-    enddo
-
-    write(iout,*) 'Ext_index'
-    counter      = 1
-    Do
-      proc=desc_p%ext_index(counter+psb_proc_id_)
-      if (proc == -1) exit
-      n_elem_recv=desc_p%ext_index(counter+psb_n_elem_recv_)
-      n_elem_send=desc_p%ext_index(counter+n_elem_recv+psb_n_elem_send_)
-      write(iout,*) 'Ext_index Receive',proc,n_elem_recv
-      if (.not.lshort) write(iout,*) &
-           & desc_p%ext_index(counter+psb_n_elem_recv_+1:counter+psb_n_elem_recv_+n_elem_recv)
-      write(iout,*) 'Ext_index Send',proc,n_elem_send
-      if (.not.lshort) write(iout,*) &
-           & desc_p%ext_index(counter+n_elem_recv+psb_n_elem_send_+1: &
-           &                   counter+n_elem_recv+psb_n_elem_send_+n_elem_send)
-
-      counter   = counter+n_elem_recv+n_elem_send+3
-    enddo
-
-
-    write(iout,*) 'Ovrlap_index'
-    counter      = 1
-    Do
-      proc=desc_p%ovrlap_index(counter+psb_proc_id_)
-      if (proc == -1) exit
-      n_elem_recv=desc_p%ovrlap_index(counter+psb_n_elem_recv_)
-      n_elem_send=desc_p%ovrlap_index(counter+n_elem_recv+psb_n_elem_send_)
-      write(iout,*) 'Ovrlap_index Receive',proc,n_elem_recv
-      if (.not.lshort) write(iout,*) &
-           & desc_p%ovrlap_index(counter+psb_n_elem_recv_+1:&
-           &    counter+psb_n_elem_recv_+n_elem_recv)
-      write(iout,*) 'Ovrlap_index Send',proc,n_elem_send
-      if (.not.lshort) write(iout,*) &
-           & desc_p%ovrlap_index(counter+n_elem_recv+psb_n_elem_send_+1: &
-           &                   counter+n_elem_recv+psb_n_elem_send_+n_elem_send)
-
-      counter   = counter+n_elem_recv+n_elem_send+3
-    enddo
-
-    write(iout,*) 'Ovrlap_elem'
-
-    Do  counter = 1,size(desc_p%ovrlap_elem,1)
-      idx         = desc_p%ovrlap_elem(counter,1)
-      n_elem_recv = desc_p%ovrlap_elem(counter,2)
-      proc        = desc_p%ovrlap_elem(counter,3)
-      if (.not.lshort) write(iout,*) idx,n_elem_Recv,proc
-    enddo
-
-  else if (lglob) then 
-
-!!$    write(iout,*) 'Communication descriptor:',desc_p%matrix_data(1:10)
-!!$    m=desc_p%matrix_data(psb_m_)
-!!$    n_row=desc_p%matrix_data(psb_n_row_)
-!!$    n_col=desc_p%matrix_data(psb_n_col_)
-    if (.not.lshort) then 
-!!$      write(iout,*) 'Loc_to_glob '
-!!$      do i=1, n_row
-!!$        write(iout,*) i, desc_p%idxmap%loc_to_glob(i)
-!!$      enddo
-!!$      write(iout,*) '........'
-!!$      do i=n_row+1,n_col
-!!$        write(iout,*) i, desc_p%idxmap%loc_to_glob(i)
-!!$      enddo
-!!$
-!!$      write(iout,*) 'glob_to_loc '
-!!$      do i=1,m
-!!$        write(iout,*) i,desc_p%idxmap%glob_to_loc(i)
-!!$      enddo
-    endif
-    write(iout,*) 'Halo_index'
-    counter      = 1
-    Do
-      proc=desc_p%halo_index(counter+psb_proc_id_)
-      if (proc == -1) exit
-      n_elem_recv=desc_p%halo_index(counter+psb_n_elem_recv_)
-      n_elem_send=desc_p%halo_index(counter+n_elem_recv+psb_n_elem_send_)
-      write(iout,*) 'Halo_index Receive',proc,n_elem_recv
-      if (.not.lshort) then 
-        do i=counter+psb_n_elem_recv_+1,counter+psb_n_elem_recv_+n_elem_recv
-!!$          write(iout,*) &
-!!$               & desc_p%idxmap%loc_to_glob(desc_p%halo_index(i)),desc_p%halo_index(i)
-        enddo
-      endif
-      write(iout,*) 'Halo_index Send',proc,n_elem_send
-      if (.not.lshort) then 
-        do i=counter+n_elem_recv+psb_n_elem_send_+1, &
-             & counter+n_elem_recv+psb_n_elem_send_+n_elem_send
-!!$          write(iout,*) &
-!!$               & desc_p%idxmap%loc_to_glob(desc_p%halo_index(i)),  desc_p%halo_index(i)
-        enddo
-      endif
-      counter   = counter+n_elem_recv+n_elem_send+3
-    enddo
-
-    write(iout,*) 'Ext_index'
-    counter      = 1
-    Do
-      proc=desc_p%ext_index(counter+psb_proc_id_)
-      if (proc == -1) exit
-      n_elem_recv=desc_p%ext_index(counter+psb_n_elem_recv_)
-      n_elem_send=desc_p%ext_index(counter+n_elem_recv+psb_n_elem_send_)
-      write(iout,*) 'Ext_index Receive',proc,n_elem_recv
-      if (.not.lshort) then 
-        do i=counter+psb_n_elem_recv_+1,counter+psb_n_elem_recv_+n_elem_recv
-!!$          write(iout,*) &
-!!$               & desc_p%idxmap%loc_to_glob(desc_p%ext_index(i)),desc_p%ext_index(i)
-        enddo
-      endif
-      write(iout,*) 'Ext_index Send',proc,n_elem_send
-      if (.not.lshort) then 
-        do i=counter+n_elem_recv+psb_n_elem_send_+1, &
-             & counter+n_elem_recv+psb_n_elem_send_+n_elem_send
-!!$          write(iout,*) &
-!!$               & desc_p%idxmap%loc_to_glob(desc_p%ext_index(i)),  desc_p%ext_index(i)
-        enddo
-      endif
-      counter   = counter+n_elem_recv+n_elem_send+3
-    enddo
-
-
-    write(iout,*) 'Ovrlap_index'
-    counter      = 1
-    Do
-      proc=desc_p%ovrlap_index(counter+psb_proc_id_)
-      if (proc == -1) exit
-      n_elem_recv=desc_p%ovrlap_index(counter+psb_n_elem_recv_)
-      n_elem_send=desc_p%ovrlap_index(counter+n_elem_recv+psb_n_elem_send_)
-      write(iout,*) 'Ovrlap_index Receive',proc,n_elem_recv
-      if (.not.lshort) then 
-        do i=counter+psb_n_elem_recv_+1,counter+psb_n_elem_recv_+n_elem_recv
-!!$          write(iout,*) desc_p%idxmap%loc_to_glob(desc_p%ovrlap_index(i)),&
-!!$               & desc_p%ovrlap_index(i)
-        enddo
-      endif
-      write(iout,*) 'Ovrlap_index Send',proc,n_elem_send
-      if (.not.lshort) then 
-        do i=counter+n_elem_recv+psb_n_elem_send_+1, &
-             &                   counter+n_elem_recv+psb_n_elem_send_+n_elem_send
-!!$          write(iout,*) desc_p%idxmap%loc_to_glob(desc_p%ovrlap_index(i)),&
-!!$               &   desc_p%ovrlap_index(i)
-        enddo
-      endif
-      counter   = counter+n_elem_recv+n_elem_send+3
-    enddo
     
-    write(iout,*) 'Ovrlap_elem'
+    integer(psb_ipk_) :: ip, nerv, nesd, totxch,idxr,idxs
+    integer(psb_ipk_) :: ictxt, me, np, data_, info, verb_
+    class(psb_i_base_vect_type), pointer :: vpnt
     
-    Do  counter = 1,size(desc_p%ovrlap_elem,1)
+    ictxt = desc_p%get_ctxt()
-      idx         = desc_p%ovrlap_elem(counter,1)
+    call psb_info(ictxt, me,np)
-      n_elem_recv = desc_p%ovrlap_elem(counter,2)
+    if (present(data)) then
-      proc        = desc_p%ovrlap_elem(counter,3)
+      data_ = data
-!!$      if (.not.lshort) write(iout,*) idx,desc_p%idxmap%loc_to_glob(idx),n_elem_Recv,proc
+    else
-    enddo
+      data_ = psb_comm_halo_
+    end if
+    if (present(verbosity)) then
+      verb_ = verbosity
+    else
+      verb_ = 1
+    end if
     
+    call psb_cd_v_get_list(data_,desc_p,vpnt,totxch,idxr,idxs,info)
+    select case(verb_)
+    case (1) 
+      write(iout,*) me,' Total exchanges ',totxch,' Total sends:',idxs,' Total receives:', idxr
+    case (2)
+      write(iout,*) me,' Total exchanges ',totxch,' Total sends:',idxs,' Total receives:', idxr
+      if (totxch == 0) return
+      if (.not.associated(vpnt)) return
+      if (.not.allocated(vpnt%v)) return
+      associate(idx => vpnt%v)
+        ip     = 1        
+        do 
+          if (ip > size(idx)) then 
+            write(psb_err_unit,*) ': Warning: out of size of input vector '
+            exit
           end if
+          if (idx(ip) == -1) exit
+          totxch = totxch+1
+          nerv   = idx(ip+psb_n_elem_recv_)
+          nesd   = idx(ip+nerv+psb_n_elem_send_)
+          write(iout,*) '   ',me,' Exchanging with:',idx(ip),' Sends:',nesd,' Receives:', nerv
+          idxs = idxs + nesd
+          idxr = idxr + nerv
+          ip   = ip+nerv+nesd+3
+        end do
+      end associate
+    case default
+      ! Do nothing
+    end select
+    
+  end subroutine print_my_xchg
+
 end subroutine psb_cdprt