From 35da66299a2cc00de48055a03080b0cf97fbcb2d Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 5 Feb 2018 11:52:21 +0000 Subject: [PATCH] New version of PSB_CDPRT. Must be called by all processes. --- base/modules/tools/psb_cd_tools_mod.f90 | 3 +- base/tools/psb_cdprt.f90 | 319 ++++++++++-------------- 2 files changed, 127 insertions(+), 195 deletions(-) diff --git a/base/modules/tools/psb_cd_tools_mod.f90 b/base/modules/tools/psb_cd_tools_mod.f90 index 1a689ac8..5db8ac06 100644 --- a/base/modules/tools/psb_cd_tools_mod.f90 +++ b/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 diff --git a/base/tools/psb_cdprt.f90 b/base/tools/psb_cdprt.f90 index d77ad7ff..05f88050 100644 --- a/base/tools/psb_cdprt.f90 +++ b/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 + 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 - - integer(psb_ipk_) :: m, n_row, n_col,counter,idx,n_elem_recv,n_elem_send,& - & proc,i - + logical :: short_, glob_ + + integer(psb_ipk_) :: m, n_row, n_col,counter,idx,& + & 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 + if (present(verbosity)) then + verb_ = verbosity + else + verb_ = 1 endif - write(0,*) 'To be reimplemented ye' - return - - if (.not.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) & -!!$ & write(iout,*) 'Loc_to_glob ',desc_p%idxmap%loc_to_glob(1:n_row), ': ',& -!!$ & 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' + 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 - 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,desc_p%idxmap%loc_to_glob(idx),n_elem_Recv,proc - enddo +contains + subroutine print_my_xchg(iout,desc_p,data,glob,short, verbosity) + implicit none + type(psb_desc_type), intent(in), target :: desc_p + integer(psb_ipk_), intent(in) :: iout + integer(psb_ipk_), intent(in), optional :: verbosity, data + logical, intent(in), optional :: glob,short + logical :: short_, glob_ + + 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 + + ictxt = desc_p%get_ctxt() + call psb_info(ictxt, me,np) + if (present(data)) then + data_ = data + else + 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 if end subroutine psb_cdprt