From 2b295de9e762e6f8f5aba0fe9090100d287eaacf Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 20 May 2020 15:32:52 +0200 Subject: [PATCH] New crea_index internals. --- base/internals/Makefile | 3 +- base/internals/psi_crea_index.f90 | 99 ++++++++----- base/internals/psi_xtr_loc_dl.F90 | 222 ++++-------------------------- base/modules/psi_i_mod.F90 | 22 ++- 4 files changed, 116 insertions(+), 230 deletions(-) diff --git a/base/internals/Makefile b/base/internals/Makefile index 1ebdbcc0..cf499f2d 100644 --- a/base/internals/Makefile +++ b/base/internals/Makefile @@ -4,7 +4,8 @@ FOBJS = psi_compute_size.o psi_crea_bnd_elem.o psi_crea_index.o \ psi_crea_ovr_elem.o psi_bld_tmpovrl.o psi_dl_check.o \ psi_bld_tmphalo.o psi_sort_dl.o \ psi_indx_map_fnd_owner.o \ - psi_desc_impl.o psi_hash_impl.o psi_list_search.o psi_srtlist.o + psi_desc_impl.o psi_hash_impl.o psi_list_search.o psi_srtlist.o \ + psi_bld_glb_dep_list.o psi_xtr_loc_dl.o MPFOBJS = psi_desc_index.o psi_extrct_dl.o psi_fnd_owner.o psi_a2a_fnd_owner.o \ psi_graph_fnd_owner.o psi_adjcncy_fnd_owner.o psi_symm_dep_list.o diff --git a/base/internals/psi_crea_index.f90 b/base/internals/psi_crea_index.f90 index 51046737..eaa9f636 100644 --- a/base/internals/psi_crea_index.f90 +++ b/base/internals/psi_crea_index.f90 @@ -64,9 +64,10 @@ subroutine psi_i_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info) integer(psb_ipk_), allocatable, intent(inout) :: index_out(:) ! ....local scalars... - integer(psb_ipk_) :: ictxt, me, np, mode, err_act, dl_lda + integer(psb_ipk_) :: ictxt, me, np, mode, err_act, dl_lda, ldl ! ...parameters... - integer(psb_ipk_), allocatable :: dep_list(:,:), length_dl(:) + integer(psb_ipk_), allocatable :: dep_list(:,:), length_dl(:), loc_dl(:) + integer(psb_ipk_) :: dlmax, dlavg integer(psb_ipk_),parameter :: root=psb_root_,no_comm=-1 integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -136,54 +137,80 @@ subroutine psi_i_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info) goto 9999 end if if (do_timings) call psb_toc(idx_phase2) + ldl = length_dl(me) + loc_dl = dep_list(1:ldl,me) + else + if (do_timings) call psb_tic(idx_phase1) - call psi_extract_dep_list(ictxt,& + call psi_extract_loc_dl(ictxt,& & desc_a%is_bld(), desc_a%is_upd(),& - & index_in, dep_list,length_dl,dl_lda,mode,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='extrct_dl') - goto 9999 + & index_in, loc_dl,length_dl,info) + + dlmax = maxval(length_dl(:)) + dlavg = (sum(length_dl(:))+np-1)/np +!!$ if ((dlmax>0).and.(me==0)) write(0,*) 'Dependency list : max:',dlmax,& +!!$ & ' avg:',dlavg, ((dlmax>np/3).or.((dlavg>=np/4).and.(np>128))) + + if (choose_sorting(dlmax,dlavg,np)) then + + call psi_bld_glb_dep_list(ictxt,& + & loc_dl,length_dl,dep_list,dl_lda,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='extrct_dl') + goto 9999 + end if + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),': from extract_dep_list',& + & me,length_dl(0),index_in(1), ':',dep_list(:length_dl(me),me) + ! ...now process root contains dependence list of all processes... + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),': root sorting dep list' + if (do_timings) call psb_toc(idx_phase1) + if (do_timings) call psb_tic(idx_phase2) + + call psi_dl_check(dep_list,dl_lda,np,length_dl) + + ! ....now i can sort dependency lists. + call psi_sort_dl(dep_list,length_dl,np,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_sort_dl') + goto 9999 + end if + if (do_timings) call psb_toc(idx_phase2) + ldl = length_dl(me) + loc_dl = dep_list(1:ldl,me) + else + ! Do nothing + ldl = length_dl(me) + loc_dl = loc_dl(1:ldl) end if - if (debug_level >= psb_debug_inner_) & - & write(debug_unit,*) me,' ',trim(name),': from extract_dep_list',& - & me,length_dl(0),index_in(1), ':',dep_list(:length_dl(me),me) - ! ...now process root contains dependence list of all processes... - if (debug_level >= psb_debug_inner_) & - & write(debug_unit,*) me,' ',trim(name),': root sorting dep list' - if (do_timings) call psb_toc(idx_phase1) - if (do_timings) call psb_tic(idx_phase2) - - call psi_dl_check(dep_list,dl_lda,np,length_dl) - - ! ....now i can sort dependency lists. - call psi_sort_dl(dep_list,length_dl,np,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_sort_dl') - goto 9999 - end if - if (do_timings) call psb_toc(idx_phase2) end if - if (do_timings) call psb_tic(idx_phase3) + if (do_timings) call psb_tic(idx_phase3) if(debug_level >= psb_debug_inner_)& - & write(debug_unit,*) me,' ',trim(name),': calling psi_desc_index' + & write(debug_unit,*) me,' ',trim(name),': calling psi_desc_index',ldl,':',loc_dl(1:ldl) ! Do the actual format conversion. - call psi_desc_index(desc_a,index_in,dep_list(1:,me),& - & length_dl(me),nsnd,nrcv, index_out,info) + call psi_desc_index(desc_a,index_in,loc_dl,ldl,nsnd,nrcv,index_out,info) if(debug_level >= psb_debug_inner_) & & write(debug_unit,*) me,' ',trim(name),': out of psi_desc_index',& & size(index_out) - nxch = length_dl(me) + nxch = ldl if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_desc_index') goto 9999 end if if (do_timings) call psb_toc(idx_phase3) - deallocate(dep_list,length_dl) + if (allocated(dep_list)) deallocate(dep_list,stat=info) + if ((info==0).and.allocated(length_dl)) deallocate(length_dl,stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if if(debug_level >= psb_debug_inner_) & & write(debug_unit,*) me,' ',trim(name),': done' @@ -193,4 +220,14 @@ subroutine psi_i_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info) 9999 call psb_error_handler(ictxt,err_act) return +contains + function choose_sorting(dlmax,dlavg,np) result(val) + implicit none + integer(psb_ipk_), intent(in) :: dlmax,dlavg,np + logical :: val + + val = .not.(((dlmax>(27*4)).or.((dlavg>=(27*2)).and.(np>128)))) + val = .false. + end function choose_sorting + end subroutine psi_i_crea_index diff --git a/base/internals/psi_xtr_loc_dl.F90 b/base/internals/psi_xtr_loc_dl.F90 index 4941982a..c97cc7a5 100644 --- a/base/internals/psi_xtr_loc_dl.F90 +++ b/base/internals/psi_xtr_loc_dl.F90 @@ -29,8 +29,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_i_xtr_loc_dl(ictxt,is_bld,is_upd,desc_str,loc_dl,& - & ldl,max_ldl,mode,info) +subroutine psi_i_xtr_loc_dl(ictxt,is_bld,is_upd,desc_str,loc_dl,length_dl,info) ! internal routine ! == = ============= @@ -104,20 +103,11 @@ subroutine psi_i_xtr_loc_dl(ictxt,is_bld,is_upd,desc_str,loc_dl,& ! np integer (global input) ! number of grid process. ! - ! mode integer (global input) - ! if mode =0 then will be inserted also duplicate element in - ! a same dependence list - ! if mode =1 then not will be inserted duplicate element in - ! a same dependence list ! output ! == = == - ! only for root (pid=0) process: - ! dep_list integer array(dl_lda,0:np) - ! dependence list dep_list(*,i) is the list of process identifiers to which process i - ! must communicate with. this list with its order is extracted from - ! desc_str list. - ! length_dl integer array(0:np) - ! length_dl(i) is the length of dep_list(*,i) list + ! loc_dl integer array(:) + ! dependence list of current process + ! use psi_mod, psb_protect_name => psi_i_xtr_loc_dl #ifdef MPI_MOD use mpi @@ -133,22 +123,19 @@ subroutine psi_i_xtr_loc_dl(ictxt,is_bld,is_upd,desc_str,loc_dl,& #endif ! ....scalar parameters... logical, intent(in) :: is_bld, is_upd - integer(psb_ipk_), intent(in) :: ictxt,mode - integer(psb_ipk_), intent(out) :: max_ldl, ldl - integer(psb_ipk_), intent(in) :: desc_str(*) - integer(psb_ipk_), allocatable, intent(out) :: loc_dl(:) + integer(psb_ipk_), intent(in) :: ictxt + integer(psb_ipk_), intent(in) :: desc_str(:) + integer(psb_ipk_), allocatable, intent(out) :: loc_dl(:), length_dl(:) integer(psb_ipk_), intent(out) :: info ! .....local arrays.... integer(psb_ipk_) :: int_err(5) - integer(psb_ipk_), allocatable :: itmp(:) ! .....local scalars... - integer(psb_ipk_) :: i,pointer_dep_list,proc,j,err_act + integer(psb_ipk_) :: i,pdl,proc,j,err_act, ldu integer(psb_ipk_) :: err integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_), allocatable :: length_dl(:) integer(psb_mpk_) :: iictxt, icomm, me, np, minfo - logical, parameter :: dist_symm_list=.false., print_dl=.false., profile=.true. + logical, parameter :: dist_symm_list=.true., print_dl=.false., profile=.true. character name*20 name='psi_extrct_dl' @@ -159,20 +146,19 @@ subroutine psi_i_xtr_loc_dl(ictxt,is_bld,is_upd,desc_str,loc_dl,& info = psb_success_ call psb_info(iictxt,me,np) - allocate(itmp(2*np+1),length_dl(0:np),stat=info) + pdl = size(desc_str) + allocate(loc_dl(pdl+1),length_dl(0:np),stat=info) if (info /= psb_success_) then info=psb_err_alloc_dealloc_ goto 9999 end if - do i=0,np - length_dl(i) = 0 - itmp(i+1) = -1 - enddo - i=1 + if (debug_level >= psb_debug_inner_)& & write(debug_unit,*) me,' ',trim(name),': start ',info - pointer_dep_list=1 + loc_dl = -1 + i = 1 + pdl = 0 if (is_bld) then do while (desc_str(i) /= -1) if (debug_level >= psb_debug_inner_)& @@ -193,24 +179,8 @@ subroutine psi_i_xtr_loc_dl(ictxt,is_bld,is_upd,desc_str,loc_dl,& goto 9999 endif ! if((me == 1).and.(proc == 3))write(psb_err_unit,*)'found 3' - if (mode == 1) then - ! ...search if already exist proc - ! in itmp(*)... - j=1 - do while ((j < pointer_dep_list).and.& - & (itmp(j) /= proc)) - j=j+1 - enddo - - if (j == pointer_dep_list) then - ! ...if not found..... - itmp(pointer_dep_list)=proc - pointer_dep_list=pointer_dep_list+1 - endif - else if (mode == 0) then - itmp(pointer_dep_list)=proc - pointer_dep_list=pointer_dep_list+1 - endif + pdl=pdl+1 + loc_dl(pdl)=proc endif i=i+desc_str(i+1)+2 enddo @@ -227,159 +197,25 @@ subroutine psi_i_xtr_loc_dl(ictxt,is_bld,is_upd,desc_str,loc_dl,& proc=desc_str(i) ! ..if number of element to be exchanged !=0 - - if (mode == 1) then - ! ...search if already exist proc.... - j=1 - do while ((j < pointer_dep_list).and.& - & (itmp(j) /= proc)) - j=j+1 - enddo - if (j == pointer_dep_list) then - ! ...if not found..... - itmp(pointer_dep_list)=proc - pointer_dep_list=pointer_dep_list+1 - endif - else if (mode == 0) then - itmp(pointer_dep_list)=proc - pointer_dep_list=pointer_dep_list+1 - endif + pdl=pdl+1 + loc_dl(pdl)=proc endif i=i+desc_str(i+1)+2 enddo + else info = 2020 goto 9999 endif - - length_dl(me)=pointer_dep_list-1 - if ((profile).and.(me==0)) then - block - integer(psb_ipk_) :: dlmax, dlavg - dlmax = maxval(length_dl(:)) - dlavg = (sum(length_dl(:))+np-1)/np - if (dlmax>0) write(0,*) 'Dependency list : max:',dlmax,& - & ' avg:',dlavg, ((dlmax>np/3).or.((dlavg>=np/4).and.(np>128))) - - end block - end if - - if (dist_symm_list) then - call psb_realloc(length_dl(me),itmp,info) - call psi_symm_dep_list(itmp,ictxt,info) - dl_lda = max(size(itmp),1) - call psb_max(iictxt, dl_lda) - - if (debug_level >= psb_debug_inner_) & - & write(debug_unit,*) me,' ',trim(name),': Dep_list length ',length_dl(me),dl_lda - call psb_realloc(dl_lda,itmp,info) - ! dl_lda = min(np,2*dl_lda) - allocate(dep_list(dl_lda,0:np),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - - call psb_sum(iictxt,length_dl(0:np)) - icomm = psb_get_mpi_comm(iictxt) - call mpi_allgather(itmp,dl_lda,psb_mpi_ipk_,& - & dep_list,dl_lda,psb_mpi_ipk_,icomm,minfo) - info = minfo - if (info == 0) deallocate(itmp,stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - goto 9999 - endif - else - block - integer(psb_ipk_), allocatable :: list1(:,:), ldl2(:), list2(:,:) - integer(psb_ipk_) :: i,j,ip,dlsym, ldu, mdl, l1, l2 - - dl_lda = max(length_dl(me),1) - call psb_max(iictxt, dl_lda) - if (debug_level >= psb_debug_inner_) & - & write(debug_unit,*) me,' ',trim(name),': Dep_list length ',length_dl(me),dl_lda - allocate(dep_list(dl_lda,0:np),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - call psb_sum(iictxt,length_dl(0:np)) - icomm = psb_get_mpi_comm(iictxt) - call mpi_allgather(itmp,dl_lda,psb_mpi_ipk_,& - & dep_list,dl_lda,psb_mpi_ipk_,icomm,minfo) - info = minfo - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - goto 9999 - endif - allocate(ldl2(0:np),stat=info) - ldl2 = 0 - do j=0, np-1 - do i=1,length_dl(j) - ip = dep_list(i,j) - ldl2(ip) = ldl2(ip) + 1 - end do - end do - dlsym = maxval(ldl2) - allocate(list2(dlsym,0:np),stat=info) - call move_alloc(dep_list,list1) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - ldl2 = 0 - do j=0, np-1 - do i=1,length_dl(j) - ip = list1(i,j) - ldl2(ip) = ldl2(ip) + 1 - list2(ldl2(ip),ip) = j - end do - end do - mdl = 0 - do j = 0, np-1 - l1 = length_dl(j) - l2 = ldl2(j) - itmp(1:l1) = list1(1:l1,j) - itmp(l1+1:l1+l2) = list2(1:l2,j) - ldu = l1 + l2 - !if (me == 0) write(0,*) 'Iter ',j,':',l1,l2,':',itmp(1:l1),':',itmp(l1+1:l1+l2) - call psb_msort_unique(itmp(1:l1+l2),ldu) - mdl = max(mdl, ldu) - !if (me == 0) write(0,*) 'Iter ',j,':',ldu,':',itmp(1:ldu) - end do - dl_lda = mdl - allocate(dep_list(dl_lda,0:np),stat=info) - dep_list = -1 - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - do j = 0, np-1 - l1 = length_dl(j) - l2 = ldl2(j) - itmp(1:l1) = list1(1:l1,j) - itmp(l1+1:l1+l2) = list2(1:l2,j) - ldu = l1 + l2 - call psb_msort_unique(itmp(1:l1+l2),ldu) - length_dl(j) = ldu - dep_list(1:ldu,j) = itmp(1:ldu) - end do - - end block - endif - if (print_dl) then - if (me == 0) then - write(0,*) ' Dep_list ' - do i=0,np-1 - j = length_dl(i) - write(0,*) 'Proc ',i,':',dep_list(1:j,i) - end do - flush(0) - end if - call psb_barrier(ictxt) - end if - + call psb_msort_unique(loc_dl(1:pdl),ldu) + pdl = ldu + call psb_realloc(pdl,loc_dl,info) + call psi_symm_dep_list(loc_dl,ictxt,info) + pdl = size(loc_dl) + length_dl = 0 + length_dl(me) = pdl + call psb_sum(ictxt,length_dl) + call psb_erractionrestore(err_act) return diff --git a/base/modules/psi_i_mod.F90 b/base/modules/psi_i_mod.F90 index eff2a05f..9239617d 100644 --- a/base/modules/psi_i_mod.F90 +++ b/base/modules/psi_i_mod.F90 @@ -126,16 +126,28 @@ module psi_i_mod integer(psb_ipk_), intent(out) :: info end subroutine psi_i_extract_dep_list end interface psi_extract_dep_list + + interface psi_bld_glb_dep_list + subroutine psi_i_bld_glb_dep_list(ictxt,loc_dl,& + & length_dl,dep_list,dl_lda,info) + import + implicit none + integer(psb_ipk_), intent(in) :: ictxt + integer(psb_ipk_), intent(out) :: dl_lda + integer(psb_ipk_), intent(in) :: loc_dl(:), length_dl(:) + integer(psb_ipk_), allocatable, intent(out) :: dep_list(:,:) + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i_bld_glb_dep_list + end interface psi_bld_glb_dep_list interface psi_extract_loc_dl subroutine psi_i_xtr_loc_dl(ictxt,is_bld,is_upd,desc_str,loc_dl,& - & ldl,max_ldl,mode,info) + & length_dl,info) import logical, intent(in) :: is_bld, is_upd - integer(psb_ipk_), intent(in) :: ictxt,mode - integer(psb_ipk_), intent(out) :: max_ldl, ldl - integer(psb_ipk_), intent(in) :: desc_str(*) - integer(psb_ipk_), allocatable, intent(out) :: loc_dl(:) + integer(psb_ipk_), intent(in) :: ictxt + integer(psb_ipk_), intent(in) :: desc_str(:) + integer(psb_ipk_), allocatable, intent(out) :: loc_dl(:), length_dl(:) integer(psb_ipk_), intent(out) :: info end subroutine psi_i_xtr_loc_dl end interface psi_extract_loc_dl