diff --git a/base/comm/psb_cgather.f90 b/base/comm/psb_cgather.f90 index 4871c86f..bfc4ddae 100644 --- a/base/comm/psb_cgather.f90 +++ b/base/comm/psb_cgather.f90 @@ -109,7 +109,6 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot) lock=size(locx,2)-jlocx+1 globk=size(globx,2)-jglobx+1 maxk=min(lock,globk) - k = maxk call psb_bcast(ictxt,k,root=iiroot) @@ -136,7 +135,7 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot) do j=1,k do i=1,psb_cd_get_local_rows(desc_a) - idx = desc_a%idxmap%loc_to_glob(i) + call psb_loc_to_glob(i,idx,desc_a,info) globx(idx,jglobx+j-1) = locx(i,jlx+j-1) end do end do @@ -146,11 +145,12 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot) do i=1, size(desc_a%ovrlap_elem,1) if (me /= desc_a%ovrlap_elem(i,3)) then idx = desc_a%ovrlap_elem(i,1) - idx = desc_a%idxmap%loc_to_glob(idx) + call psb_loc_to_glob(idx,desc_a,info) globx(idx,jglobx+j-1) = czero end if end do end do + call psb_sum(ictxt,globx(1:m,jglobx:jglobx+k-1),root=root) call psb_erractionrestore(err_act) @@ -298,19 +298,20 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot) globx(:)=0.d0 do i=1,psb_cd_get_local_rows(desc_a) - idx = desc_a%idxmap%loc_to_glob(i) + call psb_loc_to_glob(i,idx,desc_a,info) globx(idx) = locx(i) end do + ! adjust overlapped elements do i=1, size(desc_a%ovrlap_elem,1) if (me /= desc_a%ovrlap_elem(i,3)) then idx = desc_a%ovrlap_elem(i,1) - idx = desc_a%idxmap%loc_to_glob(idx) + call psb_loc_to_glob(idx,desc_a,info) globx(idx) = czero end if end do - call psb_sum(ictxt,globx(1:m),root=root) + call psb_sum(ictxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return diff --git a/base/comm/psb_cscatter.F90 b/base/comm/psb_cscatter.F90 index f80ab7b2..bd174db1 100644 --- a/base/comm/psb_cscatter.F90 +++ b/base/comm/psb_cscatter.F90 @@ -67,7 +67,7 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot) & ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,& & jlx, myrank, rootrank, c, pos complex(psb_spk_),allocatable :: scatterv(:) - integer, allocatable :: displ(:), l_t_g_all(:), all_dim(:) + integer, allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) character(len=20) :: name, ch_err name='psb_scatterm' @@ -149,7 +149,7 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot) ! extract my chunk do j=1,k do i=1, nrow - idx = desc_a%idxmap%loc_to_glob(i) + call psb_loc_to_glob(i,idx,desc_a,info) locx(i,jlocx+j-1)=globx(idx,jglobx+j-1) end do end do @@ -157,13 +157,18 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot) call psb_get_rank(rootrank,ictxt,root) ! root has to gather size information - allocate(displ(np),all_dim(np),stat=info) + allocate(displ(np),all_dim(np),ltg(nrow),stat=info) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + call mpi_gather(nrow,1,mpi_integer,all_dim,& & 1,mpi_integer,rootrank,icomm,info) @@ -184,7 +189,7 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot) end if - call mpi_gatherv(desc_a%idxmap%loc_to_glob,nrow,& + call mpi_gatherv(ltg,nrow,& & mpi_integer,l_t_g_all,all_dim,& & displ,mpi_integer,rootrank,icomm,info) @@ -295,7 +300,7 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot) & ilocx, jlocx, lda_locx, lda_globx, root, k, icomm, myrank,& & rootrank, pos, ilx, jlx complex(psb_spk_), allocatable :: scatterv(:) - integer, allocatable :: displ(:), l_t_g_all(:), all_dim(:) + integer, allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) character(len=20) :: name, ch_err integer :: debug_level, debug_unit @@ -365,14 +370,19 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot) if ((root == -1).or.(np == 1)) then ! extract my chunk do i=1, nrow - idx=desc_a%idxmap%loc_to_glob(i) + call psb_loc_to_glob(i,idx,desc_a,info) locx(i)=globx(idx) end do else call psb_get_rank(rootrank,ictxt,root) ! root has to gather size information - allocate(displ(np),all_dim(np)) + allocate(displ(np),all_dim(np),ltg(nrow)) + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + call mpi_gather(nrow,1,mpi_integer,all_dim,& & 1,mpi_integer,rootrank,icomm,info) @@ -391,7 +401,7 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot) allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim))) end if - call mpi_gatherv(desc_a%idxmap%loc_to_glob,nrow,& + call mpi_gatherv(ltg,nrow,& & mpi_integer,l_t_g_all,all_dim,& & displ,mpi_integer,rootrank,icomm,info) diff --git a/base/comm/psb_dgather.f90 b/base/comm/psb_dgather.f90 index 8d713f83..d7d8764f 100644 --- a/base/comm/psb_dgather.f90 +++ b/base/comm/psb_dgather.f90 @@ -116,7 +116,8 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) - call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) + if (info == psb_success_) & + & call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' @@ -134,16 +135,17 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) do j=1,k do i=1,psb_cd_get_local_rows(desc_a) - idx = desc_a%idxmap%loc_to_glob(i) + call psb_loc_to_glob(i,idx,desc_a,info) globx(idx,jglobx+j-1) = locx(i,jlx+j-1) end do end do + do j=1,k ! adjust overlapped elements do i=1, size(desc_a%ovrlap_elem,1) if (me /= desc_a%ovrlap_elem(i,3)) then idx = desc_a%ovrlap_elem(i,1) - idx = desc_a%idxmap%loc_to_glob(idx) + call psb_loc_to_glob(idx,desc_a,info) globx(idx,jglobx+j-1) = dzero end if end do @@ -249,15 +251,15 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) endif if (present(iroot)) then - root = iroot - if((root < -1).or.(root > np)) then - info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + int_err(1:2)=(/5,root/) + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if else - root = -1 + root = -1 end if jglobx=1 @@ -277,24 +279,25 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) - call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + if (info == psb_success_) & + & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 end if globx(:)=0.d0 do i=1,psb_cd_get_local_rows(desc_a) - idx = desc_a%idxmap%loc_to_glob(i) + call psb_loc_to_glob(i,idx,desc_a,info) globx(idx) = locx(i) end do @@ -302,10 +305,11 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) do i=1, size(desc_a%ovrlap_elem,1) if (me /= desc_a%ovrlap_elem(i,3)) then idx = desc_a%ovrlap_elem(i,1) - idx = desc_a%idxmap%loc_to_glob(idx) + call psb_loc_to_glob(idx,desc_a,info) globx(idx) = dzero end if end do + call psb_sum(ictxt,globx(1:m),root=root) call psb_erractionrestore(err_act) @@ -315,8 +319,8 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return diff --git a/base/comm/psb_dscatter.F90 b/base/comm/psb_dscatter.F90 index 53243298..16b17fe0 100644 --- a/base/comm/psb_dscatter.F90 +++ b/base/comm/psb_dscatter.F90 @@ -67,7 +67,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot) & ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,& & jlx, myrank, rootrank, c, pos real(psb_dpk_), allocatable :: scatterv(:) - integer, allocatable :: displ(:), l_t_g_all(:), all_dim(:) + integer, allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) character(len=20) :: name, ch_err name='psb_scatterm' @@ -149,7 +149,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot) ! extract my chunk do j=1,k do i=1, nrow - idx = desc_a%idxmap%loc_to_glob(i) + call psb_loc_to_glob(i,idx,desc_a,info) locx(i,jlocx+j-1)=globx(idx,jglobx+j-1) end do end do @@ -157,13 +157,18 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot) call psb_get_rank(rootrank,ictxt,root) ! root has to gather size information - allocate(displ(np),all_dim(np),stat=info) + allocate(displ(np),all_dim(np),ltg(nrow),stat=info) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + call mpi_gather(nrow,1,mpi_integer,all_dim,& & 1,mpi_integer,rootrank,icomm,info) @@ -184,7 +189,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot) end if - call mpi_gatherv(desc_a%idxmap%loc_to_glob,nrow,& + call mpi_gatherv(ltg,nrow,& & mpi_integer,l_t_g_all,all_dim,& & displ,mpi_integer,rootrank,icomm,info) @@ -296,7 +301,7 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) & ilocx, jlocx, lda_locx, lda_globx, root, k, icomm, myrank,& & rootrank, pos, ilx, jlx real(psb_dpk_), allocatable :: scatterv(:) - integer, allocatable :: displ(:), l_t_g_all(:), all_dim(:) + integer, allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) character(len=20) :: name, ch_err integer :: debug_level, debug_unit @@ -366,14 +371,19 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) if ((root == -1).or.(np == 1)) then ! extract my chunk do i=1, nrow - idx=desc_a%idxmap%loc_to_glob(i) + call psb_loc_to_glob(i,idx,desc_a,info) locx(i)=globx(idx) end do else call psb_get_rank(rootrank,ictxt,root) ! root has to gather size information - allocate(displ(np),all_dim(np)) + allocate(displ(np),all_dim(np),ltg(nrow)) + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + call mpi_gather(nrow,1,mpi_integer,all_dim,& & 1,mpi_integer,rootrank,icomm,info) @@ -392,7 +402,7 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim))) end if - call mpi_gatherv(desc_a%idxmap%loc_to_glob,nrow,& + call mpi_gatherv(ltg,nrow,& & mpi_integer,l_t_g_all,all_dim,& & displ,mpi_integer,rootrank,icomm,info) diff --git a/base/comm/psb_igather.f90 b/base/comm/psb_igather.f90 index 53ff66d1..af5a683f 100644 --- a/base/comm/psb_igather.f90 +++ b/base/comm/psb_igather.f90 @@ -116,7 +116,8 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) - call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) + if (info == psb_success_) & + & call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' @@ -134,16 +135,17 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot) do j=1,k do i=1,psb_cd_get_local_rows(desc_a) - idx = desc_a%idxmap%loc_to_glob(i) + call psb_loc_to_glob(i,idx,desc_a,info) globx(idx,jglobx+j-1) = locx(i,jlx+j-1) end do end do + do j=1,k ! adjust overlapped elements do i=1, size(desc_a%ovrlap_elem,1) if (me /= desc_a%ovrlap_elem(i,3)) then idx = desc_a%ovrlap_elem(i,1) - idx = desc_a%idxmap%loc_to_glob(idx) + call psb_loc_to_glob(idx,desc_a,info) globx(idx,jglobx+j-1) = izero end if end do @@ -249,15 +251,15 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot) endif if (present(iroot)) then - root = iroot - if((root < -1).or.(root > np)) then - info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + int_err(1:2)=(/5,root/) + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if else - root = -1 + root = -1 end if jglobx=1 @@ -277,34 +279,37 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) - call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + if (info == psb_success_) & + & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 end if globx(:)=0 do i=1,psb_cd_get_local_rows(desc_a) - idx = desc_a%idxmap%loc_to_glob(i) - globx(idx) = locx(i) + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx) = locx(i) end do + ! adjust overlapped elements do i=1, size(desc_a%ovrlap_elem,1) if (me /= desc_a%ovrlap_elem(i,3)) then idx = desc_a%ovrlap_elem(i,1) - idx = desc_a%idxmap%loc_to_glob(idx) - globx(idx) = dzero + call psb_loc_to_glob(idx,desc_a,info) + globx(idx) = izero end if end do + call psb_sum(ictxt,globx(1:m),root=root) call psb_erractionrestore(err_act) @@ -314,8 +319,8 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot) call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return diff --git a/base/comm/psb_iscatter.F90 b/base/comm/psb_iscatter.F90 index 667933e3..524c1227 100644 --- a/base/comm/psb_iscatter.F90 +++ b/base/comm/psb_iscatter.F90 @@ -65,7 +65,7 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot) & ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,& & jlx, myrank, rootrank, c, pos integer, allocatable :: scatterv(:) - integer, allocatable :: displ(:), l_t_g_all(:), all_dim(:) + integer, allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) character(len=20) :: name, ch_err name='psb_scatterm' @@ -147,7 +147,7 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot) ! extract my chunk do j=1,k do i=1, nrow - idx = desc_a%idxmap%loc_to_glob(i) + call psb_loc_to_glob(i,idx,desc_a,info) locx(i,jlocx+j-1)=globx(idx,jglobx+j-1) end do end do @@ -155,13 +155,18 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot) call psb_get_rank(rootrank,ictxt,root) ! root has to gather size information - allocate(displ(np),all_dim(np),stat=info) + allocate(displ(np),all_dim(np),ltg(nrow),stat=info) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + call mpi_gather(nrow,1,mpi_integer,all_dim,& & 1,mpi_integer,rootrank,icomm,info) @@ -182,7 +187,7 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot) end if - call mpi_gatherv(desc_a%idxmap%loc_to_glob,nrow,& + call mpi_gatherv(ltg,nrow,& & mpi_integer,l_t_g_all,all_dim,& & displ,mpi_integer,rootrank,icomm,info) @@ -293,7 +298,7 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot) & ilocx, jlocx, lda_locx, lda_globx, root, k, icomm, myrank,& & rootrank, pos, ilx, jlx integer, allocatable :: scatterv(:) - integer, allocatable :: displ(:), l_t_g_all(:), all_dim(:) + integer, allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) character(len=20) :: name, ch_err integer :: debug_level, debug_unit @@ -363,14 +368,19 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot) if ((root == -1).or.(np == 1)) then ! extract my chunk do i=1, nrow - idx=desc_a%idxmap%loc_to_glob(i) + call psb_loc_to_glob(i,idx,desc_a,info) locx(i)=globx(idx) end do else call psb_get_rank(rootrank,ictxt,root) ! root has to gather size information - allocate(displ(np),all_dim(np)) + allocate(displ(np),all_dim(np),ltg(nrow)) + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + call mpi_gather(nrow,1,mpi_integer,all_dim,& & 1,mpi_integer,rootrank,icomm,info) @@ -389,7 +399,7 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot) allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim))) end if - call mpi_gatherv(desc_a%idxmap%loc_to_glob,nrow,& + call mpi_gatherv(ltg,nrow,& & mpi_integer,l_t_g_all,all_dim,& & displ,mpi_integer,rootrank,icomm,info) diff --git a/base/comm/psb_sgather.f90 b/base/comm/psb_sgather.f90 index 237d8f31..648c3735 100644 --- a/base/comm/psb_sgather.f90 +++ b/base/comm/psb_sgather.f90 @@ -116,7 +116,8 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) - call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) + if (info == psb_success_) & + & call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' @@ -134,16 +135,17 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) do j=1,k do i=1,psb_cd_get_local_rows(desc_a) - idx = desc_a%idxmap%loc_to_glob(i) + call psb_loc_to_glob(i,idx,desc_a,info) globx(idx,jglobx+j-1) = locx(i,jlx+j-1) end do end do + do j=1,k ! adjust overlapped elements do i=1, size(desc_a%ovrlap_elem,1) if (me /= desc_a%ovrlap_elem(i,3)) then idx = desc_a%ovrlap_elem(i,1) - idx = desc_a%idxmap%loc_to_glob(idx) + call psb_loc_to_glob(idx,desc_a,info) globx(idx,jglobx+j-1) = szero end if end do @@ -249,15 +251,15 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) endif if (present(iroot)) then - root = iroot - if((root < -1).or.(root > np)) then - info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + int_err(1:2)=(/5,root/) + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if else - root = -1 + root = -1 end if jglobx=1 @@ -277,35 +279,37 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) - call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + if (info == psb_success_) & + & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 end if globx(:)=0.d0 do i=1,psb_cd_get_local_rows(desc_a) - idx = desc_a%idxmap%loc_to_glob(i) - globx(idx) = locx(i) + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx) = locx(i) end do ! adjust overlapped elements do i=1, size(desc_a%ovrlap_elem,1) if (me /= desc_a%ovrlap_elem(i,3)) then idx = desc_a%ovrlap_elem(i,1) - idx = desc_a%idxmap%loc_to_glob(idx) + call psb_loc_to_glob(idx,desc_a,info) globx(idx) = szero end if end do + call psb_sum(ictxt,globx(1:m),root=root) call psb_erractionrestore(err_act) @@ -315,8 +319,8 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return diff --git a/base/comm/psb_sscatter.F90 b/base/comm/psb_sscatter.F90 index 3610489f..2df4bbe1 100644 --- a/base/comm/psb_sscatter.F90 +++ b/base/comm/psb_sscatter.F90 @@ -67,7 +67,7 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot) & ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,& & jlx, myrank, rootrank, c, pos real(psb_spk_), allocatable :: scatterv(:) - integer, allocatable :: displ(:), l_t_g_all(:), all_dim(:) + integer, allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) character(len=20) :: name, ch_err name='psb_scatterm' @@ -149,7 +149,7 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot) ! extract my chunk do j=1,k do i=1, nrow - idx = desc_a%idxmap%loc_to_glob(i) + call psb_loc_to_glob(i,idx,desc_a,info) locx(i,jlocx+j-1)=globx(idx,jglobx+j-1) end do end do @@ -157,13 +157,18 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot) call psb_get_rank(rootrank,ictxt,root) ! root has to gather size information - allocate(displ(np),all_dim(np),stat=info) + allocate(displ(np),all_dim(np),ltg(nrow),stat=info) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + call mpi_gather(nrow,1,mpi_integer,all_dim,& & 1,mpi_integer,rootrank,icomm,info) @@ -184,7 +189,7 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot) end if - call mpi_gatherv(desc_a%idxmap%loc_to_glob,nrow,& + call mpi_gatherv(ltg,nrow,& & mpi_integer,l_t_g_all,all_dim,& & displ,mpi_integer,rootrank,icomm,info) @@ -295,7 +300,7 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot) & ilocx, jlocx, lda_locx, lda_globx, root, k, icomm, myrank,& & rootrank, pos, ilx, jlx real(psb_spk_), allocatable :: scatterv(:) - integer, allocatable :: displ(:), l_t_g_all(:), all_dim(:) + integer, allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) character(len=20) :: name, ch_err integer :: debug_level, debug_unit @@ -365,14 +370,19 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot) if ((root == -1).or.(np == 1)) then ! extract my chunk do i=1, nrow - idx=desc_a%idxmap%loc_to_glob(i) + call psb_loc_to_glob(i,idx,desc_a,info) locx(i)=globx(idx) end do else call psb_get_rank(rootrank,ictxt,root) ! root has to gather size information - allocate(displ(np),all_dim(np)) + allocate(displ(np),all_dim(np),ltg(nrow)) + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + call mpi_gather(nrow,1,mpi_integer,all_dim,& & 1,mpi_integer,rootrank,icomm,info) @@ -391,7 +401,7 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot) allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim))) end if - call mpi_gatherv(desc_a%idxmap%loc_to_glob,nrow,& + call mpi_gatherv(ltg,nrow,& & mpi_integer,l_t_g_all,all_dim,& & displ,mpi_integer,rootrank,icomm,info) diff --git a/base/comm/psb_zgather.f90 b/base/comm/psb_zgather.f90 index 71d50815..34954181 100644 --- a/base/comm/psb_zgather.f90 +++ b/base/comm/psb_zgather.f90 @@ -109,7 +109,6 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) lock=size(locx,2)-jlocx+1 globk=size(globx,2)-jglobx+1 maxk=min(lock,globk) - k = maxk call psb_bcast(ictxt,k,root=iiroot) @@ -136,7 +135,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) do j=1,k do i=1,psb_cd_get_local_rows(desc_a) - idx = desc_a%idxmap%loc_to_glob(i) + call psb_loc_to_glob(i,idx,desc_a,info) globx(idx,jglobx+j-1) = locx(i,jlx+j-1) end do end do @@ -146,11 +145,12 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) do i=1, size(desc_a%ovrlap_elem,1) if (me /= desc_a%ovrlap_elem(i,3)) then idx = desc_a%ovrlap_elem(i,1) - idx = desc_a%idxmap%loc_to_glob(idx) + call psb_loc_to_glob(idx,desc_a,info) globx(idx,jglobx+j-1) = zzero end if end do end do + call psb_sum(ictxt,globx(1:m,jglobx:jglobx+k-1),root=root) call psb_erractionrestore(err_act) @@ -298,19 +298,20 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) globx(:)=0.d0 do i=1,psb_cd_get_local_rows(desc_a) - idx = desc_a%idxmap%loc_to_glob(i) + call psb_loc_to_glob(i,idx,desc_a,info) globx(idx) = locx(i) end do + ! adjust overlapped elements do i=1, size(desc_a%ovrlap_elem,1) if (me /= desc_a%ovrlap_elem(i,3)) then idx = desc_a%ovrlap_elem(i,1) - idx = desc_a%idxmap%loc_to_glob(idx) - globx(idx) = dzero + call psb_loc_to_glob(idx,desc_a,info) + globx(idx) = zzero end if end do - call psb_sum(ictxt,globx(1:m),root=root) + call psb_sum(ictxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return diff --git a/base/comm/psb_zscatter.F90 b/base/comm/psb_zscatter.F90 index fbbf52a2..0998b66d 100644 --- a/base/comm/psb_zscatter.F90 +++ b/base/comm/psb_zscatter.F90 @@ -66,7 +66,7 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot) & ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,& & jlx, myrank, rootrank, c, pos complex(psb_dpk_),allocatable :: scatterv(:) - integer, allocatable :: displ(:), l_t_g_all(:), all_dim(:) + integer, allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) character(len=20) :: name, ch_err name='psb_scatterm' @@ -148,7 +148,7 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot) ! extract my chunk do j=1,k do i=1, nrow - idx = desc_a%idxmap%loc_to_glob(i) + call psb_loc_to_glob(i,idx,desc_a,info) locx(i,jlocx+j-1)=globx(idx,jglobx+j-1) end do end do @@ -156,13 +156,18 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot) call psb_get_rank(rootrank,ictxt,root) ! root has to gather size information - allocate(displ(np),all_dim(np),stat=info) + allocate(displ(np),all_dim(np),ltg(nrow),stat=info) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + call mpi_gather(nrow,1,mpi_integer,all_dim,& & 1,mpi_integer,rootrank,icomm,info) @@ -183,7 +188,7 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot) end if - call mpi_gatherv(desc_a%idxmap%loc_to_glob,nrow,& + call mpi_gatherv(ltg,nrow,& & mpi_integer,l_t_g_all,all_dim,& & displ,mpi_integer,rootrank,icomm,info) @@ -294,7 +299,7 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot) & ilocx, jlocx, lda_locx, lda_globx, root, k, icomm, myrank,& & rootrank, pos, ilx, jlx complex(psb_dpk_), allocatable :: scatterv(:) - integer, allocatable :: displ(:), l_t_g_all(:), all_dim(:) + integer, allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) character(len=20) :: name, ch_err integer :: debug_level, debug_unit @@ -364,14 +369,19 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot) if ((root == -1).or.(np == 1)) then ! extract my chunk do i=1, nrow - idx=desc_a%idxmap%loc_to_glob(i) + call psb_loc_to_glob(i,idx,desc_a,info) locx(i)=globx(idx) end do else call psb_get_rank(rootrank,ictxt,root) ! root has to gather size information - allocate(displ(np),all_dim(np)) + allocate(displ(np),all_dim(np),ltg(nrow)) + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + call mpi_gather(nrow,1,mpi_integer,all_dim,& & 1,mpi_integer,rootrank,icomm,info) @@ -390,7 +400,7 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot) allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim))) end if - call mpi_gatherv(desc_a%idxmap%loc_to_glob,nrow,& + call mpi_gatherv(ltg,nrow,& & mpi_integer,l_t_g_all,all_dim,& & displ,mpi_integer,rootrank,icomm,info) diff --git a/base/internals/Makefile b/base/internals/Makefile index 17a199ff..a1554429 100644 --- a/base/internals/Makefile +++ b/base/internals/Makefile @@ -3,9 +3,10 @@ include ../../Make.inc 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_sort_dl.o \ - psi_ldsc_pre_halo.o psi_bld_tmphalo.o psi_bld_g2lmap.o\ + psi_ldsc_pre_halo.o psi_bld_tmphalo.o\ psi_sort_dl.o psi_idx_cnv.o psi_idx_ins_cnv.o \ psi_desc_impl.o psi_ovrl_restr.o psi_ovrl_save.o psi_ovrl_upd.o + FOBJS2 = psi_exist_ovr_elem.o psi_list_search.o srtlist.o #COBJS = avltree.o srcht.o @@ -14,7 +15,8 @@ MPFOBJS = psi_dswapdata.o psi_dswaptran.o\ psi_iswapdata.o psi_iswaptran.o \ psi_cswapdata.o psi_cswaptran.o \ psi_zswapdata.o psi_zswaptran.o \ - psi_desc_index.o psi_extrct_dl.o psi_fnd_owner.o + psi_desc_index.o psi_extrct_dl.o \ + psi_fnd_owner.o psb_indx_map_fnd_owner.o LIBDIR=.. MODDIR=../modules FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG)$(MODDIR) $(FMFLAG). diff --git a/base/internals/psb_indx_map_fnd_owner.F90 b/base/internals/psb_indx_map_fnd_owner.F90 new file mode 100644 index 00000000..55d65c34 --- /dev/null +++ b/base/internals/psb_indx_map_fnd_owner.F90 @@ -0,0 +1,298 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.0 +!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! File: psi_fnd_owner.f90 +! +! Subroutine: psi_fnd_owner +! Figure out who owns global indices. +! +! Arguments: +! nv - integer Number of indices required on the calling +! process +! idx(:) - integer Required indices on the calling process. +! Note: the indices should be unique! +! iprc(:) - integer, allocatable Output: process identifiers for the corresponding +! indices +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code. +! +subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info) + use psb_serial_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + use psb_realloc_mod + use psb_indx_map_mod, psb_protect_name => psb_indx_map_fnd_owner +#ifdef MPI_MOD + use mpi +#endif + + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: idx(:) + integer, allocatable, intent(out) :: iprc(:) + class(psb_indx_map), intent(in) :: idxmap + integer, intent(out) :: info + + + integer, allocatable :: hsz(:),hidx(:),helem(:),hproc(:),& + & sdsz(:),sdidx(:), rvsz(:), rvidx(:),answers(:,:),idxsrch(:,:) + + integer :: i,n_row,n_col,err_act,ih,icomm,hsize,ip,isz,k,j,& + & last_ih, last_j, nv + integer :: ictxt,np,me + logical, parameter :: gettime=.false. + real(psb_dpk_) :: t0, t1, t2, t3, t4, tamx, tidx + character(len=20) :: name + + info = psb_success_ + name = 'psb_indx_map_fnd_owner' + call psb_erractionsave(err_act) + + ictxt = idxmap%get_ctxt() + icomm = idxmap%get_mpic() + n_row = idxmap%get_lr() + n_col = idxmap%get_lc() + + + call psb_info(ictxt, me, np) + + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.(idxmap%is_valid())) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='invalid idxmap') + goto 9999 + end if + + if (gettime) then + t0 = psb_wtime() + end if + + nv = size(idx) + ! + ! The basic idea is very simple. + ! First we collect (to all) all the requests. + Allocate(hidx(np+1),hsz(np),& + & sdsz(0:np-1),sdidx(0:np-1),& + & rvsz(0:np-1),rvidx(0:np-1),& + & stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + hsz = 0 + hsz(me+1) = nv + call psb_amx(ictxt,hsz) + hidx(1) = 0 + do i=1, np + hidx(i+1) = hidx(i) + hsz(i) + end do + hsize = hidx(np+1) + Allocate(helem(hsize),hproc(hsize),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + if (gettime) then + t3 = psb_wtime() + end if + + call mpi_allgatherv(idx,hsz(me+1),mpi_integer,& + & hproc,hsz,hidx,mpi_integer,& + & icomm,info) + if (gettime) then + tamx = psb_wtime() - t3 + end if + + ! Second, we figure out locally whether we own the indices (whoever is + ! asking for them). + if (gettime) then + t3 = psb_wtime() + end if + + call idxmap%g2l(hproc(1:hsize),helem(1:hsize),info,owned=.true.) + if (gettime) then + tidx = psb_wtime()-t3 + end if + if (info == psb_err_iarray_outside_bounds_) info = psb_success_ + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_idx_cnv') + goto 9999 + end if + + ! Third: we build the answers for those indices we own, + ! with a section for each process asking. + hidx = hidx +1 + j = 0 + do ip = 0, np-1 + sdidx(ip) = j + sdsz(ip) = 0 + do i=hidx(ip+1), hidx(ip+1+1)-1 + if ((0 < helem(i)).and. (helem(i) <= n_row)) then + j = j + 1 + hproc(j) = hproc(i) + sdsz(ip) = sdsz(ip) + 1 + end if + end do + end do + + if (gettime) then + t3 = psb_wtime() + end if + + ! Collect all the answers with alltoallv (need sizes) + call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) + + isz = sum(rvsz) + + allocate(answers(isz,2),idxsrch(nv,2),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + j = 0 + do ip=0, np-1 + rvidx(ip) = j + j = j + rvsz(ip) + end do + call mpi_alltoallv(hproc,sdsz,sdidx,mpi_integer,& + & answers(:,1),rvsz,rvidx,mpi_integer,& + & icomm,info) + if (gettime) then + tamx = psb_wtime() - t3 + tamx + end if + j = 1 + do ip = 0,np-1 + do k=1,rvsz(ip) + answers(j,2) = ip + j = j + 1 + end do + end do + ! Sort the answers and the requests, so we can + ! match them efficiently + call psb_msort(answers(:,1),ix=answers(:,2),& + & flag=psb_sort_keep_idx_) + idxsrch(1:nv,1) = idx(1:nv) + 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 + do i=1, nv + ih = idxsrch(i,1) + if (ih == last_ih) then + iprc(idxsrch(i,2)) = answers(last_j,2) + else + + do + if (j > size(answers,1)) then + ! Last resort attempt. + j = psb_ibsrch(ih,size(answers,1),answers(:,1)) + if (j == -1) then + write(psb_err_unit,*) me,'psi_fnd_owner: searching for ',ih, & + & 'not found : ',size(answers,1),':',answers(:,1) + info = psb_err_internal_error_ + call psb_errpush(psb_err_internal_error_,name,a_err='out bounds srch ih') + goto 9999 + end if + end if + if (answers(j,1) == ih) exit + if (answers(j,1) > ih) then + k = j + j = psb_ibsrch(ih,k,answers(1:k,1)) + if (j == -1) then + write(psb_err_unit,*) me,'psi_fnd_owner: searching for ',ih, & + & 'not found : ',size(answers,1),':',answers(:,1) + info = psb_err_internal_error_ + call psb_errpush(psb_err_internal_error_,name,a_err='out bounds srch ih') + goto 9999 + end if + end if + + j = j + 1 + end do + ! Note that the answers here are given in order + ! of sending process, so we are implicitly getting + ! the max process index in case of overlap. + last_ih = ih + do + last_j = j + iprc(idxsrch(i,2)) = answers(j,2) + j = j + 1 + if (j > size(answers,1)) exit + if (answers(j,1) /= ih) exit + end do + end if + end do + + if (gettime) then + call psb_barrier(ictxt) + t1 = psb_wtime() + t1 = t1 -t0 - tamx - tidx + call psb_amx(ictxt,tamx) + call psb_amx(ictxt,tidx) + call psb_amx(ictxt,t1) + if (me == psb_root_) then + write(psb_out_unit,'(" fnd_owner idx time : ",es10.4)') tidx + write(psb_out_unit,'(" fnd_owner amx time : ",es10.4)') tamx + write(psb_out_unit,'(" fnd_owner remainedr : ",es10.4)') t1 + endif + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error(ictxt) + end if + return + +end subroutine psb_indx_map_fnd_owner diff --git a/base/internals/psi_bld_g2lmap.f90 b/base/internals/psi_bld_g2lmap.f90 deleted file mode 100644 index d44df9db..00000000 --- a/base/internals/psi_bld_g2lmap.f90 +++ /dev/null @@ -1,165 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 3.0 -!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari CNRS-IRIT, Toulouse -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! File: psi_bld_hash.f90 -! -! Subroutine: psi_bld_hash -! Build a hashed list of ordered sublists of the indices -! contained in loc_to_glob. -! -! -! Arguments: -! desc - type(psb_desc_type). The communication descriptor. -! info - integer. return code. -! -subroutine psi_bld_g2lmap(desc,info) - use psb_descriptor_type - use psb_serial_mod - use psb_const_mod - use psb_error_mod - use psb_penv_mod - use psb_realloc_mod - use psi_mod, psb_protect_name => psi_bld_g2lmap - implicit none - type(psb_desc_type), intent(inout) :: desc - integer, intent(out) :: info - - integer :: i,j,np,me,lhalo,nhalo,nbits,hsize,hmask,& - & n_col, err_act, key, ih, nh, idx, nk,icomm - integer :: ictxt,n_row - character(len=20) :: name,ch_err - - info = psb_success_ - name = 'psi_bld_g2lmap' - call psb_erractionsave(err_act) - - ictxt = psb_cd_get_context(desc) - icomm = psb_cd_get_mpic(desc) - n_row = psb_cd_get_local_rows(desc) - n_col = psb_cd_get_local_cols(desc) - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - - if (.not.(psb_is_bld_desc(desc).and.psb_is_large_desc(desc))) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - end if - - - nk = n_col - call psb_realloc(nk,2,desc%idxmap%glb_lc,info) - - nbits = psb_hash_bits - hsize = 2**nbits - do - if (hsize < 0) then - ! This should never happen for sane values - ! of psb_max_hash_bits. - write(psb_err_unit,*) 'Error: hash size overflow ',hsize,nbits - info = -2 - return - end if - if (hsize > nk) exit - if (nbits >= psb_max_hash_bits) exit - nbits = nbits + 1 - hsize = hsize * 2 - end do - hmask = hsize - 1 - desc%idxmap%hashvsize = hsize - desc%idxmap%hashvmask = hmask - if (info == psb_success_) call psb_realloc(hsize+1,desc%idxmap%hashv,info,lb=0) - if (info /= psb_success_) then - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - ! Build a hashed table of sorted lists to search for - ! indices. - desc%idxmap%hashv(0:hsize) = 0 - do i=1, nk - key = desc%idxmap%loc_to_glob(i) - ih = iand(key,hmask) - desc%idxmap%hashv(ih) = desc%idxmap%hashv(ih) + 1 - end do - nh = desc%idxmap%hashv(0) - idx = 1 - do i=1, hsize - desc%idxmap%hashv(i-1) = idx - idx = idx + nh - nh = desc%idxmap%hashv(i) - end do - do i=1, nk - key = desc%idxmap%loc_to_glob(i) - ih = iand(key,hmask) - idx = desc%idxmap%hashv(ih) - desc%idxmap%glb_lc(idx,1) = key - desc%idxmap%glb_lc(idx,2) = i - desc%idxmap%hashv(ih) = desc%idxmap%hashv(ih) + 1 - end do - do i = hsize, 1, -1 - desc%idxmap%hashv(i) = desc%idxmap%hashv(i-1) - end do - desc%idxmap%hashv(0) = 1 - do i=0, hsize-1 - idx = desc%idxmap%hashv(i) - nh = desc%idxmap%hashv(i+1) - desc%idxmap%hashv(i) - if (nh > 1) then - call psb_msort(desc%idxmap%glb_lc(idx:idx+nh-1,1),& - & ix=desc%idxmap%glb_lc(idx:idx+nh-1,2),& - & flag=psb_sort_keep_idx_) - end if - end do - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error(ictxt) - end if - return - - -end subroutine psi_bld_g2lmap diff --git a/base/internals/psi_bld_tmphalo.f90 b/base/internals/psi_bld_tmphalo.f90 index 1806649b..2a32c2a1 100644 --- a/base/internals/psi_bld_tmphalo.f90 +++ b/base/internals/psi_bld_tmphalo.f90 @@ -81,7 +81,7 @@ subroutine psi_bld_tmphalo(desc,info) goto 9999 endif - if (.not.(psb_is_bld_desc(desc).and.psb_is_large_desc(desc))) then + if (.not.(psb_is_bld_desc(desc).and.allocated(desc%indxmap))) then info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 @@ -100,10 +100,9 @@ subroutine psi_bld_tmphalo(desc,info) helem(i) = n_row+i ! desc%loc_to_glob(n_row+i) end do - call psb_map_l2g(helem(1:nh),desc%idxmap,info) - if (info == psb_success_) & - & call psi_fnd_owner(nh,helem,hproc,desc,info) - + call desc%indxmap%l2g(helem(1:nh),info) + call desc%indxmap%fnd_owner(helem(1:nh),hproc,info) + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='fnd_owner') goto 9999 diff --git a/base/internals/psi_crea_index.f90 b/base/internals/psi_crea_index.f90 index 63542421..5222ddec 100644 --- a/base/internals/psi_crea_index.f90 +++ b/base/internals/psi_crea_index.f90 @@ -81,7 +81,8 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = psb_cd_get_context(desc_a) + ictxt = desc_a%indxmap%get_ctxt() + call psb_info(ictxt,me,np) if (np == -1) then info = psb_err_context_error_ @@ -106,9 +107,10 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info & write(debug_unit,*) me,' ',trim(name),': calling extract_dep_list' mode = 1 - call psi_extract_dep_list(desc_a%matrix_data,index_in,& - & dep_list,length_dl,np,max(1,dl_lda),mode,info) - if(info /= psb_success_) then + call psi_extract_dep_list(desc_a%indxmap%get_ctxt(),& + & desc_a%indxmap%is_bld(), desc_a%indxmap%is_upd(),& + & index_in, dep_list,length_dl,np,max(1,dl_lda),mode,info) + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='extrct_dl') goto 9999 end if diff --git a/base/internals/psi_desc_index.F90 b/base/internals/psi_desc_index.F90 index 1b94fb1f..60e5d651 100644 --- a/base/internals/psi_desc_index.F90 +++ b/base/internals/psi_desc_index.F90 @@ -142,8 +142,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = psb_cd_get_context(desc) - icomm = psb_cd_get_mpic(desc) + ictxt = desc%indxmap%get_ctxt() + icomm = desc%indxmap%get_mpic() call psb_info(ictxt,me,np) if (np == -1) then info = psb_err_context_error_ @@ -257,11 +257,13 @@ subroutine psi_desc_index(desc,index_in,dep_list,& sndbuf(bsdindx(proc+1)+j) = (index_in(i+j)) end do else - call psb_map_l2g(index_in(i+1:i+nerv),& + + call desc%indxmap%l2g(index_in(i+1:i+nerv),& & sndbuf(bsdindx(proc+1)+1:bsdindx(proc+1)+nerv),& - & desc%idxmap,info) + & info) + if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_map_l2g') + call psb_errpush(psb_err_from_subroutine_,name,a_err='l2g') goto 9999 end if @@ -307,6 +309,7 @@ subroutine psi_desc_index(desc,index_in,dep_list,& desc_index(i) = nerv call psi_idx_cnv(nerv,sndbuf(bsdindx(proc+1)+1:bsdindx(proc+1)+nerv),& & desc_index(i+1:i+nerv),desc,info) + i = i + nerv + 1 nesd = rvsz(proc+1) desc_index(i) = nesd diff --git a/base/internals/psi_extrct_dl.F90 b/base/internals/psi_extrct_dl.F90 index 1e0f4645..54640bfd 100644 --- a/base/internals/psi_extrct_dl.F90 +++ b/base/internals/psi_extrct_dl.F90 @@ -29,7 +29,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,& +subroutine psi_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& & length_dl,np,dl_lda,mode,info) ! internal routine @@ -131,17 +131,18 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,& include 'mpif.h' #endif ! ....scalar parameters... - integer np,dl_lda,mode, info + logical :: is_bld, is_upd + integer np,dl_lda,mode, info, ictxt ! ....array parameters.... - integer :: desc_str(*),desc_data(*),dep_list(dl_lda,0:np),length_dl(0:np) + integer :: desc_str(*),dep_list(dl_lda,0:np),length_dl(0:np) integer, allocatable :: itmp(:) ! .....local arrays.... integer int_err(5) ! .....local scalars... integer i,me,nprow,pointer_dep_list,proc,j,err_act - integer ictxt, err, icomm + integer err, icomm integer :: debug_level, debug_unit character name*20 name='psi_extrct_dl' @@ -151,8 +152,6 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,& debug_level = psb_get_debug_level() info = psb_success_ - ictxt = desc_data(psb_ctxt_) - call psb_info(ictxt,me,nprow) do i=0,np @@ -160,10 +159,10 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,& enddo i=1 if (debug_level >= psb_debug_inner_)& - & write(debug_unit,*) me,' ',trim(name),': start ',info,desc_data(psb_dec_type_) + & write(debug_unit,*) me,' ',trim(name),': start ',info pointer_dep_list=1 - if (psb_is_bld_dec(desc_data(psb_dec_type_))) then + if (is_bld) then do while (desc_str(i) /= -1) if (debug_level >= psb_debug_inner_)& & write(debug_unit,*) me,' ',trim(name),' : looping ',i,& @@ -208,7 +207,7 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,& endif i=i+desc_str(i+1)+2 enddo - else if (psb_is_upd_dec(desc_data(psb_dec_type_))) then + else if (is_upd) then do while (desc_str(i) /= -1) if (debug_level >= psb_debug_inner_) & & write(debug_unit,*) me,' ',trim(name),': looping ',i,desc_str(i) diff --git a/base/internals/psi_fnd_owner.F90 b/base/internals/psi_fnd_owner.F90 index 8fb807e8..c223dc4e 100644 --- a/base/internals/psi_fnd_owner.F90 +++ b/base/internals/psi_fnd_owner.F90 @@ -108,187 +108,12 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info) goto 9999 end if - if (gettime) then - t0 = psb_wtime() - end if - ! - ! The basic idea is very simple. - ! First we collect (to all) all the requests. - Allocate(hidx(np+1),hsz(np),& - & sdsz(0:np-1),sdidx(0:np-1),& - & rvsz(0:np-1),rvidx(0:np-1),& - & stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - - hsz = 0 - hsz(me+1) = nv - call psb_amx(ictxt,hsz) - hidx(1) = 0 - do i=1, np - hidx(i+1) = hidx(i) + hsz(i) - end do - hsize = hidx(np+1) - Allocate(helem(hsize),hproc(hsize),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - - if (gettime) then - t3 = psb_wtime() - end if - - call mpi_allgatherv(idx,hsz(me+1),mpi_integer,& - & hproc,hsz,hidx,mpi_integer,& - & icomm,info) - if (gettime) then - tamx = psb_wtime() - t3 - end if - - ! Second, we figure out locally whether we own the indices (whoever is - ! asking for them). - if (gettime) then - t3 = psb_wtime() - end if - - call psi_idx_cnv(hsize,hproc,helem,desc,info,owned=.true.) - if (gettime) then - tidx = psb_wtime()-t3 - end if - if (info == psb_err_iarray_outside_bounds_) info = psb_success_ + call desc%indxmap%fnd_owner(idx(1:nv),iprc,info) + if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_idx_cnv') + call psb_errpush(psb_err_from_subroutine_,name,a_err='indxmap%fnd_owner') goto 9999 end if - - ! Third: we build the answers for those indices we own, - ! with a section for each process asking. - hidx = hidx +1 - j = 0 - do ip = 0, np-1 - sdidx(ip) = j - sdsz(ip) = 0 - do i=hidx(ip+1), hidx(ip+1+1)-1 - if ((0 < helem(i)).and. (helem(i) <= n_row)) then - j = j + 1 - hproc(j) = hproc(i) - sdsz(ip) = sdsz(ip) + 1 - end if - end do - end do - - if (gettime) then - t3 = psb_wtime() - end if - - ! Collect all the answers with alltoallv (need sizes) - call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) - - isz = sum(rvsz) - - allocate(answers(isz,2),idxsrch(nv,2),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - j = 0 - do ip=0, np-1 - rvidx(ip) = j - j = j + rvsz(ip) - end do - call mpi_alltoallv(hproc,sdsz,sdidx,mpi_integer,& - & answers(:,1),rvsz,rvidx,mpi_integer,& - & icomm,info) - if (gettime) then - tamx = psb_wtime() - t3 + tamx - end if - j = 1 - do ip = 0,np-1 - do k=1,rvsz(ip) - answers(j,2) = ip - j = j + 1 - end do - end do - ! Sort the answers and the requests, so we can - ! match them efficiently - call psb_msort(answers(:,1),ix=answers(:,2),& - & flag=psb_sort_keep_idx_) - idxsrch(1:nv,1) = idx(1:nv) - 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 - do i=1, nv - ih = idxsrch(i,1) - if (ih == last_ih) then - iprc(idxsrch(i,2)) = answers(last_j,2) - else - - do - if (j > size(answers,1)) then - ! Last resort attempt. - j = psb_ibsrch(ih,size(answers,1),answers(:,1)) - if (j == -1) then - write(psb_err_unit,*) me,'psi_fnd_owner: searching for ',ih, & - & 'not found : ',size(answers,1),':',answers(:,1) - info = psb_err_internal_error_ - call psb_errpush(psb_err_internal_error_,name,a_err='out bounds srch ih') - goto 9999 - end if - end if - if (answers(j,1) == ih) exit - if (answers(j,1) > ih) then - k = j - j = psb_ibsrch(ih,k,answers(1:k,1)) - if (j == -1) then - write(psb_err_unit,*) me,'psi_fnd_owner: searching for ',ih, & - & 'not found : ',size(answers,1),':',answers(:,1) - info = psb_err_internal_error_ - call psb_errpush(psb_err_internal_error_,name,a_err='out bounds srch ih') - goto 9999 - end if - end if - - j = j + 1 - end do - ! Note that the answers here are given in order - ! of sending process, so we are implicitly getting - ! the max process index in case of overlap. - last_ih = ih - do - last_j = j - iprc(idxsrch(i,2)) = answers(j,2) - j = j + 1 - if (j > size(answers,1)) exit - if (answers(j,1) /= ih) exit - end do - end if - end do - - if (gettime) then - call psb_barrier(ictxt) - t1 = psb_wtime() - t1 = t1 -t0 - tamx - tidx - call psb_amx(ictxt,tamx) - call psb_amx(ictxt,tidx) - call psb_amx(ictxt,t1) - if (me == psb_root_) then - write(psb_out_unit,'(" fnd_owner idx time : ",es10.4)') tidx - write(psb_out_unit,'(" fnd_owner amx time : ",es10.4)') tamx - write(psb_out_unit,'(" fnd_owner remainedr : ",es10.4)') t1 - endif - end if - call psb_erractionrestore(err_act) return diff --git a/base/internals/psi_idx_cnv.f90 b/base/internals/psi_idx_cnv.f90 index f5be88d8..55e3922c 100644 --- a/base/internals/psi_idx_cnv.f90 +++ b/base/internals/psi_idx_cnv.f90 @@ -61,6 +61,7 @@ subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned) integer :: ictxt,mglob, nglob,ip,lip,i integer :: np, me integer :: nrow,ncol, err_act + integer, allocatable :: itmp(:) integer, parameter :: relocsz=200 character(len=20) :: name logical :: owned_ @@ -77,8 +78,13 @@ subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned) call psb_info(ictxt, me, np) - if (.not.psb_is_ok_desc(desc)) then - info = psb_err_input_matrix_unassembled_ + if (.not.allocated(desc%indxmap))then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.psb_is_valid_desc(desc)) then + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -106,130 +112,13 @@ subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned) end if endif - if (present(owned)) then - owned_ = owned - else - owned_ = .false. - endif - - ! - ! The input descriptor may be in any state - ! - if (psb_is_large_desc(desc)) then - ! - ! Large descriptor: the size of the index space is such that - ! we decided not to allocate the glob_to_loc(:) map. - ! - if (psb_is_bld_desc(desc)) then - ! - ! During the build phase of a large descriptor the indices - ! are kept in an AVL tree. - ! - if (present(mask)) then - - do i = 1, nv - if (mask(i)) then - ip = idxin(i) - if ((ip < 1 ).or.(ip>mglob)) then - idxin(i) = -1 - cycle - endif - call psi_inner_cnv(ip,lip,desc%idxmap%hashvmask,desc%idxmap%hashv,desc%idxmap%glb_lc) - if (lip < 0) & - & call psb_hash_searchkey(ip,lip,desc%idxmap%hash,info) - if (owned_) then - if (lip<=nrow) then - idxin(i) = lip - else - idxin(i) = -1 - endif - else - idxin(i) = lip - endif - end if - enddo - else - do i = 1, nv - ip = idxin(i) - if ((ip < 1 ).or.(ip>mglob)) then - idxin(i) = -1 - cycle - endif - call psi_inner_cnv(ip,lip,desc%idxmap%hashvmask,desc%idxmap%hashv,desc%idxmap%glb_lc) - if (lip < 0) & - & call psb_hash_searchkey(ip,lip,desc%idxmap%hash,info) - if (owned_) then - if (lip<=nrow) then - idxin(i) = lip - else - idxin(i) = -1 - endif - else - idxin(i) = lip - endif - enddo - end if - else if (psb_is_asb_desc(desc)) then - ! - ! When a large descriptor is assembled the indices - ! are kept in a (hashed) list of ordered lists, - ! hence psi_inner_cnv does the hashing and binary search. - ! - if (.not.allocated(desc%idxmap%hashv)) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Invalid hashv into inner_cnv') - end if - call psi_inner_cnv(nv,idxin,desc%idxmap%hashvmask,desc%idxmap%hashv,desc%idxmap%glb_lc,mask=mask) - end if - - else + call desc%indxmap%g2l(idxin(1:nv),info,mask=mask,owned=owned) - ! - ! Not a large descriptor, so we have the glob_to_loc(:) map - ! available. - ! - if (present(mask)) then - do i = 1, nv - if (mask(i)) then - ip = idxin(i) - if ((ip < 1 ).or.(ip>mglob)) then - info = 1133 - call psb_errpush(info,name) - goto 9999 - endif - lip = desc%idxmap%glob_to_loc(ip) - if (owned_) then - if (lip<=nrow) then - idxin(i) = lip - else - idxin(i) = -1 - endif - else - idxin(i) = lip - endif - end if - enddo - else - do i = 1, nv - ip = idxin(i) - if ((ip < 1 ).or.(ip>mglob)) then - info = 1133 - call psb_errpush(info,name) - goto 9999 - endif - lip = desc%idxmap%glob_to_loc(ip) - if (owned_) then - if (lip<=nrow) then - idxin(i) = lip - else - idxin(i) = -1 - endif - else - idxin(i) = lip - endif - enddo - end if + if (info /= 0) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='g2l') + goto 9999 end if + call psb_erractionrestore(err_act) return @@ -323,10 +212,11 @@ subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned) nrow = psb_cd_get_local_rows(desc) ncol = psb_cd_get_local_cols(desc) + call psb_info(ictxt, me, np) if (.not.psb_is_ok_desc(desc)) then - info = psb_err_input_matrix_unassembled_ + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -350,7 +240,6 @@ subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned) goto 9999 end if - idxout(1:nv) = idxin(1:nv) call psi_idx_cnv1(nv,idxout,desc,info,mask=mask,owned=owned) diff --git a/base/internals/psi_idx_ins_cnv.f90 b/base/internals/psi_idx_ins_cnv.f90 index 70c37d32..c550768e 100644 --- a/base/internals/psi_idx_ins_cnv.f90 +++ b/base/internals/psi_idx_ins_cnv.f90 @@ -81,8 +81,9 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask) call psb_info(ictxt, me, np) - if (.not.psb_is_bld_desc(desc)) then - info = psb_err_input_matrix_unassembled_ + if ((.not.allocated(desc%indxmap)).or.& + & (.not.psb_is_bld_desc(desc))) then + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -110,234 +111,15 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask) end if endif - if (psb_is_large_desc(desc)) then - - if (present(mask)) then - do i = 1, nv - if (mask(i)) then - ip = idxin(i) - if ((ip < 1 ).or.(ip>mglob)) then - idxin(i) = -1 - cycle - endif - nxt = ncol + 1 - - call psi_inner_cnv(ip,lip,desc%idxmap%hashvmask,desc%idxmap%hashv,desc%idxmap%glb_lc) - if (lip < 0) & - & call psb_hash_searchinskey(ip,lip,nxt,desc%idxmap%hash,info) - if (info >=0) then - if (nxt == lip) then - ncol = nxt - isize = size(desc%idxmap%loc_to_glob) - if (ncol > isize) then - nh = ncol + max(nv,relocsz) - call psb_realloc(nh,desc%idxmap%loc_to_glob,info,pad=-1) - if (info /= psb_success_) then - info=1 - ch_err='psb_realloc' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - end if - isize = nh - endif - desc%idxmap%loc_to_glob(nxt) = ip - endif - info = psb_success_ - else - ch_err='SearchInsKeyVal' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - end if - idxin(i) = lip - info = psb_success_ - else - idxin(i) = -1 - end if - enddo - - else - - do i = 1, nv - ip = idxin(i) - if ((ip < 1 ).or.(ip>mglob)) then - idxin(i) = -1 - cycle - endif - nxt = ncol + 1 - - call psi_inner_cnv(ip,lip,desc%idxmap%hashvmask,desc%idxmap%hashv,desc%idxmap%glb_lc) - if (lip < 0) & - & call psb_hash_searchinskey(ip,lip,nxt,desc%idxmap%hash,info) - if (info >=0) then - if (nxt == lip) then - ncol = nxt - isize = size(desc%idxmap%loc_to_glob) - if (ncol > isize) then - nh = ncol + max(nv,relocsz) - call psb_realloc(nh,desc%idxmap%loc_to_glob,info,pad=-1) - if (info /= psb_success_) then - info=1 - ch_err='psb_realloc' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - end if - isize = nh - endif - desc%idxmap%loc_to_glob(nxt) = ip - endif - info = psb_success_ - else - ch_err='SearchInsKeyVal' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - end if - idxin(i) = lip - info = psb_success_ - enddo - endif - - else - - if (.not.allocated(desc%halo_index)) then - allocate(desc%halo_index(relocsz)) - desc%halo_index(:) = -1 - desc%matrix_data(psb_pnt_h_) = 1 - endif - pnt_halo = desc%matrix_data(psb_pnt_h_) - - pnt_h_ok = .false. - isize = size(desc%halo_index) - if ((1 <= pnt_halo).and.(pnt_halo <= isize)) then - if (desc%halo_index(pnt_halo) == -1 ) then - if (pnt_halo == 1) then - pnt_h_ok = .true. - else if (desc%halo_index(pnt_halo-1) /= -1 ) then - pnt_h_ok = .true. - end if - end if - end if - - if (.not.pnt_h_ok) then - pnt_halo = 1 - do - if (desc%halo_index(pnt_halo) == -1) exit - if (pnt_halo == isize) exit - pnt_halo = pnt_halo + 1 - end do - if (desc%halo_index(pnt_halo) /= -1) then - call psb_realloc(isize+relocsz,desc%halo_index,info,pad=-1) - pnt_halo = pnt_halo + 1 - end if - end if - - if (present(mask)) then - do i = 1, nv - if (mask(i)) then - ip = idxin(i) - if ((ip < 1 ).or.(ip>mglob)) then - idxin(i) = -1 - cycle - endif - k = desc%idxmap%glob_to_loc(ip) - if (k < -np) then - k = k + np - k = - k - 1 - ncol = ncol + 1 - lip = ncol - desc%idxmap%glob_to_loc(ip) = ncol - isize = size(desc%idxmap%loc_to_glob) - if (ncol > isize) then - nh = ncol + max(nv,relocsz) - call psb_realloc(nh,desc%idxmap%loc_to_glob,info,pad=-1) - if (info /= psb_success_) then - info=psb_err_invalid_ovr_num_ - ch_err='psb_realloc' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - end if - isize = nh - endif - desc%idxmap%loc_to_glob(ncol) = ip - isize = size(desc%halo_index) - if ((pnt_halo+3) > isize) then - nh = isize + max(nv,relocsz) - call psb_realloc(nh,desc%halo_index,info,pad=-1) - if (info /= psb_success_) then - info=4 - ch_err='psb_realloc' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - end if - isize = nh - endif - desc%halo_index(pnt_halo) = k - desc%halo_index(pnt_halo+1) = 1 - desc%halo_index(pnt_halo+2) = ncol - pnt_halo = pnt_halo + 3 - else - lip = k - endif - idxin(i) = lip - else - idxin(i) = -1 - end if - enddo - - else - - do i = 1, nv - ip = idxin(i) - if ((ip < 1 ).or.(ip>mglob)) then - idxin(i) = -1 - cycle - endif - k = desc%idxmap%glob_to_loc(ip) - if (k < -np) then - k = k + np - k = - k - 1 - ncol = ncol + 1 - lip = ncol - desc%idxmap%glob_to_loc(ip) = ncol - isize = size(desc%idxmap%loc_to_glob) - if (ncol > isize) then - nh = ncol + max(nv,relocsz) - call psb_realloc(nh,desc%idxmap%loc_to_glob,info,pad=-1) - if (info /= psb_success_) then - info=psb_err_invalid_ovr_num_ - ch_err='psb_realloc' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - end if - isize = nh - endif - desc%idxmap%loc_to_glob(ncol) = ip - isize = size(desc%halo_index) - if ((pnt_halo+3) > isize) then - nh = isize + max(nv,relocsz) - call psb_realloc(nh,desc%halo_index,info,pad=-1) - if (info /= psb_success_) then - info=4 - ch_err='psb_realloc' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - end if - isize = nh - endif - desc%halo_index(pnt_halo) = k - desc%halo_index(pnt_halo+1) = 1 - desc%halo_index(pnt_halo+2) = ncol - pnt_halo = pnt_halo + 3 - else - lip = k - endif - idxin(i) = lip - enddo - end if - desc%matrix_data(psb_pnt_h_) = pnt_halo + call desc%indxmap%g2l_ins(idxin(1:nv),info,mask) + + if (info /= 0) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='g2l_ins') + goto 9999 end if - - desc%matrix_data(psb_n_col_) = ncol + + desc%matrix_data(psb_n_col_) = desc%indxmap%get_lc() call psb_erractionrestore(err_act) return diff --git a/base/internals/psi_ldsc_pre_halo.f90 b/base/internals/psi_ldsc_pre_halo.f90 index dfd4ef9e..6cedb23a 100644 --- a/base/internals/psi_ldsc_pre_halo.f90 +++ b/base/internals/psi_ldsc_pre_halo.f90 @@ -81,26 +81,12 @@ subroutine psi_ldsc_pre_halo(desc,ext_hv,info) endif - if (.not.(psb_is_bld_desc(desc).and.psb_is_large_desc(desc))) then + if (.not.(psb_is_bld_desc(desc))) then info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 end if - call psi_bld_g2lmap(desc,info) - if (info /= psb_success_) then - ch_err='psi_bld_hash' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ! We no longer need the inner hash structure. - call psb_free(desc%idxmap%hash,info) - if (info /= psb_success_) then - ch_err='psi_bld_tmphalo' - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if if (.not.ext_hv) then call psi_bld_tmphalo(desc,info) if (info /= psb_success_) then diff --git a/base/modules/Makefile b/base/modules/Makefile index 2d35f3f4..b38708dd 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -1,7 +1,9 @@ include ../../Make.inc BASIC_MODS= psb_const_mod.o psb_error_mod.o psb_realloc_mod.o -UTIL_MODS = psb_string_mod.o \ +UTIL_MODS = psb_string_mod.o psb_desc_const_mod.o psb_indx_map_mod.o\ + psb_gen_block_map_mod.o psb_list_map_mod.o psb_repl_map_mod.o\ + psb_glist_map_mod.o psb_hash_map_mod.o \ psb_desc_type.o psb_sort_mod.o psb_serial_mod.o \ psb_base_tools_mod.o psb_s_tools_mod.o psb_d_tools_mod.o\ psb_c_tools_mod.o psb_z_tools_mod.o psb_tools_mod.o \ @@ -61,9 +63,19 @@ psb_ip_reord_mod.o: psb_const_mod.o psb_blacs_mod.o: psb_const_mod.o psi_serial_mod.o: psb_const_mod.o psb_realloc_mod.o psi_mod.o: psb_penv_mod.o psb_error_mod.o psb_desc_type.o psb_const_mod.o psi_serial_mod.o psb_serial_mod.o -psb_desc_type.o: psb_const_mod.o psb_error_mod.o psb_penv_mod.o psb_realloc_mod.o psb_hash_mod.o +psb_desc_type.o: psb_const_mod.o psb_error_mod.o psb_penv_mod.o psb_realloc_mod.o\ + psb_hash_mod.o psb_hash_map_mod.o psb_list_map_mod.o \ + psb_repl_map_mod.o psb_gen_block_map_mod.o psb_desc_const_mod.o\ + psb_indx_map_mod.o +psb_indx_map_mod.o: psb_desc_const_mod.o psb_const_mod.o +psb_hash_map_mod.o psb_list_map_mod.o psb_repl_map_mod.o psb_gen_block_map_mod.o:\ + psb_indx_map_mod.o \ + psb_desc_const_mod.o psb_const_mod.o psb_realloc_mod.o \ + psb_sort_mod.o psb_penv_mod.o psb_error_mod.o +psb_glist_map_mod.o: psb_list_map_mod.o +psb_hash_map_mod.o: psb_hash_mod.o psb_sort_mod.o psb_linmap_mod.o: psb_s_linmap_mod.o psb_d_linmap_mod.o psb_c_linmap_mod.o psb_z_linmap_mod.o - psb_s_linmap_mod.o psb_d_linmap_mod.o psb_c_linmap_mod.o psb_z_linmap_mod.o: psb_linmap_type_mod.o psb_mat_mod.o +psb_s_linmap_mod.o psb_d_linmap_mod.o psb_c_linmap_mod.o psb_z_linmap_mod.o: psb_linmap_type_mod.o psb_mat_mod.o psb_linmap_type_mod.o: psb_desc_type.o psb_error_mod.o psb_serial_mod.o psb_comm_mod.o psb_mat_mod.o psb_comm_mod.o: psb_desc_type.o psb_mat_mod.o psb_check_mod.o: psb_desc_type.o diff --git a/base/modules/psb_base_tools_mod.f90 b/base/modules/psb_base_tools_mod.f90 index d747c90b..d100a61e 100644 --- a/base/modules/psb_base_tools_mod.f90 +++ b/base/modules/psb_base_tools_mod.f90 @@ -299,8 +299,13 @@ end module psb_iv_tools_mod module psb_cd_if_tools_mod use psb_const_mod - - + use psb_descriptor_type + use psb_gen_block_map_mod + use psb_list_map_mod + use psb_glist_map_mod + use psb_hash_map_mod + use psb_repl_map_mod + interface psb_cd_set_bld subroutine psb_cd_set_bld(desc,info) use psb_descriptor_type @@ -336,7 +341,7 @@ module psb_cd_if_tools_mod !....parameters... type(psb_desc_type), intent(in) :: desc_in - type(psb_desc_type), intent(out) :: desc_out + type(psb_desc_type), intent(inout) :: desc_out integer, intent(out) :: info end subroutine psb_cdcpy end interface @@ -446,6 +451,15 @@ module psb_cd_tools_mod module procedure psb_get_boundary end interface + interface + subroutine psb_cd_switch_ovl_indxmap(desc,info) + use psb_descriptor_type + implicit None + include 'parts.fh' + type(psb_desc_type), intent(inout) :: desc + integer, intent(out) :: info + end subroutine psb_cd_switch_ovl_indxmap + end interface contains @@ -479,153 +493,3 @@ module psb_base_tools_mod end module psb_base_tools_mod - -subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalcheck) - use psb_descriptor_type - use psb_serial_mod - use psb_const_mod - use psb_error_mod - use psb_penv_mod - implicit None - include 'parts.fh' - Integer, intent(in) :: mg,ng,ictxt, vg(:), vl(:),nl - integer, intent(in) :: flag - logical, intent(in) :: repl, globalcheck - integer, intent(out) :: info - type(psb_desc_type), intent(out) :: desc - - optional :: mg,ng,parts,vg,vl,flag,nl,repl, globalcheck - - interface - subroutine psb_cdals(m, n, parts, ictxt, desc, info) - use psb_descriptor_type - include 'parts.fh' - Integer, intent(in) :: m,n,ictxt - Type(psb_desc_type), intent(out) :: desc - integer, intent(out) :: info - end subroutine psb_cdals - subroutine psb_cdalv(v, ictxt, desc, info, flag) - use psb_descriptor_type - Integer, intent(in) :: ictxt, v(:) - integer, intent(in), optional :: flag - integer, intent(out) :: info - Type(psb_desc_type), intent(out) :: desc - end subroutine psb_cdalv - subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) - use psb_descriptor_type - implicit None - Integer, intent(in) :: ictxt, v(:) - integer, intent(out) :: info - type(psb_desc_type), intent(out) :: desc - logical, intent(in), optional :: globalcheck - end subroutine psb_cd_inloc - subroutine psb_cdrep(m, ictxt, desc,info) - use psb_descriptor_type - Integer, intent(in) :: m,ictxt - Type(psb_desc_type), intent(out) :: desc - integer, intent(out) :: info - end subroutine psb_cdrep - end interface - character(len=20) :: name - integer :: err_act, n_, flag_, i, me, np, nlp, nnv - integer, allocatable :: itmpsz(:) - - - - if (psb_get_errstatus() /= 0) return - info=psb_success_ - name = 'psb_cdall' - call psb_erractionsave(err_act) - - call psb_info(ictxt, me, np) - - if (count((/ present(vg),present(vl),& - & present(parts),present(nl), present(repl) /)) /= 1) then - info=psb_err_no_optional_arg_ - call psb_errpush(info,name,a_err=" vg, vl, parts, nl, repl") - goto 999 - endif - - desc%base_desc => null() - - if (present(parts)) then - if (.not.present(mg)) then - info=psb_err_no_optional_arg_ - call psb_errpush(info,name) - goto 999 - end if - if (present(ng)) then - n_ = ng - else - n_ = mg - endif - call psb_cdals(mg, n_, parts, ictxt, desc, info) - - else if (present(repl)) then - if (.not.present(mg)) then - info=psb_err_no_optional_arg_ - call psb_errpush(info,name) - goto 999 - end if - if (.not.repl) then - info=psb_err_no_optional_arg_ - call psb_errpush(info,name) - goto 999 - end if - call psb_cdrep(mg, ictxt, desc, info) - - else if (present(vg)) then - if (present(flag)) then - flag_=flag - else - flag_=0 - endif - if (present(mg)) then - nnv = min(mg,size(vg)) - else - nnv = size(vg) - end if - call psb_cdalv(vg(1:nnv), ictxt, desc, info, flag=flag_) - - else if (present(vl)) then - if (present(nl)) then - nnv = min(nl,size(vl)) - else - nnv = size(vl) - end if - call psb_cd_inloc(vl(1:nnv),ictxt,desc,info, globalcheck=globalcheck) - - else if (present(nl)) then - allocate(itmpsz(0:np-1),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 999 - endif - - itmpsz = 0 - itmpsz(me) = nl - call psb_sum(ictxt,itmpsz) - nlp=0 - do i=0, me-1 - nlp = nlp + itmpsz(i) - end do - call psb_cd_inloc((/(i,i=nlp+1,nlp+nl)/),ictxt,desc,info,globalcheck=.false.) - - endif - - if (info /= psb_success_) goto 999 - - call psb_erractionrestore(err_act) - return - -999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - - -end subroutine psb_cdall diff --git a/base/modules/psb_desc_const_mod.f90 b/base/modules/psb_desc_const_mod.f90 new file mode 100644 index 00000000..34e10fd7 --- /dev/null +++ b/base/modules/psb_desc_const_mod.f90 @@ -0,0 +1,85 @@ +module psb_desc_const_mod + ! + ! Communication, prolongation & restriction + ! + integer, parameter :: psb_nohalo_=0, psb_halo_=1 + ! For overlap update. + integer, parameter :: psb_none_=0, psb_sum_=1 + integer, parameter :: psb_avg_=2, psb_square_root_=3 + integer, parameter :: psb_setzero_=4 + + ! The following are bit fields. + integer, parameter :: psb_swap_send_=1, psb_swap_recv_=2 + integer, parameter :: psb_swap_sync_=4, psb_swap_mpi_=8 + ! Choice among lists on which to base data exchange + integer, parameter :: psb_no_comm_=-1 + integer, parameter :: psb_comm_halo_=1, psb_comm_ovr_=2 + integer, parameter :: psb_comm_ext_=3, psb_comm_mov_=4 + ! Types of mapping between descriptors. + integer, parameter :: psb_map_xhal_ = 123 + integer, parameter :: psb_map_asov_ = psb_map_xhal_+1 + integer, parameter :: psb_map_aggr_ = psb_map_asov_+1 + integer, parameter :: psb_map_gen_linear_ = psb_map_aggr_+1 + + integer, parameter :: psb_ovt_xhal_ = psb_map_xhal_, psb_ovt_asov_=psb_map_asov_ + ! + ! Entries and values in desc%matrix_data + ! + integer, parameter :: psb_dec_type_ = 1 + integer, parameter :: psb_m_ = 2 + integer, parameter :: psb_n_ = 3 + integer, parameter :: psb_n_row_ = 4 + integer, parameter :: psb_n_col_ = 5 + integer, parameter :: psb_ctxt_ = 6 + integer, parameter :: psb_desc_size_ = 7 + integer, parameter :: psb_mpi_c_ = 9 + integer, parameter :: psb_pnt_h_ = 10 + integer, parameter :: psb_thal_xch_ = 11 + integer, parameter :: psb_thal_snd_ = 12 + integer, parameter :: psb_thal_rcv_ = 13 + integer, parameter :: psb_tovr_xch_ = 14 + integer, parameter :: psb_tovr_snd_ = 15 + integer, parameter :: psb_tovr_rcv_ = 16 + integer, parameter :: psb_text_xch_ = 17 + integer, parameter :: psb_text_snd_ = 18 + integer, parameter :: psb_text_rcv_ = 19 + integer, parameter :: psb_tmov_xch_ = 20 + integer, parameter :: psb_tmov_snd_ = 21 + integer, parameter :: psb_tmov_rcv_ = 22 + integer, parameter :: psb_mdata_size_= 24 + integer, parameter :: psb_desc_invalid_=-1 + integer, parameter :: psb_desc_null_=-1 + integer, parameter :: psb_desc_asb_=3099 + integer, parameter :: psb_desc_bld_=psb_desc_asb_+1 + integer, parameter :: psb_desc_upd_=psb_desc_bld_+1 + integer, parameter :: psb_desc_repl_=3199 + integer, parameter :: psb_desc_ovl_bld_=3399 + integer, parameter :: psb_desc_ovl_asb_=psb_desc_ovl_bld_+1 + ! these two are reserved for descriptors which are + ! "overlap-extensions" of base descriptors. + integer, parameter :: psb_cd_ovl_bld_=psb_desc_ovl_bld_ + integer, parameter :: psb_cd_ovl_asb_=psb_desc_ovl_asb_ + integer, parameter :: psb_desc_normal_=3299 + integer, parameter :: psb_desc_large_=psb_desc_normal_+1 + ! + ! Constants for hashing into desc%hashv(:) and desc%glb_lc(:,:) + ! + integer, parameter :: psb_hash_bits=16 + integer, parameter :: psb_max_hash_bits=22 + integer, parameter :: psb_hash_size=2**psb_hash_bits, psb_hash_mask=psb_hash_size-1 + integer, parameter :: psb_default_large_threshold=1*1024*1024 + integer, parameter :: psb_hpnt_nentries_=7 + + ! + ! Constants for desc_a handling + ! + + integer, parameter :: psb_upd_glbnum_=998 + integer, parameter :: psb_upd_locnum_=997 + integer, parameter :: psb_proc_id_=0, psb_n_elem_recv_=1 + integer, parameter :: psb_elem_recv_=2, psb_n_elem_send_=2 + integer, parameter :: psb_elem_send_=3, psb_n_ovrlp_elem_=1 + integer, parameter :: psb_ovrlp_elem_to_=2, psb_ovrlp_elem_=0 + integer, parameter :: psb_n_dom_ovr_=1 + +end module psb_desc_const_mod diff --git a/base/modules/psb_desc_type.f90 b/base/modules/psb_desc_type.f90 index 4e7272fc..139d70d9 100644 --- a/base/modules/psb_desc_type.f90 +++ b/base/modules/psb_desc_type.f90 @@ -38,89 +38,11 @@ module psb_descriptor_type use psb_const_mod use psb_hash_mod + use psb_desc_const_mod + use psb_indx_map_mod implicit none - ! - ! Communication, prolongation & restriction - ! - integer, parameter :: psb_nohalo_=0, psb_halo_=1 - ! For overlap update. - integer, parameter :: psb_none_=0, psb_sum_=1 - integer, parameter :: psb_avg_=2, psb_square_root_=3 - integer, parameter :: psb_setzero_=4 - - ! The following are bit fields. - integer, parameter :: psb_swap_send_=1, psb_swap_recv_=2 - integer, parameter :: psb_swap_sync_=4, psb_swap_mpi_=8 - ! Choice among lists on which to base data exchange - integer, parameter :: psb_no_comm_=-1 - integer, parameter :: psb_comm_halo_=1, psb_comm_ovr_=2 - integer, parameter :: psb_comm_ext_=3, psb_comm_mov_=4 - ! Types of mapping between descriptors. - integer, parameter :: psb_map_xhal_ = 123 - integer, parameter :: psb_map_asov_ = psb_map_xhal_+1 - integer, parameter :: psb_map_aggr_ = psb_map_asov_+1 - integer, parameter :: psb_map_gen_linear_ = psb_map_aggr_+1 - - integer, parameter :: psb_ovt_xhal_ = psb_map_xhal_, psb_ovt_asov_=psb_map_asov_ - ! - ! Entries and values in desc%matrix_data - ! - integer, parameter :: psb_dec_type_ = 1 - integer, parameter :: psb_m_ = 2 - integer, parameter :: psb_n_ = 3 - integer, parameter :: psb_n_row_ = 4 - integer, parameter :: psb_n_col_ = 5 - integer, parameter :: psb_ctxt_ = 6 - integer, parameter :: psb_desc_size_ = 7 - integer, parameter :: psb_mpi_c_ = 9 - integer, parameter :: psb_pnt_h_ = 10 - integer, parameter :: psb_thal_xch_ = 11 - integer, parameter :: psb_thal_snd_ = 12 - integer, parameter :: psb_thal_rcv_ = 13 - integer, parameter :: psb_tovr_xch_ = 14 - integer, parameter :: psb_tovr_snd_ = 15 - integer, parameter :: psb_tovr_rcv_ = 16 - integer, parameter :: psb_text_xch_ = 17 - integer, parameter :: psb_text_snd_ = 18 - integer, parameter :: psb_text_rcv_ = 19 - integer, parameter :: psb_tmov_xch_ = 20 - integer, parameter :: psb_tmov_snd_ = 21 - integer, parameter :: psb_tmov_rcv_ = 22 - integer, parameter :: psb_mdata_size_= 24 - integer, parameter :: psb_desc_asb_=3099 - integer, parameter :: psb_desc_bld_=psb_desc_asb_+1 - integer, parameter :: psb_desc_repl_=3199 - integer, parameter :: psb_desc_upd_=psb_desc_bld_+1 - ! these two are reserved for descriptors which are - ! "overlap-extensions" of base descriptors. - integer, parameter :: psb_cd_ovl_bld_=3399 - integer, parameter :: psb_cd_ovl_asb_=psb_cd_ovl_bld_+1 - integer, parameter :: psb_desc_normal_=3299 - integer, parameter :: psb_desc_large_=psb_desc_normal_+1 - ! - ! Constants for hashing into desc%hashv(:) and desc%glb_lc(:,:) - ! - integer, parameter :: psb_hash_bits=16 - integer, parameter :: psb_max_hash_bits=22 - integer, parameter :: psb_hash_size=2**psb_hash_bits, psb_hash_mask=psb_hash_size-1 - integer, parameter :: psb_default_large_threshold=1*1024*1024 - integer, parameter :: psb_hpnt_nentries_=7 - - ! - ! Constants for desc_a handling - ! - - integer, parameter :: psb_upd_glbnum_=998 - integer, parameter :: psb_upd_locnum_=997 - integer, parameter :: psb_proc_id_=0, psb_n_elem_recv_=1 - integer, parameter :: psb_elem_recv_=2, psb_n_elem_send_=2 - integer, parameter :: psb_elem_send_=3, psb_n_ovrlp_elem_=1 - integer, parameter :: psb_ovrlp_elem_to_=2, psb_ovrlp_elem_=0 - integer, parameter :: psb_n_dom_ovr_=1 - - ! ! type: psb_desc_type ! @@ -142,7 +64,6 @@ module psb_descriptor_type !| integer, allocatable :: ovrlap_index(:) !| integer, allocatable :: ovrlap_elem(:,:) !| integer, allocatable :: ovr_mst_idx(:) - !| type(psb_idxmap_type) :: idxmap !| integer, allocatable :: lprm(:) !| integer, allocatable :: idx_space(:) !| type(psb_desc_type), pointer :: base_desc => null() @@ -307,14 +228,7 @@ module psb_descriptor_type ! ! ! - type psb_idxmap_type - integer :: state - integer, allocatable :: loc_to_glob(:) - integer, allocatable :: glob_to_loc(:) - integer :: hashvsize, hashvmask - integer, allocatable :: hashv(:), glb_lc(:,:) - type(psb_hash_type) :: hash - end type psb_idxmap_type + type psb_desc_type integer, allocatable :: matrix_data(:) @@ -324,77 +238,60 @@ module psb_descriptor_type integer, allocatable :: ovrlap_elem(:,:) integer, allocatable :: ovr_mst_idx(:) integer, allocatable :: bnd_elem(:) - type(psb_idxmap_type) :: idxmap + class(psb_indx_map), allocatable :: indxmap integer, allocatable :: lprm(:) type(psb_desc_type), pointer :: base_desc => null() - integer, allocatable :: idx_space(:) + integer, allocatable :: idx_space(:) end type psb_desc_type interface psb_sizeof - module procedure psb_cd_sizeof, psb_idxmap_sizeof - end interface + module procedure psb_cd_sizeof + end interface psb_sizeof interface psb_is_ok_desc module procedure psb_is_ok_desc - end interface + end interface psb_is_ok_desc + + interface psb_is_valid_desc + module procedure psb_is_valid_desc + end interface psb_is_valid_desc interface psb_is_asb_desc module procedure psb_is_asb_desc - end interface + end interface psb_is_asb_desc interface psb_is_upd_desc module procedure psb_is_upd_desc - end interface + end interface psb_is_upd_desc interface psb_is_ovl_desc module procedure psb_is_ovl_desc - end interface + end interface psb_is_ovl_desc interface psb_is_bld_desc module procedure psb_is_bld_desc - end interface + end interface psb_is_bld_desc interface psb_is_large_desc module procedure psb_is_large_desc - end interface + end interface psb_is_large_desc interface psb_move_alloc - module procedure psb_cdtransfer, psb_idxmap_transfer - end interface + module procedure psb_cdtransfer + end interface psb_move_alloc interface psb_free - module procedure psb_cdfree, psb_idxmap_free - end interface + module procedure psb_cdfree + end interface psb_free - interface psb_map_l2g - module procedure psb_map_l2g_s1, psb_map_l2g_s2,& - & psb_map_l2g_v1, psb_map_l2g_v2 - end interface integer, private, save :: cd_large_threshold=psb_default_large_threshold contains - function psb_idxmap_sizeof(map) result(val) - implicit none - !....Parameters... - - Type(psb_idxmap_type), intent(in) :: map - integer(psb_long_int_k_) :: val - - val = 3*psb_sizeof_int - if (allocated(map%loc_to_glob)) val = val + psb_sizeof_int*size(map%loc_to_glob) - if (allocated(map%glob_to_loc)) val = val + psb_sizeof_int*size(map%glob_to_loc) - if (allocated(map%hashv)) val = val + psb_sizeof_int*size(map%hashv) - if (allocated(map%glb_lc)) val = val + psb_sizeof_int*size(map%glb_lc) - val = val + psb_sizeof(map%hash) - - end function psb_idxmap_sizeof - - function psb_cd_sizeof(desc) result(val) implicit none !....Parameters... @@ -412,7 +309,7 @@ contains if (allocated(desc%ovr_mst_idx)) val = val + psb_sizeof_int*size(desc%ovr_mst_idx) if (allocated(desc%lprm)) val = val + psb_sizeof_int*size(desc%lprm) if (allocated(desc%idx_space)) val = val + psb_sizeof_int*size(desc%idx_space) - val = val + psb_sizeof(desc%idxmap) + if (allocated(desc%indxmap)) val = val + desc%indxmap%sizeof() end function psb_cd_sizeof @@ -456,54 +353,84 @@ contains end subroutine psb_nullify_desc - logical function psb_is_ok_desc(desc) + function psb_is_ok_desc(desc) result(val) type(psb_desc_type), intent(in) :: desc - - psb_is_ok_desc = psb_is_ok_dec(psb_cd_get_dectype(desc)) + logical :: val + + val = .false. + if (allocated(desc%indxmap)) & + & val = desc%indxmap%is_valid() end function psb_is_ok_desc - logical function psb_is_bld_desc(desc) + function psb_is_valid_desc(desc) result(val) + type(psb_desc_type), intent(in) :: desc + logical :: val + + val = .false. + if (allocated(desc%indxmap)) & + & val = desc%indxmap%is_valid() + + end function psb_is_valid_desc - psb_is_bld_desc = psb_is_bld_dec(psb_cd_get_dectype(desc)) + function psb_is_bld_desc(desc) result(val) + type(psb_desc_type), intent(in) :: desc + logical :: val + + val = .false. + if (allocated(desc%indxmap)) & + & val = desc%indxmap%is_bld() end function psb_is_bld_desc - logical function psb_is_large_desc(desc) + function psb_is_large_desc(desc) result(val) type(psb_desc_type), intent(in) :: desc + logical :: val - psb_is_large_desc =(psb_desc_large_ == psb_cd_get_size(desc)) + val = .false. end function psb_is_large_desc - logical function psb_is_upd_desc(desc) + function psb_is_upd_desc(desc) result(val) type(psb_desc_type), intent(in) :: desc + logical :: val - psb_is_upd_desc = psb_is_upd_dec(psb_cd_get_dectype(desc)) + val = .false. + if (allocated(desc%indxmap)) & + & val = desc%indxmap%is_upd() end function psb_is_upd_desc - logical function psb_is_repl_desc(desc) + function psb_is_repl_desc(desc) result(val) type(psb_desc_type), intent(in) :: desc + logical :: val - psb_is_repl_desc = psb_is_repl_dec(psb_cd_get_dectype(desc)) + val = .false. + if (allocated(desc%indxmap)) & + & val = desc%indxmap%is_repl() end function psb_is_repl_desc - logical function psb_is_ovl_desc(desc) + function psb_is_ovl_desc(desc) result(val) type(psb_desc_type), intent(in) :: desc + logical :: val - psb_is_ovl_desc = psb_is_ovl_dec(psb_cd_get_dectype(desc)) + val = .false. + if (allocated(desc%indxmap)) & + & val = desc%indxmap%is_ovl() end function psb_is_ovl_desc - logical function psb_is_asb_desc(desc) + function psb_is_asb_desc(desc) result(val) type(psb_desc_type), intent(in) :: desc + logical :: val - psb_is_asb_desc = psb_is_asb_dec(psb_cd_get_dectype(desc)) + val = .false. + if (allocated(desc%indxmap)) & + & val = desc%indxmap%is_asb() end function psb_is_asb_desc @@ -600,8 +527,8 @@ contains integer function psb_cd_get_context(desc) use psb_error_mod type(psb_desc_type), intent(in) :: desc - if (allocated(desc%matrix_data)) then - psb_cd_get_context = desc%matrix_data(psb_ctxt_) + if (allocated(desc%indxmap)) then + psb_cd_get_context = desc%indxmap%get_ctxt() else psb_cd_get_context = -1 call psb_errpush(psb_err_invalid_cd_state_,'psb_cd_get_context') @@ -613,36 +540,22 @@ contains use psb_error_mod type(psb_desc_type), intent(in) :: desc - if (allocated(desc%matrix_data)) then - psb_cd_get_dectype = desc%matrix_data(psb_dec_type_) + if (allocated(desc%indxmap)) then + psb_cd_get_dectype = desc%indxmap%get_state() else psb_cd_get_dectype = -1 call psb_errpush(psb_err_invalid_cd_state_,'psb_cd_get_dectype') call psb_error() end if - - end function psb_cd_get_dectype - - integer function psb_cd_get_size(desc) - use psb_error_mod - type(psb_desc_type), intent(in) :: desc - - if (allocated(desc%matrix_data)) then - psb_cd_get_size = desc%idxmap%state - else - psb_cd_get_size = -1 - call psb_errpush(psb_err_invalid_cd_state_,'psb_cd_get_size') - call psb_error() - end if - end function psb_cd_get_size + end function psb_cd_get_dectype integer function psb_cd_get_mpic(desc) use psb_error_mod type(psb_desc_type), intent(in) :: desc - if (allocated(desc%matrix_data)) then - psb_cd_get_mpic = desc%matrix_data(psb_mpi_c_) + if (allocated(desc%indxmap)) then + psb_cd_get_mpic = desc%indxmap%get_mpic() else psb_cd_get_mpic = -1 call psb_errpush(psb_err_invalid_cd_state_,'psb_cd_get_mpic') @@ -659,8 +572,9 @@ contains type(psb_desc_type), intent(inout) :: desc integer :: info - - if (psb_is_asb_desc(desc)) desc%matrix_data(psb_dec_type_) = psb_cd_ovl_asb_ + + if (psb_is_asb_desc(desc)) & + & call desc%indxmap%set_state(psb_desc_ovl_asb_) end subroutine psb_cd_set_ovl_asb @@ -764,59 +678,6 @@ contains return end subroutine psb_cd_get_list - subroutine psb_idxmap_free(map,info) - !...free descriptor structure... - use psb_const_mod - use psb_error_mod - use psb_penv_mod - implicit none - !....parameters... - type(psb_idxmap_type), intent(inout) :: map - integer, intent(out) :: info - !...locals.... - integer :: ictxt,np,me, err_act - character(len=*), parameter :: name = 'psb_idxmap_free' - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - if (allocated(map%loc_to_glob)) then - deallocate(map%loc_to_glob,stat=info) - end if - if ((info == psb_success_).and.allocated(map%glob_to_loc)) then - deallocate(map%glob_to_loc,stat=info) - end if - if ((info == psb_success_).and.allocated(map%hashv)) then - deallocate(map%hashv,stat=info) - end if - if ((info == psb_success_).and.allocated(map%glb_lc)) then - deallocate(map%glb_lc,stat=info) - end if - if (info /= psb_success_) call psb_free(map%hash, info) - if (info /= psb_success_) then - info=2052 - call psb_errpush(info,name) - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error(ictxt) - end if - return - - end subroutine psb_idxmap_free - - ! ! Subroutine: psb_cdfree ! Frees a descriptor data structure. @@ -859,8 +720,7 @@ contains goto 9999 endif - call psb_free(desc_a%idxmap,info) - + if (.not.allocated(desc_a%halo_index)) then info=298 call psb_errpush(info,name) @@ -921,13 +781,18 @@ contains end if - deallocate(desc_a%lprm,stat=info) + if (allocated(desc_a%lprm)) & + & deallocate(desc_a%lprm,stat=info) if (info /= psb_success_) then info=2057 call psb_errpush(info,name) goto 9999 end if + if (allocated(desc_a%indxmap)) then + call desc_a%indxmap%free() + deallocate(desc_a%indxmap, stat=info) + end if if (allocated(desc_a%idx_space)) then deallocate(desc_a%idx_space,stat=info) if (info /= psb_success_) then @@ -1015,7 +880,7 @@ contains if (info == psb_success_) & & call psb_move_alloc( desc_in%idx_space , desc_out%idx_space , info) if (info == psb_success_) & - & call psb_move_alloc(desc_in%idxmap, desc_out%idxmap,info) + & call move_alloc(desc_in%indxmap, desc_out%indxmap) if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name) @@ -1039,232 +904,6 @@ contains end subroutine psb_cdtransfer - subroutine psb_idxmap_transfer(map_in, map_out, info) - - use psb_realloc_mod - use psb_const_mod - use psb_error_mod - use psb_penv_mod - - implicit none - !....parameters... - - type(psb_idxmap_type), intent(inout) :: map_in - type(psb_idxmap_type), intent(inout) :: map_out - integer, intent(out) :: info - - !locals - integer :: err_act - integer :: debug_level, debug_unit - character(len=*), parameter :: name = 'psb_idxmap_transfer' - - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - map_out%state = map_in%state - map_out%hashvsize = map_in%hashvsize - map_out%hashvmask = map_in%hashvmask - - if (info == psb_success_) & - & call psb_move_alloc( map_in%loc_to_glob , map_out%loc_to_glob , info) - if (info == psb_success_) & - & call psb_move_alloc( map_in%glob_to_loc , map_out%glob_to_loc , info) - if (info == psb_success_) & - & call psb_move_alloc( map_in%hashv , map_out%hashv , info) - if (info == psb_success_) & - & call psb_move_alloc( map_in%glb_lc , map_out%glb_lc , info) - if (info == psb_success_) & - & call psb_move_alloc( map_in%hash , map_out%hash , info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name) - goto 9999 - endif - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if - return - - end subroutine psb_idxmap_transfer - - subroutine psb_idxmap_copy(map_in, map_out, info) - - use psb_realloc_mod - use psb_const_mod - use psb_error_mod - use psb_penv_mod - - implicit none - !....parameters... - - type(psb_idxmap_type), intent(in) :: map_in - type(psb_idxmap_type), intent(inout) :: map_out - integer, intent(out) :: info - - !locals - integer :: err_act - integer :: debug_level, debug_unit - character(len=*), parameter :: name = 'psb_idxmap_transfer' - - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - map_out%state = map_in%state - map_out%hashvsize = map_in%hashvsize - map_out%hashvmask = map_in%hashvmask - - call psb_safe_ab_cpy( map_in%loc_to_glob , map_out%loc_to_glob , info) - if (info == psb_success_) & - & call psb_safe_ab_cpy( map_in%glob_to_loc , map_out%glob_to_loc , info) - if (info == psb_success_) & - & call psb_safe_ab_cpy( map_in%hashv , map_out%hashv , info) - if (info == psb_success_) & - & call psb_safe_ab_cpy( map_in%glb_lc , map_out%glb_lc , info) - if (info == psb_success_) & - & call psb_hash_copy( map_in%hash , map_out%hash , info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name) - goto 9999 - endif - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if - return - - end subroutine psb_idxmap_copy - - subroutine psb_map_l2g_s1(idx,map,info) - implicit none - integer, intent(inout) :: idx - integer, intent(out) :: info - type(psb_idxmap_type) :: map - integer :: nc - - info = psb_success_ - if (.not.allocated(map%loc_to_glob)) then - info = psb_err_iarray_outside_bounds_ - idx = -1 - return - end if - nc = size(map%loc_to_glob) - if ((idx < 1).or.(idx>nc)) then - info = psb_err_iarray_outside_bounds_ - idx = -1 - return - end if - idx = map%loc_to_glob(idx) - - end subroutine psb_map_l2g_s1 - - subroutine psb_map_l2g_s2(idx,gidx,map,info) - implicit none - integer, intent(in) :: idx - integer, intent(out) :: gidx, info - type(psb_idxmap_type) :: map - integer :: nc - - info = psb_success_ - if (.not.allocated(map%loc_to_glob)) then - info = psb_err_iarray_outside_bounds_ - gidx = -1 - return - end if - nc = size(map%loc_to_glob) - if ((idx < 1).or.(idx>nc)) then - info = psb_err_iarray_outside_bounds_ - gidx = -1 - return - end if - gidx = map%loc_to_glob(idx) - - end subroutine psb_map_l2g_s2 - - subroutine psb_map_l2g_v1(idx,map,info) - implicit none - integer, intent(inout) :: idx(:) - integer, intent(out) :: info - type(psb_idxmap_type) :: map - integer :: nc, i, ix - - info = psb_success_ - if (size(idx) == 0) return - if (.not.allocated(map%loc_to_glob)) then - info = psb_err_iarray_outside_bounds_ - idx = -1 - return - end if - nc = size(map%loc_to_glob) - do i=1, size(idx) - ix = idx(i) - if ((ix < 1).or.(ix>nc)) then - info = psb_err_iarray_outside_bounds_ - idx(i) = -1 - else - idx(i) = map%loc_to_glob(ix) - end if - end do - - end subroutine psb_map_l2g_v1 - - subroutine psb_map_l2g_v2(idx,gidx,map,info) - implicit none - integer, intent(in) :: idx(:) - integer, intent(out) :: gidx(:),info - type(psb_idxmap_type) :: map - integer :: nc, i, ix - - info = psb_success_ - if (size(idx) == 0) return - if ((.not.allocated(map%loc_to_glob)).or.& - & (size(gidx)nc)) then - info = psb_err_iarray_outside_bounds_ - gidx(i) = -1 - else - gidx(i) = map%loc_to_glob(ix) - end if - end do - - end subroutine psb_map_l2g_v2 - - Subroutine psb_cd_get_recv_idx(tmp,desc,data,info,toglob) use psb_error_mod @@ -1292,7 +931,7 @@ contains ictxt = psb_cd_get_context(desc) call psb_info(ictxt, me, np) - + select case(data) case(psb_comm_halo_) idxlist => desc%halo_index @@ -1308,7 +947,7 @@ contains call psb_errpush(info,name,a_err='wrong Data selector') goto 9999 end select - + l_tmp = 3*size(idxlist) allocate(tmp(l_tmp),stat=info) @@ -1317,7 +956,7 @@ contains call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if - + incnt = 1 outcnt = 1 tmp(:) = -1 @@ -1335,7 +974,7 @@ contains goto 9999 end if if (toglob) then - call psb_map_l2g(idx,gidx,desc%idxmap,info) + call desc%indxmap%l2g(idx,gidx,info) If (gidx < 0) then info=-3 call psb_errpush(info,name) @@ -1355,7 +994,7 @@ contains end Do incnt = incnt+n_elem_recv+n_elem_send+3 end Do - + call psb_erractionrestore(err_act) return diff --git a/base/modules/psb_gen_block_map_mod.f03 b/base/modules/psb_gen_block_map_mod.f03 new file mode 100644 index 00000000..876eee2b --- /dev/null +++ b/base/modules/psb_gen_block_map_mod.f03 @@ -0,0 +1,625 @@ +module psb_gen_block_map_mod + use psb_const_mod + use psb_desc_const_mod + use psb_indx_map_mod + + type, extends(psb_indx_map) :: psb_gen_block_map + integer :: min_glob_row = -1 + integer :: max_glob_row = -1 + integer, allocatable :: loc_to_glob(:), srt_l2g(:,:), vnl(:) + contains + + procedure, pass(idxmap) :: gen_block_map_init => block_init + + procedure, pass(idxmap) :: sizeof => block_sizeof + procedure, pass(idxmap) :: asb => block_asb + procedure, pass(idxmap) :: free => block_free + procedure, pass(idxmap) :: get_fmt => block_get_fmt + + procedure, pass(idxmap) :: l2gs1 => block_l2gs1 + procedure, pass(idxmap) :: l2gs2 => block_l2gs2 + procedure, pass(idxmap) :: l2gv1 => block_l2gv1 + procedure, pass(idxmap) :: l2gv2 => block_l2gv2 + + procedure, pass(idxmap) :: g2ls1 => block_g2ls1 + procedure, pass(idxmap) :: g2ls2 => block_g2ls2 + procedure, pass(idxmap) :: g2lv1 => block_g2lv1 + procedure, pass(idxmap) :: g2lv2 => block_g2lv2 + + procedure, pass(idxmap) :: g2ls1_ins => block_g2ls1_ins + procedure, pass(idxmap) :: g2ls2_ins => block_g2ls2_ins + procedure, pass(idxmap) :: g2lv1_ins => block_g2lv1_ins + procedure, pass(idxmap) :: g2lv2_ins => block_g2lv2_ins + + procedure, pass(idxmap) :: fnd_owner => block_fnd_owner + + end type psb_gen_block_map + + private :: block_init, block_sizeof, block_asb, block_free,& + & block_get_fmt, block_l2gs1, block_l2gs2, block_l2gv1,& + & block_l2gv2, block_g2ls1, block_g2ls2, block_g2lv1,& + & block_g2lv2, block_g2ls1_ins, block_g2ls2_ins,& + & block_g2lv1_ins, block_g2lv2_ins + + +contains + + + function block_sizeof(idxmap) result(val) + implicit none + class(psb_gen_block_map), intent(in) :: idxmap + integer(psb_long_int_k_) :: val + + val = idxmap%psb_indx_map%sizeof() + val = val + 2 * psb_sizeof_int + if (allocated(idxmap%loc_to_glob)) & + & val = val + size(idxmap%loc_to_glob)*psb_sizeof_int + if (allocated(idxmap%srt_l2g)) & + & val = val + size(idxmap%srt_l2g)*psb_sizeof_int + if (allocated(idxmap%vnl)) & + & val = val + size(idxmap%vnl)*psb_sizeof_int + + end function block_sizeof + + + subroutine block_free(idxmap) + implicit none + class(psb_gen_block_map), intent(inout) :: idxmap + + if (allocated(idxmap%loc_to_glob)) & + & deallocate(idxmap%loc_to_glob) + if (allocated(idxmap%srt_l2g)) & + & deallocate(idxmap%srt_l2g) + + if (allocated(idxmap%srt_l2g)) & + & deallocate(idxmap%vnl) + + call idxmap%psb_indx_map%free() + + end subroutine block_free + + + subroutine block_l2gs1(idx,idxmap,info,mask,owned) + implicit none + class(psb_gen_block_map), intent(in) :: idxmap + integer, intent(inout) :: idx + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + integer :: idxv(1) + info = 0 + if (present(mask)) then + if (.not.mask) return + end if + + idxv(1) = idx + call idxmap%l2g(idxv,info,owned=owned) + idx = idxv(1) + + end subroutine block_l2gs1 + + subroutine block_l2gs2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_gen_block_map), intent(in) :: idxmap + integer, intent(in) :: idxin + integer, intent(out) :: idxout + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + + idxout = idxin + call idxmap%l2g(idxout,info,mask,owned) + + end subroutine block_l2gs2 + + + subroutine block_l2gv1(idx,idxmap,info,mask,owned) + implicit none + class(psb_gen_block_map), intent(in) :: idxmap + integer, intent(inout) :: idx(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer :: i + logical :: owned_ + info = 0 + + if (present(mask)) then + if (size(mask) < size(idx)) then + info = -1 + return + end if + end if + if (present(owned)) then + owned_ = owned + else + owned_ = .false. + end if + + if (present(mask)) then + + do i=1, size(idx) + if (mask(i)) then + if ((1<=idx(i)).and.(idx(i) <= idxmap%local_rows)) then + idx(i) = idxmap%min_glob_row + idx(i) - 1 + else if ((idxmap%local_rows < idx(i)).and.(idx(i) <= idxmap%local_cols)& + & .and.(.not.owned_)) then + idx(i) = idxmap%loc_to_glob(idx(i)-idxmap%local_rows) + else + idx(i) = -1 + info = -1 + end if + end if + end do + + else if (.not.present(mask)) then + + do i=1, size(idx) + if ((1<=idx(i)).and.(idx(i) <= idxmap%local_rows)) then + idx(i) = idxmap%min_glob_row + idx(i) - 1 + else if ((idxmap%local_rows < idx(i)).and.(idx(i) <= idxmap%local_cols)& + & .and.(.not.owned_)) then + idx(i) = idxmap%loc_to_glob(idx(i)-idxmap%local_rows) + else + idx(i) = -1 + info = -1 + end if + end do + + end if + + end subroutine block_l2gv1 + + subroutine block_l2gv2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_gen_block_map), intent(in) :: idxmap + integer, intent(in) :: idxin(:) + integer, intent(out) :: idxout(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer :: is, im + + is = size(idxin) + im = min(is,size(idxout)) + idxout(1:im) = idxin(1:im) + call idxmap%l2g(idxout(1:im),info,mask,owned) + if (is > im) then + info = -3 + end if + + end subroutine block_l2gv2 + + + subroutine block_g2ls1(idx,idxmap,info,mask,owned) + implicit none + class(psb_gen_block_map), intent(in) :: idxmap + integer, intent(inout) :: idx + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + integer :: idxv(1) + info = 0 + + if (present(mask)) then + if (.not.mask) return + end if + + idxv(1) = idx + call idxmap%g2l(idxv,info,owned=owned) + idx = idxv(1) + + end subroutine block_g2ls1 + + subroutine block_g2ls2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_gen_block_map), intent(in) :: idxmap + integer, intent(in) :: idxin + integer, intent(out) :: idxout + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + + idxout = idxin + call idxmap%g2l(idxout,info,mask,owned) + + end subroutine block_g2ls2 + + + subroutine block_g2lv1(idx,idxmap,info,mask,owned) + use psb_penv_mod + use psb_sort_mod + implicit none + class(psb_gen_block_map), intent(in) :: idxmap + integer, intent(inout) :: idx(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer :: i, nv, is + integer :: ictxt, iam, np + logical :: owned_ + + info = 0 + ictxt = idxmap%get_ctxt() + call psb_info(ictxt,iam,np) + + if (present(mask)) then + if (size(mask) < size(idx)) then +!!$ write(0,*) 'Block g2l: size of mask', size(mask),size(idx) + info = -1 + return + end if + end if + if (present(owned)) then + owned_ = owned + else + owned_ = .false. + end if + + is = size(idx) + if (present(mask)) then + + if (idxmap%is_asb()) then + do i=1, is + if (mask(i)) then + if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then + idx(i) = idx(i) - idxmap%min_glob_row + 1 + else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)& + &.and.(.not.owned_)) then + nv = size(idxmap%srt_l2g,1) + idx(i) = psb_ibsrch(idx(i),nv,idxmap%srt_l2g(:,1)) + if (idx(i) > 0) idx(i) = idxmap%srt_l2g(idx(i),2)+idxmap%local_rows + else + idx(i) = -1 + end if + end if + end do + else if (idxmap%is_valid()) then + do i=1,is + if (mask(i)) then + if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then + idx(i) = idx(i) - idxmap%min_glob_row + 1 + else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)& + &.and.(.not.owned_)) then + nv = idxmap%local_cols-idxmap%local_rows + idx(i) = psb_issrch(idx(i),nv,idxmap%loc_to_glob) + if (idx(i) > 0) idx(i) = idx(i) + idxmap%local_rows + else + idx(i) = -1 + end if + end if + end do + else +!!$ write(0,*) 'Block status: invalid ',idxmap%get_state() + idx(1:is) = -1 + info = -1 + end if + + else if (.not.present(mask)) then + + if (idxmap%is_asb()) then + do i=1, is + if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then + idx(i) = idx(i) - idxmap%min_glob_row + 1 + else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)& + &.and.(.not.owned_)) then + nv = size(idxmap%srt_l2g,1) + idx(i) = psb_ibsrch(idx(i),nv,idxmap%srt_l2g(:,1)) + if (idx(i) > 0) idx(i) = idxmap%srt_l2g(idx(i),2)+idxmap%local_rows + else + idx(i) = -1 + end if + end do + + else if (idxmap%is_valid()) then + do i=1,is + if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then + idx(i) = idx(i) - idxmap%min_glob_row + 1 + else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)& + &.and.(.not.owned_)) then + nv = idxmap%local_cols-idxmap%local_rows + idx(i) = psb_issrch(idx(i),nv,idxmap%loc_to_glob) + if (idx(i) > 0) idx(i) = idx(i) + idxmap%local_rows + else + idx(i) = -1 + end if + end do + else +!!$ write(0,*) 'Block status: invalid ',idxmap%get_state() + idx(1:is) = -1 + info = -1 + end if + + end if + + end subroutine block_g2lv1 + + subroutine block_g2lv2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_gen_block_map), intent(in) :: idxmap + integer, intent(in) :: idxin(:) + integer, intent(out) :: idxout(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + + integer :: is, im + + is = size(idxin) + im = min(is,size(idxout)) + idxout(1:im) = idxin(1:im) + call idxmap%g2l(idxout(1:im),info,mask,owned) + if (is > im) info = -3 + + end subroutine block_g2lv2 + + + + subroutine block_g2ls1_ins(idx,idxmap,info,mask) + use psb_realloc_mod + use psb_sort_mod + implicit none + class(psb_gen_block_map), intent(inout) :: idxmap + integer, intent(inout) :: idx + integer, intent(out) :: info + logical, intent(in), optional :: mask + + integer :: idxv(1) + + info = 0 + if (present(mask)) then + if (.not.mask) return + end if + idxv(1) = idx + call idxmap%g2l_ins(idxv,info) + idx = idxv(1) + + end subroutine block_g2ls1_ins + + subroutine block_g2ls2_ins(idxin,idxout,idxmap,info,mask) + implicit none + class(psb_gen_block_map), intent(inout) :: idxmap + integer, intent(in) :: idxin + integer, intent(out) :: idxout + integer, intent(out) :: info + logical, intent(in), optional :: mask + + idxout = idxin + call idxmap%g2l_ins(idxout,info) + + end subroutine block_g2ls2_ins + + + subroutine block_g2lv1_ins(idx,idxmap,info,mask) + use psb_realloc_mod + use psb_sort_mod + implicit none + class(psb_gen_block_map), intent(inout) :: idxmap + integer, intent(inout) :: idx(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + integer :: i, nv, is, ix + + info = 0 + is = size(idx) + + if (present(mask)) then + if (size(mask) < size(idx)) then + info = -1 + return + end if + end if + + + if (idxmap%is_asb()) then + ! State is wrong for this one ! + idx = -1 + info = -1 + + else if (idxmap%is_valid()) then + + if (present(mask)) then + do i=1, is + if (mask(i)) then + if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then + idx(i) = idx(i) - idxmap%min_glob_row + 1 + else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then + nv = idxmap%local_cols-idxmap%local_rows + ix = psb_issrch(idx(i),nv,idxmap%loc_to_glob) + if (ix < 0) then + ix = idxmap%local_cols + 1 + call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=500) + if (info /= 0) then + info = -4 + return + end if + idxmap%local_cols = ix + ix = ix - idxmap%local_rows + idxmap%loc_to_glob(ix) = idx(i) + end if + ix = ix + idxmap%local_rows + idx(i) = ix + else + idx(i) = -1 + info = -1 + end if + end if + end do + + else if (.not.present(mask)) then + + do i=1, is + + if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then + idx(i) = idx(i) - idxmap%min_glob_row + 1 + else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then + nv = idxmap%local_cols-idxmap%local_rows + ix = psb_issrch(idx(i),nv,idxmap%loc_to_glob) + if (ix < 0) then + ix = idxmap%local_cols + 1 + call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=500) + if (info /= 0) then + info = -4 + return + end if + idxmap%local_cols = ix + ix = ix - idxmap%local_rows + idxmap%loc_to_glob(ix) = idx(i) + end if + ix = ix + idxmap%local_rows + idx(i) = ix + else + idx(i) = -1 + info = -1 + end if + end do + end if + + else + idx = -1 + info = -1 + end if + + end subroutine block_g2lv1_ins + + subroutine block_g2lv2_ins(idxin,idxout,idxmap,info,mask) + implicit none + class(psb_gen_block_map), intent(inout) :: idxmap + integer, intent(in) :: idxin(:) + integer, intent(out) :: idxout(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + integer :: is, im + + is = size(idxin) + im = min(is,size(idxout)) + idxout(1:im) = idxin(1:im) + call idxmap%g2l_ins(idxout(1:im),info,mask) + if (is > im) then +!!$ write(0,*) 'g2lv2_ins err -3' + info = -3 + end if + + end subroutine block_g2lv2_ins + + subroutine block_fnd_owner(idx,iprc,idxmap,info) + use psb_penv_mod + use psb_sort_mod + implicit none + integer, intent(in) :: idx(:) + integer, allocatable, intent(out) :: iprc(:) + class(psb_gen_block_map), intent(in) :: idxmap + integer, intent(out) :: info + integer :: ictxt, iam, np, nv, ip, i + + ictxt = idxmap%get_ctxt() + call psb_info(ictxt,iam,np) + nv = size(idx) + allocate(iprc(nv),stat=info) + if (info /= 0) then +!!$ write(0,*) 'Memory allocation failure in repl_map_fnd-owner' + return + end if + do i=1, nv + ip = psb_iblsrch(idx(i)-1,np+1,idxmap%vnl) + iprc(i) = ip - 1 + end do + + end subroutine block_fnd_owner + + + + subroutine block_init(idxmap,ictxt,nl,info) + use psb_penv_mod + use psb_error_mod + implicit none + class(psb_gen_block_map), intent(inout) :: idxmap + integer, intent(in) :: ictxt, nl + integer, intent(out) :: info + ! To be implemented + integer :: iam, np, i, j, ntot + integer, allocatable :: vnl(:) + + info = 0 + call psb_info(ictxt,iam,np) + if (np < 0) then + write(psb_err_unit,*) 'Invalid ictxt:',ictxt + info = -1 + return + end if + allocate(vnl(0:np),stat=info) + if (info /= 0) then + info = -2 + return + end if + + vnl(:) = 0 + vnl(iam) = nl + call psb_sum(ictxt,vnl) + ntot = sum(vnl) + vnl(1:np) = vnl(0:np-1) + vnl(0) = 0 + do i=1,np + vnl(i) = vnl(i) + vnl(i-1) + end do + if (ntot /= vnl(np)) then +!!$ write(0,*) ' Mismatch in block_init ',ntot,vnl(np) + end if + + idxmap%global_rows = ntot + idxmap%global_cols = ntot + idxmap%local_rows = nl + idxmap%local_cols = nl + idxmap%ictxt = ictxt + idxmap%state = psb_desc_bld_ + call psb_get_mpicomm(ictxt,idxmap%mpic) + idxmap%min_glob_row = vnl(iam)+1 + idxmap%max_glob_row = vnl(iam+1) + call move_alloc(vnl,idxmap%vnl) + allocate(idxmap%loc_to_glob(nl),stat=info) + if (info /= 0) then + info = -2 + return + end if + call idxmap%set_state(psb_desc_bld_) + + + end subroutine block_init + + + subroutine block_asb(idxmap,info) + use psb_penv_mod + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + implicit none + class(psb_gen_block_map), intent(inout) :: idxmap + integer, intent(out) :: info + + integer :: nhal, ictxt, iam, np + + info = 0 + ictxt = idxmap%get_ctxt() + call psb_info(ictxt,iam,np) + + nhal = idxmap%local_cols-idxmap%local_rows + + call psb_realloc(nhal,idxmap%loc_to_glob,info) + call psb_realloc(nhal,2,idxmap%srt_l2g,info) + idxmap%srt_l2g(1:nhal,1) = idxmap%loc_to_glob(1:nhal) + + call psb_qsort(idxmap%srt_l2g(:,1),& + & ix=idxmap%srt_l2g(:,2),dir=psb_sort_up_) + + call idxmap%set_state(psb_desc_asb_) + + end subroutine block_asb + + function block_get_fmt(idxmap) result(res) + implicit none + class(psb_gen_block_map), intent(in) :: idxmap + character(len=5) :: res + res = 'BLOCK' + end function block_get_fmt + +end module psb_gen_block_map_mod diff --git a/base/modules/psb_glist_map_mod.f03 b/base/modules/psb_glist_map_mod.f03 new file mode 100644 index 00000000..b406d857 --- /dev/null +++ b/base/modules/psb_glist_map_mod.f03 @@ -0,0 +1,144 @@ +module psb_glist_map_mod + use psb_const_mod + use psb_desc_const_mod + use psb_list_map_mod + + type, extends(psb_list_map) :: psb_glist_map + integer, allocatable :: vgp(:) + contains + procedure, pass(idxmap) :: glist_map_init => glist_initvg + procedure, pass(idxmap) :: sizeof => glist_sizeof + procedure, pass(idxmap) :: free => glist_free + procedure, pass(idxmap) :: get_fmt => glist_get_fmt + procedure, pass(idxmap) :: fnd_owner => glist_fnd_owner + + end type psb_glist_map + + private :: glist_initvg, glist_sizeof, glist_free, glist_get_fmt + + +contains + + + function glist_sizeof(idxmap) result(val) + implicit none + class(psb_glist_map), intent(in) :: idxmap + integer(psb_long_int_k_) :: val + + val = idxmap%psb_list_map%sizeof() + + if (allocated(idxmap%vgp)) & + & val = val + size(idxmap%vgp)*psb_sizeof_int + + end function glist_sizeof + + + subroutine glist_free(idxmap) + implicit none + class(psb_glist_map), intent(inout) :: idxmap + + if (allocated(idxmap%vgp)) & + & deallocate(idxmap%vgp) + + call idxmap%psb_list_map%free() + + end subroutine glist_free + + + + + subroutine glist_initvg(idxmap,ictxt,vg,info) + use psb_penv_mod + use psb_error_mod + implicit none + class(psb_glist_map), intent(inout) :: idxmap + integer, intent(in) :: ictxt, vg(:) + integer, intent(out) :: info + ! To be implemented + integer :: iam, np, i, j, n, nl + + + info = 0 + call psb_info(ictxt,iam,np) + if (np < 0) then + write(psb_err_unit,*) 'Invalid ictxt:',ictxt + info = -1 + return + end if + n = size(vg) + + idxmap%global_rows = n + idxmap%global_cols = n + + allocate(idxmap%loc_to_glob(n),idxmap%glob_to_loc(n),& + & idxmap%vgp(n),stat=info) + if (info /= 0) then + info = -2 + return + end if + + idxmap%ictxt = ictxt + idxmap%state = psb_desc_bld_ + call psb_get_mpicomm(ictxt,idxmap%mpic) + + nl = 0 + do i=1, n + if ((vg(i) > np-1).or.(vg(i) < 0)) then + info=psb_err_partfunc_wrong_pid_ + exit + end if + idxmap%vgp(i) = vg(i) + if (vg(i) == iam) then + ! this point belongs to me + nl = nl + 1 + idxmap%glob_to_loc(i) = nl + idxmap%loc_to_glob(nl) = i + else + idxmap%glob_to_loc(i) = -(np+vg(i)+1) + end if + end do + + call idxmap%set_lr(nl) + call idxmap%set_lc(nl) + + end subroutine glist_initvg + + subroutine glist_fnd_owner(idx,iprc,idxmap,info) + use psb_penv_mod + use psb_sort_mod + implicit none + integer, intent(in) :: idx(:) + integer, allocatable, intent(out) :: iprc(:) + class(psb_glist_map), intent(in) :: idxmap + integer, intent(out) :: info + integer :: ictxt, iam, np, nv, ip, i, ngp + + ictxt = idxmap%get_ctxt() + call psb_info(ictxt,iam,np) + nv = size(idx) + allocate(iprc(nv),stat=info) + if (info /= 0) then + write(0,*) 'Memory allocation failure in repl_map_fnd-owner' + return + end if + + ngp = size(idxmap%vgp) + do i=1, nv + if ((1<=idx(i)).and.(idx(i) hash_init_vl + procedure, pass(idxmap) :: hash_map_init => hash_init_vg + + procedure, pass(idxmap) :: sizeof => hash_sizeof + procedure, pass(idxmap) :: asb => hash_asb + procedure, pass(idxmap) :: free => hash_free + procedure, pass(idxmap) :: get_fmt => hash_get_fmt + + procedure, pass(idxmap) :: row_extendable => hash_row_extendable + + procedure, pass(idxmap) :: l2gs1 => hash_l2gs1 + procedure, pass(idxmap) :: l2gs2 => hash_l2gs2 + procedure, pass(idxmap) :: l2gv1 => hash_l2gv1 + procedure, pass(idxmap) :: l2gv2 => hash_l2gv2 + + procedure, pass(idxmap) :: g2ls1 => hash_g2ls1 + procedure, pass(idxmap) :: g2ls2 => hash_g2ls2 + procedure, pass(idxmap) :: g2lv1 => hash_g2lv1 + procedure, pass(idxmap) :: g2lv2 => hash_g2lv2 + + procedure, pass(idxmap) :: g2ls1_ins => hash_g2ls1_ins + procedure, pass(idxmap) :: g2ls2_ins => hash_g2ls2_ins + procedure, pass(idxmap) :: g2lv1_ins => hash_g2lv1_ins + procedure, pass(idxmap) :: g2lv2_ins => hash_g2lv2_ins + + procedure, pass(idxmap) :: bld_g2l_map => hash_bld_g2l_map + + end type psb_hash_map + + private :: hash_init_vl, hash_init_vg, hash_sizeof, hash_asb, & + & hash_free, hash_get_fmt, hash_l2gs1, hash_l2gs2, & + & hash_l2gv1, hash_l2gv2, hash_g2ls1, hash_g2ls2, & + & hash_g2lv1, hash_g2lv2, hash_g2ls1_ins, hash_g2ls2_ins, & + & hash_g2lv1_ins, hash_g2lv2_ins, hash_init_vlu, & + & hash_bld_g2l_map, hash_inner_cnvs1, hash_inner_cnvs2,& + & hash_inner_cnv1, hash_inner_cnv2, hash_row_extendable + + + interface hash_inner_cnv + module procedure hash_inner_cnvs1, hash_inner_cnvs2,& + & hash_inner_cnv1, hash_inner_cnv2 + end interface hash_inner_cnv + private :: hash_inner_cnv + +contains + + function hash_row_extendable(idxmap) result(val) + implicit none + class(psb_hash_map), intent(in) :: idxmap + logical :: val + val = .true. + end function hash_row_extendable + + function hash_sizeof(idxmap) result(val) + implicit none + class(psb_hash_map), intent(in) :: idxmap + integer(psb_long_int_k_) :: val + + val = idxmap%psb_indx_map%sizeof() + val = val + 2 * psb_sizeof_int + if (allocated(idxmap%hashv)) & + & val = val + size(idxmap%hashv)*psb_sizeof_int + if (allocated(idxmap%glb_lc)) & + & val = val + size(idxmap%glb_lc)*psb_sizeof_int + if (allocated(idxmap%hash)) & + & val = val + psb_sizeof(idxmap%hash) + + end function hash_sizeof + + + subroutine hash_free(idxmap) + implicit none + class(psb_hash_map), intent(inout) :: idxmap + integer :: info + + if (allocated(idxmap%hashv)) & + & deallocate(idxmap%hashv) + if (allocated(idxmap%glb_lc)) & + & deallocate(idxmap%glb_lc) + + if (allocated(idxmap%hash)) then + call psb_free(idxmap%hash,info) + deallocate(idxmap%hash) + end if + + call idxmap%psb_indx_map%free() + + end subroutine hash_free + + + subroutine hash_l2gs1(idx,idxmap,info,mask,owned) + implicit none + class(psb_hash_map), intent(in) :: idxmap + integer, intent(inout) :: idx + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + integer :: idxv(1) + info = 0 + if (present(mask)) then + if (.not.mask) return + end if + + idxv(1) = idx + call idxmap%l2g(idxv,info,owned=owned) + idx = idxv(1) + + end subroutine hash_l2gs1 + + subroutine hash_l2gs2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_hash_map), intent(in) :: idxmap + integer, intent(in) :: idxin + integer, intent(out) :: idxout + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + + idxout = idxin + call idxmap%l2g(idxout,info,mask,owned) + + end subroutine hash_l2gs2 + + + subroutine hash_l2gv1(idx,idxmap,info,mask,owned) + implicit none + class(psb_hash_map), intent(in) :: idxmap + integer, intent(inout) :: idx(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer :: i + logical :: owned_ + info = 0 + + if (present(mask)) then + if (size(mask) < size(idx)) then + info = -1 + return + end if + end if + if (present(owned)) then + owned_ = owned + else + owned_ = .false. + end if + + if (present(mask)) then + + do i=1, size(idx) + if (mask(i)) then + if ((1<=idx(i)).and.(idx(i) <= idxmap%local_rows)) then + idx(i) = idxmap%loc_to_glob(idx(i)) + else if ((idxmap%local_rows < idx(i)).and.(idx(i) <= idxmap%local_cols)& + & .and.(.not.owned_)) then + idx(i) = idxmap%loc_to_glob(idx(i)) + else + idx(i) = -1 + end if + end if + end do + + else if (.not.present(mask)) then + + do i=1, size(idx) + if ((1<=idx(i)).and.(idx(i) <= idxmap%local_rows)) then + idx(i) = idxmap%loc_to_glob(idx(i)) + else if ((idxmap%local_rows < idx(i)).and.(idx(i) <= idxmap%local_cols)& + & .and.(.not.owned_)) then + idx(i) = idxmap%loc_to_glob(idx(i)) + else + idx(i) = -1 + end if + end do + + end if + + end subroutine hash_l2gv1 + + subroutine hash_l2gv2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_hash_map), intent(in) :: idxmap + integer, intent(in) :: idxin(:) + integer, intent(out) :: idxout(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer :: is, im + + is = size(idxin) + im = min(is,size(idxout)) + idxout(1:im) = idxin(1:im) + call idxmap%l2g(idxout(1:im),info,mask,owned) + if (is > im) then + write(0,*) 'l2gv2 err -3' + info = -3 + end if + + end subroutine hash_l2gv2 + + + subroutine hash_g2ls1(idx,idxmap,info,mask,owned) + implicit none + class(psb_hash_map), intent(in) :: idxmap + integer, intent(inout) :: idx + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + integer :: idxv(1) + info = 0 + + if (present(mask)) then + if (.not.mask) return + end if + + idxv(1) = idx + call idxmap%g2l(idxv,info,owned=owned) + idx = idxv(1) + + end subroutine hash_g2ls1 + + subroutine hash_g2ls2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_hash_map), intent(in) :: idxmap + integer, intent(in) :: idxin + integer, intent(out) :: idxout + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + + idxout = idxin + call idxmap%g2l(idxout,info,mask,owned) + + end subroutine hash_g2ls2 + + + subroutine hash_g2lv1(idx,idxmap,info,mask,owned) + use psb_penv_mod + use psb_sort_mod + implicit none + class(psb_hash_map), intent(in) :: idxmap + integer, intent(inout) :: idx(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer :: i, nv, is, mglob, ip, lip, nrow, ncol, nrm + integer :: ictxt, iam, np + logical :: owned_ + + info = 0 + ictxt = idxmap%get_ctxt() + call psb_info(ictxt,iam,np) + + if (present(mask)) then + if (size(mask) < size(idx)) then + info = -1 + return + end if + end if + if (present(owned)) then + owned_ = owned + else + owned_ = .false. + end if + + is = size(idx) + + mglob = idxmap%get_gr() + nrow = idxmap%get_lr() + ncol = idxmap%get_lc() + if (owned_) then + nrm = nrow + else + nrm = ncol + end if + if (present(mask)) then + + if (idxmap%is_asb()) then + + call hash_inner_cnv(is,idx,idxmap%hashvmask,& + & idxmap%hashv,idxmap%glb_lc,mask=mask, nrm=nrm) + + else if (idxmap%is_valid()) then + + do i = 1, is + if (mask(i)) then + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle + endif + call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,nrm) + if (lip < 0) & + & call psb_hash_searchkey(ip,lip,idxmap%hash,info) + if (owned_) then + if (lip<=nrow) then + idx(i) = lip + else + idx(i) = -1 + endif + else + idx(i) = lip + endif + end if + enddo + + else + write(0,*) 'Hash status: invalid ',idxmap%get_state() + idx(1:is) = -1 + info = -1 + end if + + else if (.not.present(mask)) then + + if (idxmap%is_asb()) then + + call hash_inner_cnv(is,idx,idxmap%hashvmask,& + & idxmap%hashv,idxmap%glb_lc,nrm=nrm) + + else if (idxmap%is_valid()) then + + do i = 1, is + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle + endif + call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,nrm) + if (lip < 0) & + & call psb_hash_searchkey(ip,lip,idxmap%hash,info) + if (owned_) then + if (lip<=nrow) then + idx(i) = lip + else + idx(i) = -1 + endif + else + idx(i) = lip + endif + enddo + + else + write(0,*) 'Hash status: invalid ',idxmap%get_state() + idx(1:is) = -1 + info = -1 + + end if + + end if + + end subroutine hash_g2lv1 + + subroutine hash_g2lv2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_hash_map), intent(in) :: idxmap + integer, intent(in) :: idxin(:) + integer, intent(out) :: idxout(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + + integer :: is, im + + is = size(idxin) + im = min(is,size(idxout)) + idxout(1:im) = idxin(1:im) + call idxmap%g2l(idxout(1:im),info,mask,owned) + if (is > im) then + write(0,*) 'g2lv2 err -3' + info = -3 + end if + + end subroutine hash_g2lv2 + + + + subroutine hash_g2ls1_ins(idx,idxmap,info,mask) + use psb_realloc_mod + use psb_sort_mod + implicit none + class(psb_hash_map), intent(inout) :: idxmap + integer, intent(inout) :: idx + integer, intent(out) :: info + logical, intent(in), optional :: mask + + integer :: idxv(1) + + info = 0 + if (present(mask)) then + if (.not.mask) return + end if + idxv(1) = idx + call idxmap%g2l_ins(idxv,info) + idx = idxv(1) + + end subroutine hash_g2ls1_ins + + subroutine hash_g2ls2_ins(idxin,idxout,idxmap,info,mask) + implicit none + class(psb_hash_map), intent(inout) :: idxmap + integer, intent(in) :: idxin + integer, intent(out) :: idxout + integer, intent(out) :: info + logical, intent(in), optional :: mask + + idxout = idxin + call idxmap%g2l_ins(idxout,info) + + end subroutine hash_g2ls2_ins + + + subroutine hash_g2lv1_ins(idx,idxmap,info,mask) + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + use psb_penv_mod + implicit none + class(psb_hash_map), intent(inout) :: idxmap + integer, intent(inout) :: idx(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + integer :: i, nv, is, ix, mglob, ip, lip, nrow, ncol, & + & nrm, nxt, err_act, ictxt, me, np + character(len=20) :: name,ch_err + + info = psb_success_ + name = 'hash_g2l_ins' + call psb_erractionsave(err_act) + + ictxt = idxmap%get_ctxt() + call psb_info(ictxt, me, np) + + is = size(idx) + + if (present(mask)) then + if (size(mask) < size(idx)) then + info = -1 + return + end if + end if + + + mglob = idxmap%get_gr() + nrow = idxmap%get_lr() + if (idxmap%is_bld()) then + + if (present(mask)) then + do i = 1, is + ncol = idxmap%get_lc() + if (mask(i)) then + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle + endif + nxt = ncol + 1 + call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,ncol) + if (lip < 0) & + & call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) + + if (info >=0) then + if (nxt == lip) then + ncol = nxt + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-1,addsz=200) + if (info /= psb_success_) then + info=1 + ch_err='psb_ensure_size' + call psb_errpush(psb_err_from_subroutine_ai_,name,& + &a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + idxmap%loc_to_glob(nxt) = ip + call idxmap%set_lc(ncol) + endif + info = psb_success_ + else + ch_err='SearchInsKeyVal' + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + idx(i) = lip + info = psb_success_ + else + idx(i) = -1 + end if + enddo + + else + do i = 1, is + ncol = idxmap%get_lc() + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle + endif + nxt = ncol + 1 + call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,ncol) + if (lip < 0) & + & call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) + + if (info >=0) then + if (nxt == lip) then + ncol = nxt + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-1,addsz=200) + if (info /= psb_success_) then + info=1 + ch_err='psb_ensure_size' + call psb_errpush(psb_err_from_subroutine_ai_,name,& + &a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + idxmap%loc_to_glob(nxt) = ip + call idxmap%set_lc(ncol) + endif + info = psb_success_ + else + ch_err='SearchInsKeyVal' + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + idx(i) = lip + info = psb_success_ + enddo + + + end if + + else + ! Wrong state + idx = -1 + info = -1 + end if + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error(ictxt) + end if + return + + end subroutine hash_g2lv1_ins + + subroutine hash_g2lv2_ins(idxin,idxout,idxmap,info,mask) + implicit none + class(psb_hash_map), intent(inout) :: idxmap + integer, intent(in) :: idxin(:) + integer, intent(out) :: idxout(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + integer :: is, im + + is = size(idxin) + im = min(is,size(idxout)) + idxout(1:im) = idxin(1:im) + call idxmap%g2l_ins(idxout(1:im),info,mask) + if (is > im) then + write(0,*) 'g2lv2_ins err -3' + info = -3 + end if + + end subroutine hash_g2lv2_ins + + subroutine hash_init_vl(idxmap,ictxt,vl,info) + use psb_penv_mod + use psb_error_mod + use psb_sort_mod + use psb_realloc_mod + implicit none + class(psb_hash_map), intent(inout) :: idxmap + integer, intent(in) :: ictxt, vl(:) + integer, intent(out) :: info + ! To be implemented + integer :: iam, np, i, j, nlu, nl, m, nrt,int_err(5) + integer, allocatable :: vlu(:) + character(len=20), parameter :: name='hash_map_init_vl' + + info = 0 + call psb_info(ictxt,iam,np) + if (np < 0) then + write(psb_err_unit,*) 'Invalid ictxt:',ictxt + info = -1 + return + end if + + nl = size(vl) + + m = maxval(vl(1:nl)) + nrt = nl + call psb_sum(ictxt,nrt) + call psb_max(ictxt,m) + + allocate(vlu(nl), stat=info) + if (info /= 0) then + info = -1 + return + end if + + do i=1,nl + if ((vl(i)<1).or.(vl(i)>m)) then + info = psb_err_entry_out_of_bounds_ + int_err(1) = i + int_err(2) = vl(i) + int_err(3) = nl + int_err(4) = m + exit + endif + vlu(i) = vl(i) + end do + + if ((m /= nrt).and.(iam == psb_root_)) then + write(psb_err_unit,*) trim(name),& + & ' Warning: globalcheck=.false., but there is a mismatch' + write(psb_err_unit,*) trim(name),& + & ' : in the global sizes!',m,nrt + end if + ! + ! Now sort the input items, and check for duplicates + ! (unlikely, but possible) + ! + call psb_msort_unique(vlu,nlu) + if (nlu /= nl) then + write(0,*) 'Warning: duplicates in input' + end if + + call hash_init_vlu(idxmap,ictxt,m,nlu,vlu,info) + + end subroutine hash_init_vl + + subroutine hash_init_vg(idxmap,ictxt,vg,info) + use psb_penv_mod + use psb_error_mod + implicit none + class(psb_hash_map), intent(inout) :: idxmap + integer, intent(in) :: ictxt, vg(:) + integer, intent(out) :: info + ! To be implemented + integer :: iam, np, i, j, lc2, nl, nlu, n, nrt,int_err(5) + integer :: key, ih, ik, nh, idx, nbits, hsize, hmask + integer, allocatable :: vlu(:) + + info = 0 + call psb_info(ictxt,iam,np) + if (np < 0) then + write(psb_err_unit,*) 'Invalid ictxt:',ictxt + info = -1 + return + end if + + n = size(vg) + nl = 0 + do i=1, n + if ((vg(i)<0).or.(vg(i)>=np)) then + info = psb_err_partfunc_wrong_pid_ + int_err(1) = 3 + int_err(2) = vg(i) + int_err(3) = i + exit + endif + if (vg(i) == iam) nl = nl + 1 + end do + + allocate(vlu(nl), stat=info) + if (info /= 0) then + info = -1 + return + end if + + j = 0 + do i=1, n + if (vg(i) == iam) then + j = j + 1 + vlu(j) = i + end if + end do + + + call hash_init_vlu(idxmap,ictxt,n,nl,vlu,info) + + + end subroutine hash_init_vg + + + subroutine hash_init_vlu(idxmap,ictxt,ntot,nl,vlu,info) + use psb_penv_mod + use psb_error_mod + use psb_sort_mod + use psb_realloc_mod + implicit none + class(psb_hash_map), intent(inout) :: idxmap + integer, intent(in) :: ictxt, vlu(:), nl, ntot + integer, intent(out) :: info + ! To be implemented + integer :: iam, np, i, j, lc2, nlu, m, nrt,int_err(5) + integer :: key, ih, ik, nh, idx, nbits, hsize, hmask + character(len=20), parameter :: name='hash_map_init_vlu' + + info = 0 + call psb_info(ictxt,iam,np) + if (np < 0) then + write(psb_err_unit,*) 'Invalid ictxt:',ictxt + info = -1 + return + end if + + idxmap%global_rows = ntot + idxmap%global_cols = ntot + idxmap%local_rows = nl + idxmap%local_cols = nl + idxmap%ictxt = ictxt + idxmap%state = psb_desc_bld_ + call psb_get_mpicomm(ictxt,idxmap%mpic) + + lc2 = int(1.5*nl) + allocate(idxmap%hash,idxmap%loc_to_glob(lc2),stat=info) + if (info /= 0) then + info = -2 + return + end if + + call psb_hash_init(nl,idxmap%hash,info) + if (info /= 0) then + write(0,*) 'from Hash_Init inside init_vlu',info + info = -3 + return + endif + + do i=1, nl + idxmap%loc_to_glob(i) = vlu(i) + end do + + call hash_bld_g2l_map(idxmap,info) + call idxmap%set_state(psb_desc_bld_) + + end subroutine hash_init_vlu + + + + subroutine hash_bld_g2l_map(idxmap,info) + use psb_penv_mod + use psb_error_mod + use psb_sort_mod + use psb_realloc_mod + implicit none + class(psb_hash_map), intent(inout) :: idxmap + integer, intent(out) :: info + ! To be implemented + integer :: ictxt, iam, np, i, j, lc2, nlu, m, nrt,int_err(5), nl + integer :: key, ih, ik, nh, idx, nbits, hsize, hmask + character(len=20), parameter :: name='hash_map_init_vlu' + + info = 0 + ictxt = idxmap%get_ctxt() + + call psb_info(ictxt,iam,np) + if (np < 0) then + write(psb_err_unit,*) 'Invalid ictxt:',ictxt + info = -1 + return + end if + + nl = idxmap%get_lc() + + call psb_realloc(nl,2,idxmap%glb_lc,info) + + nbits = psb_hash_bits + hsize = 2**nbits + do + if (hsize < 0) then + ! This should never happen for sane values + ! of psb_max_hash_bits. + write(psb_err_unit,*) & + & 'Error: hash size overflow ',hsize,nbits + info = -2 + return + end if + if (hsize > nl) exit + if (nbits >= psb_max_hash_bits) exit + nbits = nbits + 1 + hsize = hsize * 2 + end do + + hmask = hsize - 1 + idxmap%hashvsize = hsize + idxmap%hashvmask = hmask + + if (info == psb_success_) & + & call psb_realloc(hsize+1,idxmap%hashv,info,lb=0) + if (info /= psb_success_) then + ! !$ ch_err='psb_realloc' + ! !$ call psb_errpush(info,name,a_err=ch_err) + ! !$ goto 9999 + info = -4 + return + end if + + idxmap%hashv(:) = 0 + + do i=1, nl + key = idxmap%loc_to_glob(i) + ih = iand(key,hmask) + idxmap%hashv(ih) = idxmap%hashv(ih) + 1 + end do + + nh = idxmap%hashv(0) + idx = 1 + + do i=1, hsize + idxmap%hashv(i-1) = idx + idx = idx + nh + nh = idxmap%hashv(i) + end do + + do i=1, nl + key = idxmap%loc_to_glob(i) + ih = iand(key,hmask) + idx = idxmap%hashv(ih) + idxmap%glb_lc(idx,1) = key + idxmap%glb_lc(idx,2) = i + idxmap%hashv(ih) = idxmap%hashv(ih) + 1 + end do + + do i = hsize, 1, -1 + idxmap%hashv(i) = idxmap%hashv(i-1) + end do + + idxmap%hashv(0) = 1 + do i=0, hsize-1 + idx = idxmap%hashv(i) + nh = idxmap%hashv(i+1) - idxmap%hashv(i) + if (nh > 1) then + call psb_msort(idxmap%glb_lc(idx:idx+nh-1,1),& + & ix=idxmap%glb_lc(idx:idx+nh-1,2),& + & flag=psb_sort_keep_idx_) + end if + end do + + end subroutine hash_bld_g2l_map + + + subroutine hash_asb(idxmap,info) + use psb_penv_mod + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + implicit none + class(psb_hash_map), intent(inout) :: idxmap + integer, intent(out) :: info + + integer :: nhal, ictxt, iam, np + + info = 0 + ictxt = idxmap%get_ctxt() + call psb_info(ictxt,iam,np) + + nhal = max(0,idxmap%local_cols-idxmap%local_rows) + + call hash_bld_g2l_map(idxmap,info) + if (info /= 0) then + write(0,*) 'Error from bld_g2l_map', info + return + end if + + call psb_free(idxmap%hash,info) + if (info == 0) deallocate(idxmap%hash,stat=info) + if (info /= 0) then + write(0,*) 'Error from hash free', info + return + end if + + call idxmap%set_state(psb_desc_asb_) + + end subroutine hash_asb + + function hash_get_fmt(idxmap) result(res) + implicit none + class(psb_hash_map), intent(in) :: idxmap + character(len=5) :: res + res = 'HASH' + end function hash_get_fmt + + + subroutine hash_inner_cnvs1(x,hashmask,hashv,glb_lc,nrm) + + integer, intent(in) :: hashmask,hashv(0:),glb_lc(:,:) + integer, intent(inout) :: x + integer, intent(in) :: nrm + integer :: i, ih, key, idx,nh,tmp,lb,ub,lm + ! + ! When a large descriptor is assembled the indices + ! are kept in a (hashed) list of ordered lists. + ! Thus we first hash the index, then we do a binary search on the + ! ordered sublist. The hashing is based on the low-order bits + ! for a width of psb_hash_bits + ! + + key = x + ih = iand(key,hashmask) + idx = hashv(ih) + nh = hashv(ih+1) - hashv(ih) + if (nh > 0) then + tmp = -1 + lb = idx + ub = idx+nh-1 + do + if (lb>ub) exit + lm = (lb+ub)/2 + if (key == glb_lc(lm,1)) then + tmp = lm + exit + else if (key 0) then + x = glb_lc(tmp,2) + if (x > nrm) then + x = -1 + end if + else + x = tmp + end if + end subroutine hash_inner_cnvs1 + + subroutine hash_inner_cnvs2(x,y,hashmask,hashv,glb_lc,nrm) + integer, intent(in) :: hashmask,hashv(0:),glb_lc(:,:) + integer, intent(in) :: x + integer, intent(out) :: y + integer, intent(in) :: nrm + integer :: i, ih, key, idx,nh,tmp,lb,ub,lm + ! + ! When a large descriptor is assembled the indices + ! are kept in a (hashed) list of ordered lists. + ! Thus we first hash the index, then we do a binary search on the + ! ordered sublist. The hashing is based on the low-order bits + ! for a width of psb_hash_bits + ! + + key = x + ih = iand(key,hashmask) + idx = hashv(ih) + nh = hashv(ih+1) - hashv(ih) + if (nh > 0) then + tmp = -1 + lb = idx + ub = idx+nh-1 + do + if (lb>ub) exit + lm = (lb+ub)/2 + if (key == glb_lc(lm,1)) then + tmp = lm + exit + else if (key 0) then + y = glb_lc(tmp,2) + if (y > nrm) then + y = -1 + end if + else + y = tmp + end if + end subroutine hash_inner_cnvs2 + + + subroutine hash_inner_cnv1(n,x,hashmask,hashv,glb_lc,mask,nrm) + integer, intent(in) :: n,hashmask,hashv(0:),glb_lc(:,:) + logical, intent(in), optional :: mask(:) + integer, intent(in), optional :: nrm + integer, intent(inout) :: x(:) + + integer :: i, ih, key, idx,nh,tmp,lb,ub,lm + ! + ! When a large descriptor is assembled the indices + ! are kept in a (hashed) list of ordered lists. + ! Thus we first hash the index, then we do a binary search on the + ! ordered sublist. The hashing is based on the low-order bits + ! for a width of psb_hash_bits + ! + if (present(mask)) then + do i=1, n + if (mask(i)) then + key = x(i) + ih = iand(key,hashmask) + idx = hashv(ih) + nh = hashv(ih+1) - hashv(ih) + if (nh > 0) then + tmp = -1 + lb = idx + ub = idx+nh-1 + do + if (lb>ub) exit + lm = (lb+ub)/2 + if (key == glb_lc(lm,1)) then + tmp = lm + exit + else if (key 0) then + x(i) = glb_lc(tmp,2) + if (present(nrm)) then + if (x(i) > nrm) then + x(i) = -1 + end if + end if + else + x(i) = tmp + end if + end if + end do + else + do i=1, n + key = x(i) + ih = iand(key,hashmask) + idx = hashv(ih) + nh = hashv(ih+1) - hashv(ih) + if (nh > 0) then + tmp = -1 + lb = idx + ub = idx+nh-1 + do + if (lb>ub) exit + lm = (lb+ub)/2 + if (key == glb_lc(lm,1)) then + tmp = lm + exit + else if (key 0) then + x(i) = glb_lc(tmp,2) + if (present(nrm)) then + if (x(i) > nrm) then + x(i) = -1 + end if + end if + else + x(i) = tmp + end if + end do + end if + end subroutine hash_inner_cnv1 + + subroutine hash_inner_cnv2(n,x,y,hashmask,hashv,glb_lc,mask,nrm) + integer, intent(in) :: n, hashmask,hashv(0:),glb_lc(:,:) + logical, intent(in), optional :: mask(:) + integer, intent(in), optional :: nrm + integer, intent(in) :: x(:) + integer, intent(out) :: y(:) + + integer :: i, ih, key, idx,nh,tmp,lb,ub,lm + ! + ! When a large descriptor is assembled the indices + ! are kept in a (hashed) list of ordered lists. + ! Thus we first hash the index, then we do a binary search on the + ! ordered sublist. The hashing is based on the low-order bits + ! for a width of psb_hash_bits + ! + if (present(mask)) then + do i=1, n + if (mask(i)) then + key = x(i) + ih = iand(key,hashmask) + if (ih > ubound(hashv,1) ) then + write(psb_err_unit,*) ' In inner cnv: ',ih,ubound(hashv) + end if + idx = hashv(ih) + nh = hashv(ih+1) - hashv(ih) + if (nh > 0) then + tmp = -1 + lb = idx + ub = idx+nh-1 + do + if (lb>ub) exit + lm = (lb+ub)/2 + if (key == glb_lc(lm,1)) then + tmp = lm + exit + else if (key 0) then + y(i) = glb_lc(tmp,2) + if (present(nrm)) then + if (y(i) > nrm) then + y(i) = -1 + end if + end if + else + y(i) = tmp + end if + end if + end do + + else + + do i=1, n + key = x(i) + ih = iand(key,hashmask) + if (ih > ubound(hashv,1) ) then + write(psb_err_unit,*) ' In inner cnv: ',ih,ubound(hashv) + end if + idx = hashv(ih) + nh = hashv(ih+1) - hashv(ih) + if (nh > 0) then + tmp = -1 + lb = idx + ub = idx+nh-1 + do + if (lb>ub) exit + lm = (lb+ub)/2 + if (key == glb_lc(lm,1)) then + tmp = lm + exit + else if (key 0) then + y(i) = glb_lc(tmp,2) + if (present(nrm)) then + if (y(i) > nrm) then + y(i) = -1 + end if + end if + else + y(i) = tmp + end if + end do + end if + end subroutine hash_inner_cnv2 + + +end module psb_hash_map_mod diff --git a/base/modules/psb_indx_map_mod.f03 b/base/modules/psb_indx_map_mod.f03 new file mode 100644 index 00000000..062d4ecb --- /dev/null +++ b/base/modules/psb_indx_map_mod.f03 @@ -0,0 +1,718 @@ +module psb_indx_map_mod + use psb_const_mod + use psb_desc_const_mod + + type :: psb_indx_map + + integer :: state = psb_desc_null_ + integer :: ictxt = -1 + integer :: mpic = -1 + integer :: global_rows = -1 + integer :: global_cols = -1 + integer :: local_rows = -1 + integer :: local_cols = -1 + + contains + + procedure, pass(idxmap) :: get_state => base_get_state + procedure, pass(idxmap) :: set_state => base_set_state + procedure, pass(idxmap) :: is_null => base_is_null + procedure, pass(idxmap) :: is_repl => base_is_repl + procedure, pass(idxmap) :: is_bld => base_is_bld + procedure, pass(idxmap) :: is_upd => base_is_upd + procedure, pass(idxmap) :: is_asb => base_is_asb + procedure, pass(idxmap) :: is_valid => base_is_valid + procedure, pass(idxmap) :: is_ovl => base_is_ovl + procedure, pass(idxmap) :: get_gr => base_get_gr + procedure, pass(idxmap) :: get_gc => base_get_gc + procedure, pass(idxmap) :: get_lr => base_get_lr + procedure, pass(idxmap) :: get_lc => base_get_lc + procedure, pass(idxmap) :: get_ctxt => base_get_ctxt + procedure, pass(idxmap) :: get_mpic => base_get_mpic + procedure, pass(idxmap) :: sizeof => base_sizeof + procedure, pass(idxmap) :: set_null => base_set_null + procedure, pass(idxmap) :: row_extendable => base_row_extendable + + procedure, pass(idxmap) :: set_gr => base_set_gr + procedure, pass(idxmap) :: set_gc => base_set_gc + procedure, pass(idxmap) :: set_lr => base_set_lr + procedure, pass(idxmap) :: set_lc => base_set_lc + procedure, pass(idxmap) :: set_ctxt => base_set_ctxt + procedure, pass(idxmap) :: set_mpic => base_set_mpic + + procedure, pass(idxmap) :: get_fmt => base_get_fmt + + procedure, pass(idxmap) :: asb => base_asb + procedure, pass(idxmap) :: free => base_free + + procedure, pass(idxmap) :: l2gs1 => base_l2gs1 + procedure, pass(idxmap) :: l2gs2 => base_l2gs2 + procedure, pass(idxmap) :: l2gv1 => base_l2gv1 + procedure, pass(idxmap) :: l2gv2 => base_l2gv2 + generic, public :: l2g => l2gs1, l2gs2, l2gv1, l2gv2 + + procedure, pass(idxmap) :: g2ls1 => base_g2ls1 + procedure, pass(idxmap) :: g2ls2 => base_g2ls2 + procedure, pass(idxmap) :: g2lv1 => base_g2lv1 + procedure, pass(idxmap) :: g2lv2 => base_g2lv2 + generic, public :: g2l => g2ls1, g2ls2, g2lv1, g2lv2 + + procedure, pass(idxmap) :: g2ls1_ins => base_g2ls1_ins + procedure, pass(idxmap) :: g2ls2_ins => base_g2ls2_ins + procedure, pass(idxmap) :: g2lv1_ins => base_g2lv1_ins + procedure, pass(idxmap) :: g2lv2_ins => base_g2lv2_ins + generic, public :: g2l_ins => g2ls1_ins, g2ls2_ins,& + & g2lv1_ins, g2lv2_ins + + procedure, pass(idxmap) :: fnd_owner => psb_indx_map_fnd_owner + procedure, pass(idxmap) :: init_vl => base_init_vl + generic, public :: init => init_vl + + end type psb_indx_map + + private :: base_get_state, base_set_state, base_is_repl, base_is_bld,& + & base_is_upd, base_is_asb, base_is_valid, base_is_ovl,& + & base_get_gr, base_get_gc, base_get_lr, base_get_lc, base_get_ctxt,& + & base_get_mpic, base_sizeof, base_set_null, base_set_gr,& + & base_set_gc, base_set_lr, base_set_lc, base_set_ctxt,& + & base_set_mpic, base_get_fmt, base_asb, base_free,& + & base_l2gs1, base_l2gs2, base_l2gv1, base_l2gv2,& + & base_g2ls1, base_g2ls2, base_g2lv1, base_g2lv2,& + & base_g2ls1_ins, base_g2ls2_ins, base_g2lv1_ins,& + & base_g2lv2_ins, base_init_vl, base_is_null, base_row_extendable + + interface + subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info) + import :: psb_indx_map + implicit none + integer, intent(in) :: idx(:) + integer, allocatable, intent(out) :: iprc(:) + class(psb_indx_map), intent(in) :: idxmap + integer, intent(out) :: info + end subroutine psb_indx_map_fnd_owner + end interface + +contains + + function base_get_state(idxmap) result(val) + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer :: val + + val = idxmap%state + + end function base_get_state + + + function base_get_gr(idxmap) result(val) + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer :: val + + val = idxmap%global_rows + + end function base_get_gr + + + function base_get_gc(idxmap) result(val) + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer :: val + + val = idxmap%global_cols + + end function base_get_gc + + + function base_get_lr(idxmap) result(val) + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer :: val + + val = idxmap%local_rows + + end function base_get_lr + + + function base_get_lc(idxmap) result(val) + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer :: val + + val = idxmap%local_cols + + end function base_get_lc + + + function base_get_ctxt(idxmap) result(val) + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer :: val + + val = idxmap%ictxt + + end function base_get_ctxt + + + function base_get_mpic(idxmap) result(val) + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer :: val + + val = idxmap%mpic + + end function base_get_mpic + + + subroutine base_set_state(idxmap,val) + implicit none + class(psb_indx_map), intent(inout) :: idxmap + integer, intent(in) :: val + + idxmap%state = val + end subroutine base_set_state + + subroutine base_set_ctxt(idxmap,val) + implicit none + class(psb_indx_map), intent(inout) :: idxmap + integer, intent(in) :: val + + idxmap%ictxt = val + end subroutine base_set_ctxt + + subroutine base_set_gr(idxmap,val) + implicit none + class(psb_indx_map), intent(inout) :: idxmap + integer, intent(in) :: val + + idxmap%global_rows = val + end subroutine base_set_gr + + subroutine base_set_gc(idxmap,val) + implicit none + class(psb_indx_map), intent(inout) :: idxmap + integer, intent(in) :: val + + idxmap%global_cols = val + end subroutine base_set_gc + + subroutine base_set_lr(idxmap,val) + implicit none + class(psb_indx_map), intent(inout) :: idxmap + integer, intent(in) :: val + + idxmap%local_rows = val + end subroutine base_set_lr + + subroutine base_set_lc(idxmap,val) + implicit none + class(psb_indx_map), intent(inout) :: idxmap + integer, intent(in) :: val + + idxmap%local_cols = val + end subroutine base_set_lc + + subroutine base_set_mpic(idxmap,val) + implicit none + class(psb_indx_map), intent(inout) :: idxmap + integer, intent(in) :: val + + idxmap%mpic = val + end subroutine base_set_mpic + + + function base_row_extendable(idxmap) result(val) + implicit none + class(psb_indx_map), intent(in) :: idxmap + logical :: val + val = .false. + end function base_row_extendable + + function base_is_repl(idxmap) result(val) + implicit none + class(psb_indx_map), intent(in) :: idxmap + logical :: val + val = .false. + end function base_is_repl + + function base_is_null(idxmap) result(val) + implicit none + class(psb_indx_map), intent(in) :: idxmap + logical :: val + val = (idxmap%state == psb_desc_null_) + end function base_is_null + + + function base_is_bld(idxmap) result(val) + implicit none + class(psb_indx_map), intent(in) :: idxmap + logical :: val + val = (idxmap%state == psb_desc_bld_).or.& + & (idxmap%state == psb_desc_ovl_bld_) + end function base_is_bld + + function base_is_upd(idxmap) result(val) + implicit none + class(psb_indx_map), intent(in) :: idxmap + logical :: val + val = (idxmap%state == psb_desc_upd_) + end function base_is_upd + + function base_is_asb(idxmap) result(val) + implicit none + class(psb_indx_map), intent(in) :: idxmap + logical :: val + val = (idxmap%state == psb_desc_asb_).or.& + & (idxmap%state == psb_desc_ovl_asb_) + end function base_is_asb + + function base_is_valid(idxmap) result(val) + implicit none + class(psb_indx_map), intent(in) :: idxmap + logical :: val + val = idxmap%is_bld().or.idxmap%is_upd().or.idxmap%is_asb() + end function base_is_valid + + + function base_is_ovl(idxmap) result(val) + implicit none + class(psb_indx_map), intent(in) :: idxmap + logical :: val + val = (idxmap%state == psb_desc_ovl_bld_).or.& + & (idxmap%state == psb_desc_ovl_asb_) + end function base_is_ovl + + function base_sizeof(idxmap) result(val) + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer(psb_long_int_k_) :: val + + val = 8 * psb_sizeof_int + end function base_sizeof + + + ! !!!!!!!!!!!!!!!! + ! + ! !!!!!!!!!!!!!!!! + subroutine base_l2gs1(idx,idxmap,info,mask,owned) + use psb_error_mod + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer, intent(inout) :: idx + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + Integer :: err_act + character(len=20) :: name='base_l2g' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine base_l2gs1 + + subroutine base_l2gs2(idxin,idxout,idxmap,info,mask,owned) + use psb_error_mod + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer, intent(in) :: idxin + integer, intent(out) :: idxout + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + + Integer :: err_act + character(len=20) :: name='base_l2g' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine base_l2gs2 + + + subroutine base_l2gv1(idx,idxmap,info,mask,owned) + use psb_error_mod + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer, intent(inout) :: idx(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + Integer :: err_act + character(len=20) :: name='base_l2g' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + end subroutine base_l2gv1 + + subroutine base_l2gv2(idxin,idxout,idxmap,info,mask,owned) + use psb_error_mod + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer, intent(in) :: idxin(:) + integer, intent(out) :: idxout(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + Integer :: err_act + character(len=20) :: name='base_l2g' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine base_l2gv2 + + + subroutine base_g2ls1(idx,idxmap,info,mask,owned) + use psb_error_mod + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer, intent(inout) :: idx + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + Integer :: err_act + character(len=20) :: name='base_g2l' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine base_g2ls1 + + subroutine base_g2ls2(idxin,idxout,idxmap,info,mask,owned) + use psb_error_mod + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer, intent(in) :: idxin + integer, intent(out) :: idxout + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + + Integer :: err_act + character(len=20) :: name='base_g2l' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine base_g2ls2 + + + subroutine base_g2lv1(idx,idxmap,info,mask,owned) + use psb_error_mod + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer, intent(inout) :: idx(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + Integer :: err_act + character(len=20) :: name='base_g2l' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine base_g2lv1 + + subroutine base_g2lv2(idxin,idxout,idxmap,info,mask,owned) + use psb_error_mod + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer, intent(in) :: idxin(:) + integer, intent(out) :: idxout(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + + Integer :: err_act + character(len=20) :: name='base_g2l' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + + end subroutine base_g2lv2 + + + + subroutine base_g2ls1_ins(idx,idxmap,info,mask) + use psb_error_mod + implicit none + class(psb_indx_map), intent(inout) :: idxmap + integer, intent(inout) :: idx + integer, intent(out) :: info + logical, intent(in), optional :: mask + Integer :: err_act + character(len=20) :: name='base_g2l_ins' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine base_g2ls1_ins + + subroutine base_g2ls2_ins(idxin,idxout,idxmap,info,mask) + use psb_error_mod + implicit none + class(psb_indx_map), intent(inout) :: idxmap + integer, intent(in) :: idxin + integer, intent(out) :: idxout + integer, intent(out) :: info + logical, intent(in), optional :: mask + + Integer :: err_act + character(len=20) :: name='base_g2l_ins' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine base_g2ls2_ins + + + subroutine base_g2lv1_ins(idx,idxmap,info,mask) + use psb_error_mod + implicit none + class(psb_indx_map), intent(inout) :: idxmap + integer, intent(inout) :: idx(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + + Integer :: err_act + character(len=20) :: name='base_g2l_ins' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine base_g2lv1_ins + + subroutine base_g2lv2_ins(idxin,idxout,idxmap,info,mask) + use psb_error_mod + implicit none + class(psb_indx_map), intent(inout) :: idxmap + integer, intent(in) :: idxin(:) + integer, intent(out) :: idxout(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + Integer :: err_act + character(len=20) :: name='base_g2l_ins' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine base_g2lv2_ins + + + subroutine base_asb(idxmap,info) + use psb_error_mod + implicit none + class(psb_indx_map), intent(inout) :: idxmap + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='base_asb' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine base_asb + + subroutine base_free(idxmap) + use psb_error_mod + implicit none + class(psb_indx_map), intent(inout) :: idxmap + + Integer :: err_act + character(len=20) :: name='base_free' + logical, parameter :: debug=.false. + + ! almost nothing to be done here + idxmap%state = -1 + idxmap%ictxt = -1 + idxmap%mpic = -1 + idxmap%global_rows = -1 + idxmap%global_cols = -1 + idxmap%local_rows = -1 + idxmap%local_cols = -1 + + return + + end subroutine base_free + + subroutine base_set_null(idxmap) + implicit none + class(psb_indx_map), intent(inout) :: idxmap + + idxmap%state = psb_desc_null_ + idxmap%ictxt = -1 + idxmap%mpic = -1 + idxmap%global_rows = -1 + idxmap%global_cols = -1 + idxmap%local_rows = -1 + idxmap%local_cols = -1 + + end subroutine base_set_null + + + function base_get_fmt(idxmap) result(res) + implicit none + class(psb_indx_map), intent(in) :: idxmap + character(len=5) :: res + res = 'NULL' + end function base_get_fmt + + + subroutine base_init_vl(idxmap,ictxt,vl,info) + use psb_penv_mod + use psb_error_mod + implicit none + class(psb_indx_map), intent(inout) :: idxmap + integer, intent(in) :: ictxt, vl(:) + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='base_init_vl' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + end subroutine base_init_vl + + + +end module psb_indx_map_mod diff --git a/base/modules/psb_list_map_mod.f03 b/base/modules/psb_list_map_mod.f03 new file mode 100644 index 00000000..8bfe3299 --- /dev/null +++ b/base/modules/psb_list_map_mod.f03 @@ -0,0 +1,593 @@ +module psb_list_map_mod + use psb_const_mod + use psb_desc_const_mod + use psb_indx_map_mod + + type, extends(psb_indx_map) :: psb_list_map + integer :: pnt_h = -1 + integer, allocatable :: loc_to_glob(:), glob_to_loc(:) + contains + procedure, pass(idxmap) :: init_vl => list_initvl + + procedure, pass(idxmap) :: sizeof => list_sizeof + procedure, pass(idxmap) :: asb => list_asb + procedure, pass(idxmap) :: free => list_free + procedure, pass(idxmap) :: get_fmt => list_get_fmt + procedure, pass(idxmap) :: row_extendable => list_row_extendable + + procedure, pass(idxmap) :: l2gs1 => list_l2gs1 + procedure, pass(idxmap) :: l2gs2 => list_l2gs2 + procedure, pass(idxmap) :: l2gv1 => list_l2gv1 + procedure, pass(idxmap) :: l2gv2 => list_l2gv2 + + procedure, pass(idxmap) :: g2ls1 => list_g2ls1 + procedure, pass(idxmap) :: g2ls2 => list_g2ls2 + procedure, pass(idxmap) :: g2lv1 => list_g2lv1 + procedure, pass(idxmap) :: g2lv2 => list_g2lv2 + + procedure, pass(idxmap) :: g2ls1_ins => list_g2ls1_ins + procedure, pass(idxmap) :: g2ls2_ins => list_g2ls2_ins + procedure, pass(idxmap) :: g2lv1_ins => list_g2lv1_ins + procedure, pass(idxmap) :: g2lv2_ins => list_g2lv2_ins + + end type psb_list_map + + private :: list_initvl, list_sizeof, list_asb, list_free,& + & list_get_fmt, list_l2gs1, list_l2gs2, list_l2gv1,& + & list_l2gv2, list_g2ls1, list_g2ls2, list_g2lv1,& + & list_g2lv2, list_g2ls1_ins, list_g2ls2_ins,& + & list_g2lv1_ins, list_g2lv2_ins, list_row_extendable + +contains + + function list_row_extendable(idxmap) result(val) + implicit none + class(psb_list_map), intent(in) :: idxmap + logical :: val + val = .true. + end function list_row_extendable + + function list_sizeof(idxmap) result(val) + implicit none + class(psb_list_map), intent(in) :: idxmap + integer(psb_long_int_k_) :: val + + val = idxmap%psb_indx_map%sizeof() + + if (allocated(idxmap%loc_to_glob)) & + & val = val + size(idxmap%loc_to_glob)*psb_sizeof_int + if (allocated(idxmap%glob_to_loc)) & + & val = val + size(idxmap%glob_to_loc)*psb_sizeof_int + + end function list_sizeof + + + subroutine list_free(idxmap) + implicit none + class(psb_list_map), intent(inout) :: idxmap + + if (allocated(idxmap%loc_to_glob)) & + & deallocate(idxmap%loc_to_glob) + if (allocated(idxmap%glob_to_loc)) & + & deallocate(idxmap%glob_to_loc) + + call idxmap%psb_indx_map%free() + + end subroutine list_free + + + subroutine list_l2gs1(idx,idxmap,info,mask,owned) + implicit none + class(psb_list_map), intent(in) :: idxmap + integer, intent(inout) :: idx + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + integer :: idxv(1) + info = 0 + if (present(mask)) then + if (.not.mask) return + end if + + idxv(1) = idx + call idxmap%l2g(idxv,info,owned=owned) + idx = idxv(1) + + end subroutine list_l2gs1 + + subroutine list_l2gs2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_list_map), intent(in) :: idxmap + integer, intent(in) :: idxin + integer, intent(out) :: idxout + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + + idxout = idxin + call idxmap%l2g(idxout,info,mask,owned) + + end subroutine list_l2gs2 + + + subroutine list_l2gv1(idx,idxmap,info,mask,owned) + implicit none + class(psb_list_map), intent(in) :: idxmap + integer, intent(inout) :: idx(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer :: i + logical :: owned_ + info = 0 + + if (present(mask)) then + if (size(mask) < size(idx)) then + info = -1 + return + end if + end if + if (present(owned)) then + owned_ = owned + else + owned_ = .false. + end if + + if (present(mask)) then + + do i=1, size(idx) + if (mask(i)) then + if ((1<=idx(i)).and.(idx(i) <= idxmap%get_lr())) then + idx(i) = idxmap%loc_to_glob(idx(i)) + else if ((idxmap%get_lr() < idx(i)).and.(idx(i) <= idxmap%local_cols)& + & .and.(.not.owned_)) then + idx(i) = idxmap%loc_to_glob(idx(i)) + else + idx(i) = -1 + end if + end if + end do + + else if (.not.present(mask)) then + + do i=1, size(idx) + if ((1<=idx(i)).and.(idx(i) <= idxmap%get_lr())) then + idx(i) = idxmap%loc_to_glob(idx(i)) + else if ((idxmap%get_lr() < idx(i)).and.(idx(i) <= idxmap%local_cols)& + & .and.(.not.owned_)) then + idx(i) = idxmap%loc_to_glob(idx(i)) + else + idx(i) = -1 + end if + end do + + end if + + end subroutine list_l2gv1 + + subroutine list_l2gv2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_list_map), intent(in) :: idxmap + integer, intent(in) :: idxin(:) + integer, intent(out) :: idxout(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer :: is, im + + is = size(idxin) + im = min(is,size(idxout)) + idxout(1:im) = idxin(1:im) + call idxmap%l2g(idxout(1:im),info,mask,owned) + if (is > im) info = -3 + + end subroutine list_l2gv2 + + + subroutine list_g2ls1(idx,idxmap,info,mask,owned) + implicit none + class(psb_list_map), intent(in) :: idxmap + integer, intent(inout) :: idx + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + integer :: idxv(1) + info = 0 + + if (present(mask)) then + if (.not.mask) return + end if + + idxv(1) = idx + call idxmap%g2l(idxv,info,owned=owned) + idx = idxv(1) + + end subroutine list_g2ls1 + + subroutine list_g2ls2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_list_map), intent(in) :: idxmap + integer, intent(in) :: idxin + integer, intent(out) :: idxout + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + + idxout = idxin + call idxmap%g2l(idxout,info,mask,owned) + + end subroutine list_g2ls2 + + + subroutine list_g2lv1(idx,idxmap,info,mask,owned) + use psb_sort_mod + implicit none + class(psb_list_map), intent(in) :: idxmap + integer, intent(inout) :: idx(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer :: i, nv, is, ix + logical :: owned_ + + info = 0 + + if (present(mask)) then + if (size(mask) < size(idx)) then + info = -1 + return + end if + end if + if (present(owned)) then + owned_ = owned + else + owned_ = .false. + end if + + is = size(idx) + + if (present(mask)) then + if (idxmap%is_valid()) then + do i=1,is + if (mask(i)) then + if ((1 <= idx(i)).and.(idx(i) <= idxmap%global_rows)) then + ix = idxmap%glob_to_loc(idx(i)) + if ((ix > idxmap%get_lr()).and.(owned_)) ix = -1 + idx(i) = ix + else + idx(i) = -1 + end if + end if + end do + else + idx(1:is) = -1 + info = -1 + end if + + else if (.not.present(mask)) then + + if (idxmap%is_valid()) then + do i=1, is + if ((1 <= idx(i)).and.(idx(i) <= idxmap%global_rows)) then + ix = idxmap%glob_to_loc(idx(i)) + if ((ix > idxmap%get_lr()).and.(owned_)) ix = -1 + idx(i) = ix + else + idx(i) = -1 + end if + end do + else + idx(1:is) = -1 + info = -1 + end if + + end if + + end subroutine list_g2lv1 + + subroutine list_g2lv2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_list_map), intent(in) :: idxmap + integer, intent(in) :: idxin(:) + integer, intent(out) :: idxout(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + + integer :: is, im + + is = size(idxin) + im = min(is,size(idxout)) + idxout(1:im) = idxin(1:im) + call idxmap%g2l(idxout(1:im),info,mask,owned) + if (is > im) info = -3 + + end subroutine list_g2lv2 + + + + subroutine list_g2ls1_ins(idx,idxmap,info,mask) + use psb_realloc_mod + use psb_sort_mod + implicit none + class(psb_list_map), intent(inout) :: idxmap + integer, intent(inout) :: idx + integer, intent(out) :: info + logical, intent(in), optional :: mask + + integer :: idxv(1) + + info = 0 + if (present(mask)) then + if (.not.mask) return + end if + idxv(1) = idx + call idxmap%g2l_ins(idxv,info) + idx = idxv(1) + + end subroutine list_g2ls1_ins + + subroutine list_g2ls2_ins(idxin,idxout,idxmap,info,mask) + implicit none + class(psb_list_map), intent(inout) :: idxmap + integer, intent(in) :: idxin + integer, intent(out) :: idxout + integer, intent(out) :: info + logical, intent(in), optional :: mask + + idxout = idxin + call idxmap%g2l_ins(idxout,info) + + end subroutine list_g2ls2_ins + + + subroutine list_g2lv1_ins(idx,idxmap,info,mask) + use psb_realloc_mod + use psb_sort_mod + implicit none + class(psb_list_map), intent(inout) :: idxmap + integer, intent(inout) :: idx(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + integer :: i, nv, is, ix + + info = 0 + is = size(idx) + + if (present(mask)) then + if (size(mask) < size(idx)) then + info = -1 + return + end if + end if + + + if (idxmap%is_asb()) then + ! State is wrong for this one ! + idx = -1 + info = -1 + + else if (idxmap%is_valid()) then + + if (present(mask)) then + do i=1, is + if (mask(i)) then + if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then + ix = idxmap%glob_to_loc(idx(i)) + if (ix < 0) then + ix = idxmap%local_cols + 1 + call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=500) + if (info /= 0) then + info = -4 + return + end if + idxmap%local_cols = ix + idxmap%loc_to_glob(ix) = idx(i) + idxmap%glob_to_loc(idx(i)) = ix + end if + idx(i) = ix + else + idx(i) = -1 + end if + end if + end do + + else if (.not.present(mask)) then + + do i=1, is + if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then + ix = idxmap%glob_to_loc(idx(i)) + if (ix < 0) then + ix = idxmap%local_cols + 1 + call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=500) + if (info /= 0) then + info = -4 + return + end if + idxmap%local_cols = ix + idxmap%loc_to_glob(ix) = idx(i) + idxmap%glob_to_loc(idx(i)) = ix + end if + idx(i) = ix + else + idx(i) = -1 + end if + end do + end if + + else + idx = -1 + info = -1 + end if + + end subroutine list_g2lv1_ins + + subroutine list_g2lv2_ins(idxin,idxout,idxmap,info,mask) + implicit none + class(psb_list_map), intent(inout) :: idxmap + integer, intent(in) :: idxin(:) + integer, intent(out) :: idxout(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + integer :: is, im + + is = size(idxin) + im = min(is,size(idxout)) + idxout(1:im) = idxin(1:im) + call idxmap%g2l_ins(idxout(1:im),info,mask) + if (is > im) info = -3 + + end subroutine list_g2lv2_ins + + + +!!$ +!!$ subroutine list_initvg(idxmap,vg,ictxt,info) +!!$ use psb_penv_mod +!!$ use psb_error_mod +!!$ implicit none +!!$ class(psb_list_map), intent(inout) :: idxmap +!!$ integer, intent(in) :: ictxt, vg(:) +!!$ integer, intent(out) :: info +!!$ ! To be implemented +!!$ integer :: iam, np, i, j, n, nl +!!$ +!!$ +!!$ info = 0 +!!$ call psb_info(ictxt,iam,np) +!!$ if (np < 0) then +!!$ write(psb_err_unit,*) 'Invalid ictxt:',ictxt +!!$ info = -1 +!!$ return +!!$ end if +!!$ n = size(vg) +!!$ +!!$ idxmap%global_rows = n +!!$ idxmap%global_cols = n +!!$ +!!$ allocate(idxmap%loc_to_glob(n),idxmap%glob_to_loc(n),& +!!$ & stat=info) +!!$ if (info /= 0) then +!!$ info = -2 +!!$ return +!!$ end if +!!$ +!!$ idxmap%ictxt = ictxt +!!$ idxmap%state = psb_desc_bld_ +!!$ call psb_get_mpicomm(ictxt,idxmap%mpic) +!!$ +!!$ nl = 0 +!!$ do i=1, n +!!$ if ((vg(i) > np-1).or.(vg(i) < 0)) then +!!$ info=psb_err_partfunc_wrong_pid_ +!!$ exit +!!$ end if +!!$ if (vg(i) == iam) then +!!$ ! this point belongs to me +!!$ nl = nl + 1 +!!$ idxmap%glob_to_loc(i) = nl +!!$ idxmap%loc_to_glob(nl) = i +!!$ else +!!$ idxmap%glob_to_loc(i) = -(np+vg(i)+1) +!!$ end if +!!$ end do +!!$ +!!$ call idxmap%set_lr(nl) +!!$ call idxmap%set_lc(nl) +!!$ +!!$ end subroutine list_initvg +!!$ + + subroutine list_initvl(idxmap,ictxt,vL,info) + use psb_penv_mod + use psb_error_mod + implicit none + class(psb_list_map), intent(inout) :: idxmap + integer, intent(in) :: ictxt, vl(:) + integer, intent(out) :: info + ! To be implemented + integer :: iam, np, i, ix, nl, n, nrt + + info = 0 + call psb_info(ictxt,iam,np) + if (np < 0) then + write(psb_err_unit,*) 'Invalid ictxt:',ictxt + info = -1 + return + end if + + nl = size(vl) + + + n = maxval(vl(1:nl)) + nrt = nl + call psb_sum(ictxt,nrt) + call psb_max(ictxt,n) + + + if (n /= nrt) then + write(psb_err_unit,*) 'Size mismatch', n, nrt + info = -1 + return + end if + + idxmap%global_rows = n + idxmap%global_cols = n + + allocate(idxmap%loc_to_glob(n),idxmap%glob_to_loc(n),stat=info) + if (info /= 0) then + info = -2 + return + end if + + idxmap%ictxt = ictxt + idxmap%state = psb_desc_bld_ + call psb_get_mpicomm(ictxt,idxmap%mpic) + do i=1, n + idxmap%glob_to_loc(i) = -1 + end do + + do i=1, nl + ix = vl(i) + idxmap%loc_to_glob(i) = ix + idxmap%glob_to_loc(ix) = i + end do + + idxmap%local_rows = nl + idxmap%local_cols = nl + call idxmap%set_state(psb_desc_bld_) + + end subroutine list_initvl + + + subroutine list_asb(idxmap,info) + use psb_penv_mod + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + implicit none + class(psb_list_map), intent(inout) :: idxmap + integer, intent(out) :: info + + integer :: nhal, ictxt, iam, np + + info = 0 + ictxt = idxmap%get_ctxt() + call psb_info(ictxt,iam,np) + + nhal = idxmap%local_cols + call psb_realloc(nhal,idxmap%loc_to_glob,info) + + call idxmap%set_state(psb_desc_asb_) + + end subroutine list_asb + + function list_get_fmt(idxmap) result(res) + implicit none + class(psb_list_map), intent(in) :: idxmap + character(len=5) :: res + res = 'LIST' + end function list_get_fmt + + +end module psb_list_map_mod diff --git a/base/modules/psb_repl_map_mod.f03 b/base/modules/psb_repl_map_mod.f03 new file mode 100644 index 00000000..fc65425d --- /dev/null +++ b/base/modules/psb_repl_map_mod.f03 @@ -0,0 +1,502 @@ +module psb_repl_map_mod + use psb_const_mod + use psb_desc_const_mod + use psb_indx_map_mod + + type, extends(psb_indx_map) :: psb_repl_map + + contains + + procedure, pass(idxmap) :: repl_map_init => repl_init + + procedure, pass(idxmap) :: is_repl => repl_is_repl + procedure, pass(idxmap) :: asb => repl_asb + procedure, pass(idxmap) :: free => repl_free + procedure, pass(idxmap) :: get_fmt => repl_get_fmt + + procedure, pass(idxmap) :: l2gs1 => repl_l2gs1 + procedure, pass(idxmap) :: l2gs2 => repl_l2gs2 + procedure, pass(idxmap) :: l2gv1 => repl_l2gv1 + procedure, pass(idxmap) :: l2gv2 => repl_l2gv2 + + procedure, pass(idxmap) :: g2ls1 => repl_g2ls1 + procedure, pass(idxmap) :: g2ls2 => repl_g2ls2 + procedure, pass(idxmap) :: g2lv1 => repl_g2lv1 + procedure, pass(idxmap) :: g2lv2 => repl_g2lv2 + + procedure, pass(idxmap) :: g2ls1_ins => repl_g2ls1_ins + procedure, pass(idxmap) :: g2ls2_ins => repl_g2ls2_ins + procedure, pass(idxmap) :: g2lv1_ins => repl_g2lv1_ins + procedure, pass(idxmap) :: g2lv2_ins => repl_g2lv2_ins + + procedure, pass(idxmap) :: fnd_owner => repl_fnd_owner + + end type psb_repl_map + + private :: repl_init, repl_is_repl, repl_asb, repl_free,& + & repl_get_fmt, repl_l2gs1, repl_l2gs2, repl_l2gv1,& + & repl_l2gv2, repl_g2ls1, repl_g2ls2, repl_g2lv1,& + & repl_g2lv2, repl_g2ls1_ins, repl_g2ls2_ins,& + & repl_g2lv1_ins, repl_g2lv2_ins + + +contains + + function repl_is_repl(idxmap) result(val) + implicit none + class(psb_repl_map), intent(in) :: idxmap + logical :: val + val = .true. + end function repl_is_repl + + + function repl_sizeof(idxmap) result(val) + implicit none + class(psb_repl_map), intent(in) :: idxmap + integer(psb_long_int_k_) :: val + + val = idxmap%psb_indx_map%sizeof() + + end function repl_sizeof + + + + subroutine repl_l2gs1(idx,idxmap,info,mask,owned) + implicit none + class(psb_repl_map), intent(in) :: idxmap + integer, intent(inout) :: idx + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + integer :: idxv(1) + info = 0 + if (present(mask)) then + if (.not.mask) return + end if + + idxv(1) = idx + call idxmap%l2g(idxv,info,owned=owned) + idx = idxv(1) + + end subroutine repl_l2gs1 + + subroutine repl_l2gs2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_repl_map), intent(in) :: idxmap + integer, intent(in) :: idxin + integer, intent(out) :: idxout + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + + idxout = idxin + call idxmap%l2g(idxout,info,mask,owned) + + end subroutine repl_l2gs2 + + + subroutine repl_l2gv1(idx,idxmap,info,mask,owned) + implicit none + class(psb_repl_map), intent(in) :: idxmap + integer, intent(inout) :: idx(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer :: i + logical :: owned_ + info = 0 + + if (present(mask)) then + if (size(mask) < size(idx)) then + info = -1 + return + end if + end if + if (present(owned)) then + owned_ = owned + else + owned_ = .false. + end if + + if (present(mask)) then + + do i=1, size(idx) + if (mask(i)) then + if ((1<=idx(i)).and.(idx(i) <= idxmap%local_rows)) then + ! do nothing + else + idx(i) = -1 + end if + end if + end do + + else if (.not.present(mask)) then + + do i=1, size(idx) + if ((1<=idx(i)).and.(idx(i) <= idxmap%local_rows)) then + ! do nothing + else + idx(i) = -1 + end if + end do + + end if + + end subroutine repl_l2gv1 + + subroutine repl_l2gv2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_repl_map), intent(in) :: idxmap + integer, intent(in) :: idxin(:) + integer, intent(out) :: idxout(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer :: is, im + + is = size(idxin) + im = min(is,size(idxout)) + idxout(1:im) = idxin(1:im) + call idxmap%l2g(idxout(1:im),info,mask,owned) + if (is > im) info = -3 + + end subroutine repl_l2gv2 + + + subroutine repl_g2ls1(idx,idxmap,info,mask,owned) + implicit none + class(psb_repl_map), intent(in) :: idxmap + integer, intent(inout) :: idx + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + integer :: idxv(1) + info = 0 + + if (present(mask)) then + if (.not.mask) return + end if + + idxv(1) = idx + call idxmap%g2l(idxv,info,owned=owned) + idx = idxv(1) + + end subroutine repl_g2ls1 + + subroutine repl_g2ls2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_repl_map), intent(in) :: idxmap + integer, intent(in) :: idxin + integer, intent(out) :: idxout + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + + idxout = idxin + call idxmap%g2l(idxout,info,mask,owned) + + end subroutine repl_g2ls2 + + + subroutine repl_g2lv1(idx,idxmap,info,mask,owned) + implicit none + class(psb_repl_map), intent(in) :: idxmap + integer, intent(inout) :: idx(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer :: i, nv, is + logical :: owned_ + + info = 0 + + if (present(mask)) then + if (size(mask) < size(idx)) then + info = -1 + return + end if + end if + if (present(owned)) then + owned_ = owned + else + owned_ = .false. + end if + + is = size(idx) + + if (present(mask)) then + + if (idxmap%is_asb()) then + do i=1, is + if (mask(i)) then + if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then + ! do nothing + else + idx(i) = -1 + end if + end if + end do + else if (idxmap%is_valid()) then + do i=1,is + if (mask(i)) then + if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then + ! do nothing + + else + idx(i) = -1 + end if + end if + end do + else + idx(1:is) = -1 + info = -1 + end if + + else if (.not.present(mask)) then + + if (idxmap%is_asb()) then + do i=1, is + if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then + ! do nothing + else + idx(i) = -1 + end if + end do + else if (idxmap%is_valid()) then + do i=1,is + if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then + ! do nothing + else + idx(i) = -1 + end if + end do + else + idx(1:is) = -1 + info = -1 + end if + + end if + + end subroutine repl_g2lv1 + + subroutine repl_g2lv2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_repl_map), intent(in) :: idxmap + integer, intent(in) :: idxin(:) + integer, intent(out) :: idxout(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + + integer :: is, im + + is = size(idxin) + im = min(is,size(idxout)) + idxout(1:im) = idxin(1:im) + call idxmap%g2l(idxout(1:im),info,mask,owned) + if (is > im) info = -3 + + end subroutine repl_g2lv2 + + + + subroutine repl_g2ls1_ins(idx,idxmap,info,mask) + use psb_realloc_mod + use psb_sort_mod + implicit none + class(psb_repl_map), intent(inout) :: idxmap + integer, intent(inout) :: idx + integer, intent(out) :: info + logical, intent(in), optional :: mask + + integer :: idxv(1) + + info = 0 + if (present(mask)) then + if (.not.mask) return + end if + idxv(1) = idx + call idxmap%g2l_ins(idxv,info) + idx = idxv(1) + + end subroutine repl_g2ls1_ins + + subroutine repl_g2ls2_ins(idxin,idxout,idxmap,info,mask) + implicit none + class(psb_repl_map), intent(inout) :: idxmap + integer, intent(in) :: idxin + integer, intent(out) :: idxout + integer, intent(out) :: info + logical, intent(in), optional :: mask + + idxout = idxin + call idxmap%g2l_ins(idxout,info) + + end subroutine repl_g2ls2_ins + + + subroutine repl_g2lv1_ins(idx,idxmap,info,mask) + use psb_realloc_mod + use psb_sort_mod + implicit none + class(psb_repl_map), intent(inout) :: idxmap + integer, intent(inout) :: idx(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + integer :: i, nv, is, ix + + info = 0 + is = size(idx) + + if (present(mask)) then + if (size(mask) < size(idx)) then + info = -1 + return + end if + end if + + + if (idxmap%is_asb()) then + ! State is wrong for this one ! + idx = -1 + info = -1 + + else if (idxmap%is_valid()) then + + if (present(mask)) then + do i=1, is + if (mask(i)) then + if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then + ! do nothing + else + idx(i) = -1 + end if + end if + end do + + else if (.not.present(mask)) then + + do i=1, is + if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then + ! do nothing + else + idx(i) = -1 + end if + end do + end if + + else + idx = -1 + info = -1 + end if + + end subroutine repl_g2lv1_ins + + subroutine repl_g2lv2_ins(idxin,idxout,idxmap,info,mask) + implicit none + class(psb_repl_map), intent(inout) :: idxmap + integer, intent(in) :: idxin(:) + integer, intent(out) :: idxout(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + integer :: is, im + + is = size(idxin) + im = min(is,size(idxout)) + idxout(1:im) = idxin(1:im) + call idxmap%g2l_ins(idxout(1:im),info,mask) + if (is > im) info = -3 + + end subroutine repl_g2lv2_ins + + + subroutine repl_fnd_owner(idx,iprc,idxmap,info) + use psb_penv_mod + implicit none + integer, intent(in) :: idx(:) + integer, allocatable, intent(out) :: iprc(:) + class(psb_repl_map), intent(in) :: idxmap + integer, intent(out) :: info + integer :: ictxt, iam, np, nv + + ictxt = idxmap%get_ctxt() + call psb_info(ictxt,iam,np) + + write(0,*) iam, ' REPL fnd_owner' + nv = size(idx) + allocate(iprc(nv),stat=info) + if (info /= 0) then + write(0,*) 'Memory allocation failure in repl_map_fnd-owner' + return + end if + iprc(1:nv) = iam + + end subroutine repl_fnd_owner + + + subroutine repl_init(idxmap,ictxt,nl,info) + use psb_penv_mod + use psb_error_mod + implicit none + class(psb_repl_map), intent(inout) :: idxmap + integer, intent(in) :: ictxt, nl + integer, intent(out) :: info + ! To be implemented + integer :: iam, np, i, j, ntot + integer, allocatable :: vnl(:) + + info = 0 + call psb_info(ictxt,iam,np) + if (np < 0) then + write(psb_err_unit,*) 'Invalid ictxt:',ictxt + info = -1 + return + end if + + + idxmap%global_rows = nl + idxmap%global_cols = nl + idxmap%local_rows = nl + idxmap%local_cols = nl + idxmap%ictxt = ictxt + idxmap%state = psb_desc_bld_ + call psb_get_mpicomm(ictxt,idxmap%mpic) + call idxmap%set_state(psb_desc_bld_) + + end subroutine repl_init + + + subroutine repl_asb(idxmap,info) + use psb_penv_mod + use psb_error_mod + implicit none + class(psb_repl_map), intent(inout) :: idxmap + integer, intent(out) :: info + + integer :: ictxt, iam, np + + info = 0 + ictxt = idxmap%get_ctxt() + call psb_info(ictxt,iam,np) + + call idxmap%set_state(psb_desc_asb_) + + end subroutine repl_asb + + subroutine repl_free(idxmap) + implicit none + class(psb_repl_map), intent(inout) :: idxmap + + call idxmap%psb_indx_map%free() + + end subroutine repl_free + + + function repl_get_fmt(idxmap) result(res) + implicit none + class(psb_repl_map), intent(in) :: idxmap + character(len=5) :: res + res = 'REPL' + end function repl_get_fmt + +end module psb_repl_map_mod diff --git a/base/modules/psb_sort_mod.f90 b/base/modules/psb_sort_mod.f90 index fbec74d4..e5e92795 100644 --- a/base/modules/psb_sort_mod.f90 +++ b/base/modules/psb_sort_mod.f90 @@ -86,6 +86,13 @@ module psb_sort_mod end type psb_dcomplex_idx_heap + interface psb_iblsrch + function psb_iblsrch(key,n,v) result(ipos) + integer ipos, key, n + integer v(n) + end function psb_iblsrch + end interface + interface psb_ibsrch function psb_ibsrch(key,n,v) result(ipos) integer ipos, key, n diff --git a/base/modules/psi_mod.f90 b/base/modules/psi_mod.f90 index 4b8a0733..68fc367d 100644 --- a/base/modules/psi_mod.f90 +++ b/base/modules/psi_mod.f90 @@ -447,12 +447,14 @@ module psi_mod end interface interface - subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,& + subroutine psi_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& & length_dl,np,dl_lda,mode,info) - integer :: np,dl_lda,mode, info - integer :: desc_str(*),desc_data(*),dep_list(dl_lda,0:np),length_dl(0:np) + logical :: is_bld, is_upd + integer :: ictxt,np,dl_lda,mode, info + integer :: desc_str(*),dep_list(dl_lda,0:np),length_dl(0:np) end subroutine psi_extract_dep_list end interface + interface psi_fnd_owner subroutine psi_fnd_owner(nv,idx,iprc,desc,info) use psb_descriptor_type, only : psb_desc_type, psb_spk_, psb_dpk_ @@ -473,14 +475,6 @@ module psi_mod end subroutine psi_ldsc_pre_halo end interface - interface psi_bld_g2lmap - subroutine psi_bld_g2lmap(desc,info) - use psb_descriptor_type, only : psb_desc_type, psb_spk_, psb_dpk_ - type(psb_desc_type), intent(inout) :: desc - integer, intent(out) :: info - end subroutine psi_bld_g2lmap - end interface - interface psi_bld_tmphalo subroutine psi_bld_tmphalo(desc,info) use psb_descriptor_type, only : psb_desc_type, psb_spk_, psb_dpk_ @@ -589,16 +583,6 @@ module psi_mod end subroutine psi_renum_index end interface - interface psi_renum_idxmap - subroutine psi_renum_idxmap(nc,iperm,idxmap,info) - use psb_descriptor_type, only: psb_idxmap_type - integer, intent(out) :: info - integer, intent(in) :: nc,iperm(:) - type(psb_idxmap_type), intent(inout) :: idxmap - end subroutine psi_renum_idxmap - end interface - - interface psi_inner_cnv subroutine psi_inner_cnvs(x,hashmask,hashv,glb_lc) integer, intent(in) :: hashmask,hashv(0:),glb_lc(:,:) diff --git a/base/modules/psi_reduce_mod.F90 b/base/modules/psi_reduce_mod.F90 index 4503f224..0f1d3cc6 100644 --- a/base/modules/psi_reduce_mod.F90 +++ b/base/modules/psi_reduce_mod.F90 @@ -154,6 +154,7 @@ contains dat_=dat call mpi_reduce(dat_,dat,size(dat),psb_mpi_integer,mpi_max,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),psb_mpi_integer,mpi_max,root_,ictxt,info) end if endif @@ -196,6 +197,7 @@ contains dat_=dat call mpi_reduce(dat_,dat,size(dat),psb_mpi_integer,mpi_max,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),psb_mpi_integer,mpi_max,root_,ictxt,info) end if endif @@ -273,6 +275,7 @@ contains dat_=dat call mpi_reduce(dat_,dat,size(dat),mpi_integer8,mpi_max,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_integer8,mpi_max,root_,ictxt,info) end if endif @@ -315,6 +318,7 @@ contains dat_=dat call mpi_reduce(dat_,dat,size(dat),mpi_integer8,mpi_max,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_integer8,mpi_max,root_,ictxt,info) end if endif @@ -395,6 +399,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_max,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_max,root_,ictxt,info) end if endif @@ -437,6 +442,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_max,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_max,root_,ictxt,info) end if endif @@ -514,6 +520,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_max,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_max,root_,ictxt,info) end if endif @@ -556,6 +563,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_max,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_max,root_,ictxt,info) end if endif @@ -638,6 +646,7 @@ contains dat_=dat call mpi_reduce(dat_,dat,size(dat),psb_mpi_integer,mpi_min,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),psb_mpi_integer,mpi_min,root_,ictxt,info) end if endif @@ -680,6 +689,7 @@ contains dat_=dat call mpi_reduce(dat_,dat,size(dat),psb_mpi_integer,mpi_min,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),psb_mpi_integer,mpi_min,root_,ictxt,info) end if endif @@ -757,6 +767,7 @@ contains dat_=dat call mpi_reduce(dat_,dat,size(dat),mpi_integer8,mpi_min,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_integer8,mpi_min,root_,ictxt,info) end if endif @@ -799,6 +810,7 @@ contains dat_=dat call mpi_reduce(dat_,dat,size(dat),mpi_integer8,mpi_min,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_integer8,mpi_min,root_,ictxt,info) end if endif @@ -879,6 +891,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_min,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_min,root_,ictxt,info) end if endif @@ -921,6 +934,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_min,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_min,root_,ictxt,info) end if endif @@ -998,6 +1012,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_min,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_min,root_,ictxt,info) end if endif @@ -1040,6 +1055,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_min,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_min,root_,ictxt,info) end if endif @@ -1126,6 +1142,7 @@ contains dat_=dat call mpi_reduce(dat_,dat,size(dat),psb_mpi_integer,mpi_iamx_op,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),psb_mpi_integer,mpi_iamx_op,root_,ictxt,info) end if endif @@ -1168,6 +1185,7 @@ contains dat_=dat call mpi_reduce(dat_,dat,size(dat),psb_mpi_integer,mpi_iamx_op,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),psb_mpi_integer,mpi_iamx_op,root_,ictxt,info) end if endif @@ -1248,6 +1266,7 @@ contains dat_=dat call mpi_reduce(dat_,dat,size(dat),mpi_integer8,mpi_i8amx_op,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_integer8,mpi_i8amx_op,root_,ictxt,info) end if endif @@ -1290,6 +1309,7 @@ contains dat_=dat call mpi_reduce(dat_,dat,size(dat),mpi_integer8,mpi_i8amx_op,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_integer8,mpi_i8amx_op,root_,ictxt,info) end if endif @@ -1370,6 +1390,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_samx_op,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_samx_op,root_,ictxt,info) end if endif @@ -1412,6 +1433,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_samx_op,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_samx_op,root_,ictxt,info) end if endif @@ -1489,6 +1511,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_damx_op,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_damx_op,root_,ictxt,info) end if endif @@ -1531,6 +1554,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_damx_op,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_damx_op,root_,ictxt,info) end if endif @@ -1608,6 +1632,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_complex,mpi_camx_op,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_complex,mpi_camx_op,root_,ictxt,info) end if endif @@ -1650,6 +1675,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_complex,mpi_camx_op,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_complex,mpi_camx_op,root_,ictxt,info) end if endif @@ -1727,6 +1753,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_double_complex,mpi_zamx_op,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_double_complex,mpi_zamx_op,root_,ictxt,info) end if endif @@ -1769,6 +1796,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_double_complex,mpi_zamx_op,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_double_complex,mpi_zamx_op,root_,ictxt,info) end if endif @@ -1855,6 +1883,7 @@ contains dat_=dat call mpi_reduce(dat_,dat,size(dat),psb_mpi_integer,mpi_iamn_op,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),psb_mpi_integer,mpi_iamn_op,root_,ictxt,info) end if endif @@ -1897,6 +1926,7 @@ contains dat_=dat call mpi_reduce(dat_,dat,size(dat),psb_mpi_integer,mpi_iamn_op,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),psb_mpi_integer,mpi_iamn_op,root_,ictxt,info) end if endif @@ -1977,6 +2007,7 @@ contains dat_=dat call mpi_reduce(dat_,dat,size(dat),mpi_integer8,mpi_i8amn_op,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_integer8,mpi_i8amn_op,root_,ictxt,info) end if endif @@ -2019,6 +2050,7 @@ contains dat_=dat call mpi_reduce(dat_,dat,size(dat),mpi_integer8,mpi_i8amn_op,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_integer8,mpi_i8amn_op,root_,ictxt,info) end if endif @@ -2099,6 +2131,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_samn_op,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_samn_op,root_,ictxt,info) end if endif @@ -2141,6 +2174,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_samn_op,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_samn_op,root_,ictxt,info) end if endif @@ -2218,6 +2252,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_damn_op,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_damn_op,root_,ictxt,info) end if endif @@ -2260,6 +2295,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_damn_op,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_damn_op,root_,ictxt,info) end if endif @@ -2337,6 +2373,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_complex,mpi_camn_op,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_complex,mpi_camn_op,root_,ictxt,info) end if endif @@ -2379,6 +2416,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_complex,mpi_camn_op,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_complex,mpi_camn_op,root_,ictxt,info) end if endif @@ -2456,6 +2494,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_double_complex,mpi_zamn_op,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_double_complex,mpi_zamn_op,root_,ictxt,info) end if endif @@ -2498,6 +2537,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_double_complex,mpi_zamn_op,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_double_complex,mpi_zamn_op,root_,ictxt,info) end if endif @@ -2583,6 +2623,7 @@ contains dat_=dat call mpi_reduce(dat_,dat,size(dat),psb_mpi_integer,mpi_sum,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),psb_mpi_integer,mpi_sum,root_,ictxt,info) end if endif @@ -2625,6 +2666,7 @@ contains dat_=dat call mpi_reduce(dat_,dat,size(dat),psb_mpi_integer,mpi_sum,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),psb_mpi_integer,mpi_sum,root_,ictxt,info) end if endif @@ -2705,6 +2747,7 @@ contains dat_=dat call mpi_reduce(dat_,dat,size(dat),mpi_integer8,mpi_sum,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_integer8,mpi_sum,root_,ictxt,info) end if endif @@ -2747,6 +2790,7 @@ contains dat_=dat call mpi_reduce(dat_,dat,size(dat),mpi_integer8,mpi_sum,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_integer8,mpi_sum,root_,ictxt,info) end if endif @@ -2827,6 +2871,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_sum,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_sum,root_,ictxt,info) end if endif @@ -2869,6 +2914,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_sum,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_sum,root_,ictxt,info) end if endif @@ -2946,6 +2992,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_sum,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_sum,root_,ictxt,info) end if endif @@ -2988,6 +3035,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_sum,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_sum,root_,ictxt,info) end if endif @@ -3065,6 +3113,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_complex,mpi_sum,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_complex,mpi_sum,root_,ictxt,info) end if endif @@ -3107,6 +3156,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_complex,mpi_sum,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_complex,mpi_sum,root_,ictxt,info) end if endif @@ -3184,6 +3234,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_double_complex,mpi_sum,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_double_complex,mpi_sum,root_,ictxt,info) end if endif @@ -3226,6 +3277,7 @@ contains dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_double_complex,mpi_sum,root_,ictxt,info) else + call psb_realloc(1,1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_double_complex,mpi_sum,root_,ictxt,info) end if endif @@ -3343,6 +3395,7 @@ contains call mpi_reduce(dat_,dat,size(dat),mpi_real,& & mpi_snrm2_op,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_real,& & mpi_snrm2_op,root_,ictxt,info) end if @@ -3388,6 +3441,7 @@ contains call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,& & mpi_dnrm2_op,root_,ictxt,info) else + call psb_realloc(1,dat_,info) call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,& & mpi_dnrm2_op,root_,ictxt,info) end if diff --git a/base/serial/f03/psb_c_coo_impl.f03 b/base/serial/f03/psb_c_coo_impl.f03 index 3f8ec9ec..61158f65 100644 --- a/base/serial/f03/psb_c_coo_impl.f03 +++ b/base/serial/f03/psb_c_coo_impl.f03 @@ -3045,7 +3045,7 @@ subroutine psb_c_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) case(0) ! Row major order - call msort_up(nzin,ia(1),iaux(1),iret) + call msort_up(nzin,ia(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3056,7 +3056,7 @@ subroutine psb_c_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call msort_up(nzl,ja(i),iaux(1),iret) + call msort_up(nzl,ja(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) @@ -3130,7 +3130,7 @@ subroutine psb_c_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) case(1) ! Col major order - call msort_up(nzin,ja(1),iaux(1),iret) + call msort_up(nzin,ja(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3141,7 +3141,7 @@ subroutine psb_c_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call msort_up(nzl,ia(i),iaux(1),iret) + call msort_up(nzl,ia(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) diff --git a/base/serial/f03/psb_d_coo_impl.f03 b/base/serial/f03/psb_d_coo_impl.f03 index f9c618c8..8d22c396 100644 --- a/base/serial/f03/psb_d_coo_impl.f03 +++ b/base/serial/f03/psb_d_coo_impl.f03 @@ -3091,7 +3091,7 @@ subroutine psb_d_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) case(0) ! Row major order - call msort_up(nzin,ia(1),iaux(1),iret) + call msort_up(nzin,ia(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3102,7 +3102,7 @@ subroutine psb_d_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call msort_up(nzl,ja(i),iaux(1),iret) + call msort_up(nzl,ja(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) @@ -3176,7 +3176,7 @@ subroutine psb_d_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) case(1) ! Col major order - call msort_up(nzin,ja(1),iaux(1),iret) + call msort_up(nzin,ja(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3187,7 +3187,7 @@ subroutine psb_d_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call msort_up(nzl,ia(i),iaux(1),iret) + call msort_up(nzl,ia(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) diff --git a/base/serial/f03/psb_s_coo_impl.f03 b/base/serial/f03/psb_s_coo_impl.f03 index ae36d816..5908fa75 100644 --- a/base/serial/f03/psb_s_coo_impl.f03 +++ b/base/serial/f03/psb_s_coo_impl.f03 @@ -2844,7 +2844,7 @@ subroutine psb_s_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) case(0) ! Row major order - call msort_up(nzin,ia(1),iaux(1),iret) + call msort_up(nzin,ia(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -2855,7 +2855,7 @@ subroutine psb_s_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call msort_up(nzl,ja(i),iaux(1),iret) + call msort_up(nzl,ja(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) @@ -2929,7 +2929,7 @@ subroutine psb_s_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) case(1) ! Col major order - call msort_up(nzin,ja(1),iaux(1),iret) + call msort_up(nzin,ja(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -2940,7 +2940,7 @@ subroutine psb_s_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call msort_up(nzl,ia(i),iaux(1),iret) + call msort_up(nzl,ia(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) diff --git a/base/serial/f03/psb_z_coo_impl.f03 b/base/serial/f03/psb_z_coo_impl.f03 index c61d0238..b8139250 100644 --- a/base/serial/f03/psb_z_coo_impl.f03 +++ b/base/serial/f03/psb_z_coo_impl.f03 @@ -3044,7 +3044,7 @@ subroutine psb_z_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) case(0) ! Row major order - call msort_up(nzin,ia(1),iaux(1),iret) + call msort_up(nzin,ia(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3055,7 +3055,7 @@ subroutine psb_z_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call msort_up(nzl,ja(i),iaux(1),iret) + call msort_up(nzl,ja(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) @@ -3129,7 +3129,7 @@ subroutine psb_z_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) case(1) ! Col major order - call msort_up(nzin,ja(1),iaux(1),iret) + call msort_up(nzin,ja(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3140,7 +3140,7 @@ subroutine psb_z_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call msort_up(nzl,ia(i),iaux(1),iret) + call msort_up(nzl,ia(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) diff --git a/base/serial/psb_sort_impl.f90 b/base/serial/psb_sort_impl.f90 index 66e5445f..7052a0ed 100644 --- a/base/serial/psb_sort_impl.f90 +++ b/base/serial/psb_sort_impl.f90 @@ -97,6 +97,48 @@ logical function psb_isaperm(n,eip) return end function psb_isaperm +function psb_iblsrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_iblsrch + implicit none + integer ipos, key, n + integer v(n) + + integer lb, ub, m + + if (n < 5) then + ! don't bother with binary search for very + ! small vectors + ipos = 0 + do + if (ipos == n) return + if (key < v(ipos+1)) return + ipos = ipos + 1 + end do + else + lb = 1 + ub = n + ipos = -1 + + do while (lb <= ub) + m = (lb+ub)/2 + if (key==v(m)) then + ipos = m + return + else if (key < v(m)) then + ub = m-1 + else + lb = m + 1 + end if + enddo + if (v(ub) > key) then +!!$ write(0,*) 'Check: ',ub,v(ub),key + ub = ub - 1 + end if + ipos = ub + endif + return +end function psb_iblsrch + function psb_ibsrch(key,n,v) result(ipos) use psb_sort_mod, psb_protect_name => psb_ibsrch implicit none @@ -138,6 +180,7 @@ function psb_issrch(key,n,v) result(ipos) return end if enddo + return end function psb_issrch diff --git a/base/tools/Makefile b/base/tools/Makefile index 62cd7de1..2af4b6b6 100644 --- a/base/tools/Makefile +++ b/base/tools/Makefile @@ -4,9 +4,9 @@ FOBJS = psb_sallc.o psb_sasb.o \ psb_sfree.o psb_sins.o \ psb_dallc.o psb_dasb.o \ psb_dfree.o psb_dins.o \ - psb_cdals.o psb_cdalv.o psb_cd_inloc.o psb_cdins.o psb_cdprt.o \ + psb_cdall.o psb_cdals.o psb_cdalv.o psb_cd_inloc.o psb_cdins.o psb_cdprt.o \ psb_cdren.o psb_cdrep.o psb_get_overlap.o psb_cd_lstext.o\ - psb_cdcpy.o psb_cd_reinit.o \ + psb_cdcpy.o psb_cd_reinit.o psb_cd_switch_ovl_indxmap.o\ psb_dspalloc.o psb_dspasb.o \ psb_dspfree.o psb_dspins.o psb_dsprn.o \ psb_sspalloc.o psb_sspasb.o \ diff --git a/base/tools/psb_ccdbldext.F90 b/base/tools/psb_ccdbldext.F90 index 22cbba19..5513eb2c 100644 --- a/base/tools/psb_ccdbldext.F90 +++ b/base/tools/psb_ccdbldext.F90 @@ -73,7 +73,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) #endif ! .. Array Arguments .. - integer, intent(in) :: novr + integer, intent(in) :: novr Type(psb_cspmat_type), Intent(in) :: a Type(psb_desc_type), Intent(in), target :: desc_a Type(psb_desc_type), Intent(out) :: desc_ov @@ -83,7 +83,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) ! .. Local Scalars .. Integer :: i, j, np, me,m,& - & ictxt, lovr, lworks,lworkr, n_row,n_col, int_err(5),& + & ictxt, lovr, lworks,lworkr, n_row,n_col, n_col_prev, int_err(5),& & index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo Integer :: counter,counter_h, counter_o, counter_e,idx,gidx,proc,n_elem_recv,& & n_elem_send,tot_recv,tot_elem,cntov_o,& @@ -131,9 +131,18 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) goto 9999 endif + select case(extype_) + case(psb_ovt_xhal_,psb_ovt_asov_) + case default + call psb_errpush(psb_err_input_value_invalid_i_,& + & name,i_err=(/5,extype_,0,0,0/)) + goto 9999 + end select + if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& - & ':Calling desccpy' + & ': Calling desccpy' + call psb_cdcpy(desc_a,desc_ov,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ @@ -141,25 +150,35 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name,a_err=ch_err) goto 9999 end if + if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& - & ':From desccpy' + & ': From desccpy' - if (novr == 0) then + if ((novr == 0).or.(np==1)) then ! ! Just copy the input. + ! Should we return also when is_repl() ? ! return endif + if ((extype_ == psb_ovt_asov_).and.& + & (.not.desc_ov%indxmap%row_extendable())) then + ! Need to switch to a format that can support overlap, + ! so far: LIST or HASH. Encapsulate choice + ! in a separate method. + call psb_cd_switch_ovl_indxmap(desc_ov,info) + end if + + call psb_cd_set_ovl_bld(desc_ov,info) If (debug_level >= psb_debug_outer_)then Write(debug_unit,*) me,' ',trim(name),& - & ':BEGIN ',nhalo + & ': BEGIN ',nhalo, desc_ov%indxmap%get_state() call psb_barrier(ictxt) endif - ! ! Ok, since we are only estimating, do it as follows: ! LOVR= (NNZ/NROW)*N_HALO*NOVR This assumes that the local average @@ -184,11 +203,11 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) l_tmp_ovr_idx = novr*(3*Max(2*index_dim,1)+1) l_tmp_halo = novr*(3*Size(desc_a%halo_index)) - call psb_cd_set_ovl_bld(desc_ov,info) desc_ov%base_desc => desc_a If (debug_level >= psb_debug_outer_) then - Write(debug_unit,*) me,' ',trim(name),':Start',lworks,lworkr + Write(debug_unit,*) me,' ',trim(name),':Start',& + & lworks,lworkr, desc_ov%indxmap%get_state() call psb_barrier(ictxt) endif @@ -232,7 +251,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) Do j=0,n_elem_recv-1 idx = desc_a%ovrlap_index(counter+psb_elem_recv_+j) - call psb_map_l2g(idx,gidx,desc_ov%idxmap,info) + call desc_ov%indxmap%l2g(idx,gidx,info) If (gidx < 0) then info=-3 call psb_errpush(info,name) @@ -298,7 +317,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) counter = 1 counter_t = 1 - desc_ov%matrix_data(psb_n_row_)=desc_ov%matrix_data(psb_n_col_) + n_col_prev = psb_cd_get_local_cols(desc_ov) Do While (halo(counter) /= -1) tot_elem=0 @@ -333,12 +352,12 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) end If idx = halo(counter+psb_elem_recv_+j) - call psb_map_l2g(idx,gidx,desc_ov%idxmap,info) + call desc_ov%indxmap%l2g(idx,gidx,info) If (gidx < 0) then info=-3 call psb_errpush(info,name) goto 9999 - endif + endif call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) if (info /= psb_success_) then info=psb_err_from_subroutine_ @@ -377,7 +396,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) Do j=0,n_elem_send-1 idx = halo(counter+psb_elem_send_+j) - call psb_map_l2g(idx,gidx,desc_ov%idxmap,info) + call desc_ov%indxmap%l2g(idx,gidx,info) If (gidx < 0) then info=-3 call psb_errpush(info,name) @@ -413,9 +432,10 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if - call psb_map_l2g(icol(1:n_elem),& + call desc_ov%indxmap%l2g(icol(1:n_elem),& & works(idxs+tot_elem+1:idxs+tot_elem+n_elem),& - & desc_ov%idxmap,info) + & info) + tot_elem=tot_elem+n_elem End If @@ -492,114 +512,73 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': ISZR :',iszr - if (psb_is_large_desc(desc_ov)) then - call psb_ensure_size(iszr,maskr,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_ensure_size') - goto 9999 + call psb_ensure_size(iszr,maskr,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_ensure_size') + goto 9999 + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': going for first idx_cnv', desc_ov%indxmap%get_state() + + call psi_idx_cnv(iszr,workr,maskr,desc_ov,info) + iszs = count(maskr(1:iszr)<=0) + if (iszs > size(works)) call psb_realloc(iszs,works,info) + j = 0 + do i=1,iszr + if (maskr(i) < 0) then + j=j+1 + works(j) = workr(i) end if - call psi_idx_cnv(iszr,workr,maskr,desc_ov,info) - iszs = count(maskr(1:iszr)<=0) - if (iszs > size(works)) call psb_realloc(iszs,works,info) - j = 0 - do i=1,iszr - if (maskr(i) < 0) then - j=j+1 - works(j) = workr(i) - end if - end do - ! Eliminate duplicates from request - call psb_msort_unique(works(1:j),iszs) + end do + ! Eliminate duplicates from request + call psb_msort_unique(works(1:j),iszs) + + ! + ! fnd_owner on desc_a because we want the procs who + ! owned the rows from the beginning! + ! + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': going for fnd_owner', desc_ov%indxmap%get_state() + call psi_fnd_owner(iszs,works,temp,desc_a,info) + n_col = psb_cd_get_local_cols(desc_ov) - ! - ! fnd_owner on desc_a because we want the procs who - ! owned the rows from the beginning! - ! - call psi_fnd_owner(iszs,works,temp,desc_a,info) - n_col = psb_cd_get_local_cols(desc_ov) - - do i=1,iszs - idx = works(i) - n_col = psb_cd_get_local_cols(desc_ov) - call psi_idx_ins_cnv(idx,lidx,desc_ov,info) - if (psb_cd_get_local_cols(desc_ov) > n_col ) then - ! - ! This is a new index. Assigning a local index as - ! we receive them guarantees that all indices for HALO(I) - ! will be less than those for HALO(J) whenever I= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': Done fnd_owner', desc_ov%indxmap%get_state() + + do i=1,iszs + idx = works(i) n_col = psb_cd_get_local_cols(desc_ov) - - else - - Do i=1,iszr - idx=workr(i) - if (idx <1) then - write(psb_err_unit,*) me,'Error in CDBLDEXTBLD level',i_ovr,' : ',idx,i,iszr - else If (desc_ov%idxmap%glob_to_loc(idx) < -np) Then - ! - ! This is a new index. Assigning a local index as - ! we receive them guarantees that all indices for HALO(I) - ! will be less than those for HALO(J) whenever I= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ': Added into t_halo_in from recv',& - & proc_id,n_col,idx - else if (desc_ov%idxmap%glob_to_loc(idx) < 0) Then - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ':Wrong input to cdbldextbld?',& - & idx,desc_ov%idxmap%glob_to_loc(idx) - End If - End Do - desc_ov%matrix_data(psb_n_col_) = n_col - - end if + call psi_idx_ins_cnv(idx,lidx,desc_ov,info) + if (psb_cd_get_local_cols(desc_ov) > n_col ) then + ! + ! This is a new index. Assigning a local index as + ! we receive them guarantees that all indices for HALO(I) + ! will be less than those for HALO(J) whenever I= psb_debug_outer_) then - write(debug_unit,*) me,' ',trim(name),':Checktmp_o_i 1',tmp_ovr_idx(1:10) - write(debug_unit,*) me,' ',trim(name),':Calling Crea_index' - end if + write(debug_unit,*) me,' ',trim(name),':Checktmp_o_i 1',tmp_ovr_idx(1:10) + write(debug_unit,*) me,' ',trim(name),':Calling Crea_index' + end if call psi_crea_index(desc_ov,t_halo_in,t_halo_out,.false.,& & nxch,nsnd,nrcv,info) - + if (debug_level >= psb_debug_outer_) then write(debug_unit,*) me,' ',trim(name),':Done Crea_Index' call psb_barrier(ictxt) @@ -642,7 +621,6 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) ! 4. n_row(ov) = n_row(a) ! 5. n_col(ov) current. ! - desc_ov%matrix_data(psb_n_row_) = desc_a%matrix_data(psb_n_row_) call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) call psb_ensure_size((counter_h+counter_t+1),tmp_halo,info,pad=-1) if (info /= psb_success_) then @@ -670,6 +648,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) ! 4. n_row(ov) current. ! 5. n_col(ov) current. ! + call desc_ov%indxmap%set_lr(n_col_prev) call psb_ensure_size((cntov_o+counter_o+1),orig_ovr,info,pad=-1) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') @@ -716,7 +695,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) if (allocated(irow)) deallocate(irow,stat=info) if ((info == psb_success_).and.allocated(icol)) deallocate(icol,stat=info) if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err='deallocate',i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='deallocate',i_err=(/info,0,0,0,0/)) goto 9999 end if end if diff --git a/base/tools/psb_cd_inloc.f90 b/base/tools/psb_cd_inloc.f90 index 38780563..591233ed 100644 --- a/base/tools/psb_cd_inloc.f90 +++ b/base/tools/psb_cd_inloc.f90 @@ -44,6 +44,9 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) use psb_sparse_mod use psi_mod + use psb_repl_map_mod + use psb_list_map_mod + use psb_hash_map_mod implicit None !....Parameters... Integer, intent(in) :: ictxt, v(:) @@ -141,7 +144,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) call psb_errpush(info,name,i_err=int_err) goto 9999 end if - + ! ! Checks for valid input: ! 1. legal range @@ -208,7 +211,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) endif vl(i) = v(i) end do - + if ((m /= nrt).and.(me == psb_root_)) then write(psb_err_unit,*) trim(name),' Warning: globalcheck=.false., but there is a mismatch' write(psb_err_unit,*) trim(name),' : in the global sizes!',m,nrt @@ -230,7 +233,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) call psb_errpush(info,name) goto 9999 end if - + call psb_nullify_desc(desc) ! @@ -282,24 +285,12 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) end if ! allocate work vector - if (islarge) then - allocate(desc%matrix_data(psb_mdata_size_),& - &temp_ovrlap(max(1,2*loc_row)),desc%lprm(1),& - & stat=info) - if (info == psb_success_) then - desc%lprm(1) = 0 - desc%matrix_data(:) = 0 - desc%idxmap%state = psb_desc_large_ - end if - else - allocate(desc%idxmap%glob_to_loc(m),desc%matrix_data(psb_mdata_size_),& - &temp_ovrlap(max(1,2*loc_row)),desc%lprm(1),& - & stat=info) - if (info == psb_success_) then - desc%lprm(1) = 0 - desc%matrix_data(:) = 0 - desc%idxmap%state = psb_desc_normal_ - end if + allocate(desc%matrix_data(psb_mdata_size_),& + &temp_ovrlap(max(1,2*loc_row)),desc%lprm(1),& + & 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_ @@ -308,17 +299,6 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) goto 9999 endif - ! estimate local cols number - loc_col = min(2*loc_row,m) - - allocate(desc%idxmap%loc_to_glob(loc_col),stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=loc_col - call psb_errpush(info,name,i_err=int_err,a_err='integer') - goto 9999 - end if - desc%idxmap%loc_to_glob(:) = -1 temp_ovrlap(:) = -1 desc%matrix_data(psb_m_) = m desc%matrix_data(psb_n_) = n @@ -330,117 +310,11 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': starting main loop' ,info - ! - ! We have to decide whether we have a "large" index space. - ! Note: in what follows, we use the original V, not the sorted VL - ! to make sure indices are processed in the order the user expects - ! them. - ! - if (islarge) then - ! - ! Yes, we do have a large index space. Therefore we are - ! keeping on the local process a map of only the global - ! indices ending up here; this map is stored in an AVL - ! tree during the build stage, so as to guarantee log-time - ! serch and insertion of new items. At assembly time it - ! is transferred to a series of ordered linear lists, - ! hashed by the low order bits of the entries. - ! - - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=loc_col - call psb_errpush(info,name,i_err=int_err,a_err='integer') - goto 9999 - end if - - ! Use sorted indices to fill in loc_to_glob - j = 1 - itmpov = 0 + j = 1 + itmpov = 0 + if (check_) then do k=1, loc_row i = v(k) - desc%idxmap%loc_to_glob(k) = i - - if (check_) then - nprocs = tmpgidx(i,2) - if (nprocs > 1) then - do - if (j > size(ov_idx,dim=1)) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='search ov_idx') - goto 9999 - end if - if (ov_idx(j,1) == i) exit - j = j + 1 - end do - call psb_ensure_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-1) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_ensure_size') - goto 9999 - end if - itmpov = itmpov + 1 - temp_ovrlap(itmpov) = i - itmpov = itmpov + 1 - temp_ovrlap(itmpov) = nprocs - temp_ovrlap(itmpov+1:itmpov+nprocs) = ov_idx(j:j+nprocs-1,2) - itmpov = itmpov + nprocs - end if - end if - - enddo - - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='insert loop') - goto 9999 - endif - - else - - ! - ! No, we don't have a large index space. Therefore we can - ! afford to keep on the local process a map of all global - ! indices; for those we know are here we immediately store - ! the corresponding local index, for the others we encode - ! the index of the process owning them, so that during the - ! insertion phase we can use the information to build the - ! data exchange lists "on-the-fly". - ! - - do i=1,m - - if (((tmpgidx(i,1)-flag_) > np-1).or.((tmpgidx(i,1)-flag_) < 0)) then - info=psb_err_partfunc_wrong_pid_ - int_err(1)=3 - int_err(2)=tmpgidx(i,1) - flag_ - int_err(3)=i - exit - end if - - desc%idxmap%glob_to_loc(i) = -(np+(tmpgidx(i,1)-flag_)+1) - enddo - - if (info /= psb_success_) then - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - ! Use sorted indices to fill in loc_to_glob - j = 1 - itmpov = 0 - do k=1, loc_row - i = v(k) - - if (desc%idxmap%glob_to_loc(i) > 0) then - info = psb_err_dupl_cd_vl - call psb_errpush(info,name) - goto 9999 - end if - - desc%idxmap%loc_to_glob(k) = i - desc%idxmap%glob_to_loc(i) = k - nprocs = tmpgidx(i,2) if (nprocs > 1) then do @@ -465,12 +339,28 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) temp_ovrlap(itmpov+1:itmpov+nprocs) = ov_idx(j:j+nprocs-1,2) itmpov = itmpov + nprocs end if - enddo + end do + end if + if (np == 1) then + allocate(psb_repl_map :: desc%indxmap, stat=info) + else + if (islarge) then + allocate(psb_hash_map :: desc%indxmap, stat=info) + else + allocate(psb_list_map :: desc%indxmap, stat=info) + end if end if + select type(aa => desc%indxmap) + type is (psb_repl_map) + call aa%repl_map_init(ictxt,m,info) + class default + call aa%init(ictxt,vl(1:nlu),info) + end select + call psi_bld_tmpovrl(temp_ovrlap,desc,info) - + if (info == psb_success_) deallocate(temp_ovrlap,vl,stat=info) if ((info == psb_success_).and.(allocated(tmpgidx)))& & deallocate(tmpgidx,stat=info) @@ -486,26 +376,26 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) 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_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 diff --git a/base/tools/psb_cd_set_bld.f90 b/base/tools/psb_cd_set_bld.f90 index e3c35195..ed44deec 100644 --- a/base/tools/psb_cd_set_bld.f90 +++ b/base/tools/psb_cd_set_bld.f90 @@ -36,8 +36,15 @@ subroutine psb_cd_set_ovl_bld(desc,info) integer :: info call psb_cd_set_bld(desc,info) - if (info == psb_success_) desc%matrix_data(psb_dec_type_) = psb_cd_ovl_bld_ - + if (info == psb_success_) then + if (desc%indxmap%row_extendable()) then + call desc%indxmap%set_state(psb_desc_ovl_bld_) + desc%matrix_data(psb_dec_type_) = psb_cd_ovl_bld_ + else + info = psb_err_invalid_cd_state_ + end if + end if + end subroutine psb_cd_set_ovl_bld subroutine psb_cd_set_bld(desc,info) @@ -62,38 +69,12 @@ subroutine psb_cd_set_bld(desc,info) ! check on blacs grid call psb_info(ictxt, me, np) if (debug) write(psb_err_unit,*) me,'Entered CDSETBLD' + if (psb_is_asb_desc(desc)) then end if - - desc%matrix_data(psb_dec_type_) = psb_desc_bld_ - if (psb_is_large_desc(desc)) then - ! - ! The idea: first build glb_lc with the info on - ! rows we already have, then leave space in - ! hash for newcomers (halo indices). - ! The policy is to allocate for as many entries - ! as there are rows; if we ever fill them up, we can - ! try and enlarge again, but by the time the hash - ! fills up it means we have as many halo as internals, - ! therefore there are much worse problems ahead than - ! the hash occupancy. - ! - nc = psb_cd_get_local_cols(desc) - if (info == psb_success_)& - & call psb_hash_init(nc,desc%idxmap%hash,info) - if (info == HashDuplicate) then - info = psb_err_dupl_cd_vl - call psb_errpush(info,name,a_err='hashInit') - goto 9999 - end if - if (info == psb_success_) call psi_bld_g2lmap(desc,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='hashInit') - goto 9999 - end if - - end if + desc%matrix_data(psb_dec_type_) = psb_desc_bld_ + call desc%indxmap%set_state(psb_desc_bld_) if (debug) write(psb_err_unit,*) me,'SET_BLD: done' call psb_erractionrestore(err_act) diff --git a/base/tools/psb_cd_switch_ovl_indxmap.f90 b/base/tools/psb_cd_switch_ovl_indxmap.f90 new file mode 100644 index 00000000..e6821840 --- /dev/null +++ b/base/tools/psb_cd_switch_ovl_indxmap.f90 @@ -0,0 +1,143 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.0 +!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! +! +Subroutine psb_cd_switch_ovl_indxmap(desc,info) + + use psb_sparse_mod, psb_protect_name => psb_cd_switch_ovl_indxmap + use psi_mod + + + Implicit None + + ! .. Array Arguments .. + Type(psb_desc_type), Intent(inout) :: desc + integer, intent(out) :: info + + ! .. Local Scalars .. + Integer :: i, j, np, me, mglob, ictxt, n_row, n_col + integer :: icomm, err_act + + integer, allocatable :: vl(:) + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + name='cd_switch_ovl_indxmap' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc) + icomm = psb_cd_get_mpic(desc) + Call psb_info(ictxt, me, np) + + If (debug_level >= psb_debug_outer_) & + & Write(debug_unit,*) me,' ',trim(name),& + & ': start' + + mglob = psb_cd_get_global_rows(desc) + n_row = psb_cd_get_local_rows(desc) + n_col = psb_cd_get_local_cols(desc) + + Allocate(vl(n_col),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,n_col + vl(i) = i + end do + call desc%indxmap%l2g(vl(1:n_col),info) + +!!$ write(0,*) 'from l2g' ,info,n_row,n_Col + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='map%l2g',i_err=(/info,0,0,0,0/)) + goto 9999 + end if + + call desc%indxmap%free() + deallocate(desc%indxmap) + + if (psb_cd_choose_large_state(ictxt,mglob)) then + allocate(psb_hash_map :: desc%indxmap, stat=info) + else + allocate(psb_list_map :: desc%indxmap, stat=info) + end if + +!!$ write(0,*) 'from allocate indxmap' ,info + if (info == psb_success_)& + & call desc%indxmap%init(ictxt,vl(1:n_row),info) +!!$ write(0,*) 'from indxmap%init' ,info + if (info == psb_success_) call psb_cd_set_bld(desc,info) +!!$ write(0,*) 'from cd_Set_bld' ,info +!!$ write(0,*) 'into g2l_ins' ,info,vl(n_row+1:n_col) + if (info == psb_success_) & + & call desc%indxmap%g2l_ins(vl(n_row+1:n_col),info) +!!$ write(0,*) 'from g2l_ins' ,info,vl(n_row+1:n_col) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='allocate/init',i_err=(/info,0,0,0,0/)) + goto 9999 + end if + if (n_row /= desc%indxmap%get_lr()) then + write(debug_unit,*) me,' ',trim(name),& + & ': Local rows mismatch ',n_row,& + &desc%indxmap%get_lr(),desc%indxmap%get_fmt() + end if + + if (n_col /= desc%indxmap%get_lc()) then + write(debug_unit,*) me,' ',trim(name),& + & ': Local cols mismatch ',n_col,& + &desc%indxmap%get_lc(),desc%indxmap%get_fmt() + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': end',desc%indxmap%get_fmt() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + Return + +End Subroutine psb_cd_switch_ovl_indxmap + diff --git a/base/tools/psb_cdall.f90 b/base/tools/psb_cdall.f90 new file mode 100644 index 00000000..ef0dc225 --- /dev/null +++ b/base/tools/psb_cdall.f90 @@ -0,0 +1,199 @@ +subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalcheck) + use psb_descriptor_type + use psb_serial_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + use psb_base_tools_mod, psb_protect_name => psb_cdall + use psi_mod + implicit None + include 'parts.fh' + Integer, intent(in) :: mg,ng,ictxt, vg(:), vl(:),nl + integer, intent(in) :: flag + logical, intent(in) :: repl, globalcheck + integer, intent(out) :: info + type(psb_desc_type), intent(out) :: desc + + optional :: mg,ng,parts,vg,vl,flag,nl,repl, globalcheck + + interface + subroutine psb_cdals(m, n, parts, ictxt, desc, info) + use psb_descriptor_type + include 'parts.fh' + Integer, intent(in) :: m,n,ictxt + Type(psb_desc_type), intent(out) :: desc + integer, intent(out) :: info + end subroutine psb_cdals + subroutine psb_cdalv(v, ictxt, desc, info, flag) + use psb_descriptor_type + Integer, intent(in) :: ictxt, v(:) + integer, intent(in), optional :: flag + integer, intent(out) :: info + Type(psb_desc_type), intent(out) :: desc + end subroutine psb_cdalv + subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) + use psb_descriptor_type + implicit None + Integer, intent(in) :: ictxt, v(:) + integer, intent(out) :: info + type(psb_desc_type), intent(out) :: desc + logical, intent(in), optional :: globalcheck + end subroutine psb_cd_inloc + subroutine psb_cdrep(m, ictxt, desc,info) + use psb_descriptor_type + Integer, intent(in) :: m,ictxt + Type(psb_desc_type), intent(out) :: desc + integer, intent(out) :: info + end subroutine psb_cdrep + end interface + character(len=20) :: name + integer :: err_act, n_, flag_, i, me, np, nlp, nnv, lr + integer, allocatable :: itmpsz(:) + + + + if (psb_get_errstatus() /= 0) return + info=psb_success_ + name = 'psb_cdall' + call psb_erractionsave(err_act) + + call psb_info(ictxt, me, np) + + if (count((/ present(vg),present(vl),& + & present(parts),present(nl), present(repl) /)) /= 1) then + info=psb_err_no_optional_arg_ + call psb_errpush(info,name,a_err=" vg, vl, parts, nl, repl") + goto 999 + endif + + desc%base_desc => null() + if (allocated(desc%indxmap)) then + write(0,*) 'Allocated on an intent(OUT) var?' + end if + + if (present(parts)) then + + if (.not.present(mg)) then + info=psb_err_no_optional_arg_ + call psb_errpush(info,name) + goto 999 + end if + if (present(ng)) then + n_ = ng + else + n_ = mg + endif + call psb_cdals(mg, n_, parts, ictxt, desc, info) + + else if (present(repl)) then + + if (.not.present(mg)) then + info=psb_err_no_optional_arg_ + call psb_errpush(info,name) + goto 999 + end if + if (.not.repl) then + info=psb_err_no_optional_arg_ + call psb_errpush(info,name) + goto 999 + end if + + call psb_cdrep(mg, ictxt, desc, info) + + + else if (present(vg)) then + + if (present(flag)) then + flag_=flag + else + flag_=0 + endif + if (present(mg)) then + nnv = min(mg,size(vg)) + else + nnv = size(vg) + end if + + call psb_cdalv(vg(1:nnv), ictxt, desc, info, flag=flag_) + + else if (present(vl)) then + + if (present(nl)) then + nnv = min(nl,size(vl)) + else + nnv = size(vl) + end if + + call psb_cd_inloc(vl(1:nnv),ictxt,desc,info, globalcheck=globalcheck) + + else if (present(nl)) then + + allocate(desc%matrix_data(psb_mdata_size_)) + desc%matrix_data(psb_m_) = nl + call psb_sum(ictxt,desc%matrix_data(psb_m_)) + desc%matrix_data(psb_n_) = desc%matrix_data(psb_m_) + desc%matrix_data(psb_ctxt_) = ictxt + call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_)) + + + + if (np == 1) then + allocate(psb_repl_map :: desc%indxmap, stat=info) + else + allocate(psb_gen_block_map :: desc%indxmap, stat=info) + end if + if (info == psb_success_) then + select type(aa => desc%indxmap) + type is (psb_repl_map) + call aa%repl_map_init(ictxt,nl,info) + type is (psb_gen_block_map) + call aa%gen_block_map_init(ictxt,nl,info) + class default + ! This cannot happen + info = psb_err_internal_error_ + goto 999 + end select + end if + + call psb_realloc(1,itmpsz, info) + if (info /= 0) then + write(0,*) 'Error reallocating itmspz' + goto 999 + end if + itmpsz(:) = -1 + call psi_bld_tmpovrl(itmpsz,desc,info) + + endif + + if (info /= psb_success_) goto 999 + + ! Finish off + lr = desc%indxmap%get_lr() + call psb_realloc(max(1,lr/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 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) + return + +999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + + +end subroutine psb_cdall diff --git a/base/tools/psb_cdals.f90 b/base/tools/psb_cdals.f90 index 4e9e4084..f806f383 100644 --- a/base/tools/psb_cdals.f90 +++ b/base/tools/psb_cdals.f90 @@ -46,6 +46,9 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) use psb_sparse_mod use psi_mod + use psb_repl_map_mod + use psb_list_map_mod + use psb_hash_map_mod implicit None include 'parts.fh' !....Parameters... @@ -55,9 +58,9 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) !locals Integer :: counter,i,j,np,me,loc_row,err,loc_col,nprocs,& - & l_ov_ix,l_ov_el,idx, err_act, itmpov, k, glx + & l_ov_ix,l_ov_el,idx, err_act, itmpov, k, glx, nlx integer :: int_err(5),exch(3) - integer, allocatable :: prc_v(:), temp_ovrlap(:) + integer, allocatable :: prc_v(:), temp_ovrlap(:), loc_idx(:) integer :: debug_level, debug_unit character(len=20) :: name @@ -122,21 +125,10 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) ! count local rows number loc_row = max(1,(m+np-1)/np) ! allocate work vector - if (psb_cd_choose_large_state(ictxt,m)) then - allocate(desc%matrix_data(psb_mdata_size_),& - & temp_ovrlap(max(1,2*loc_row)),prc_v(np),stat=info) - if (info == psb_success_) then - desc%matrix_data(:) = 0 - desc%idxmap%state = psb_desc_large_ - end if - else - allocate(desc%idxmap%glob_to_loc(m),desc%matrix_data(psb_mdata_size_),& - & temp_ovrlap(max(1,2*loc_row)),prc_v(np),stat=info) - if (info == psb_success_) then - desc%matrix_data(:) = 0 - desc%idxmap%state = psb_desc_normal_ - end if - end if + allocate(desc%matrix_data(psb_mdata_size_),& + & temp_ovrlap(max(1,2*loc_row)), prc_v(np),stat=info) + desc%matrix_data(:) = 0 + if (info /= psb_success_) then info=psb_err_alloc_request_ err=info @@ -159,210 +151,129 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) ! ! We have to decide whether we have a "large" index space. ! - if (psb_cd_choose_large_state(ictxt,m)) then - ! - ! Yes, we do have a large index space. Therefore we are - ! keeping on the local process a map of only the global - ! indices ending up here; this map is stored partly in - ! a hash of sorted lists, part in a hash table. - ! At assembly time - ! is transferred to a series of ordered linear lists, - ! hashed by the low order bits of the entries. - ! - loc_col = max(1,(m+np-1)/np) - loc_col = min(2*loc_col,m) - allocate(desc%idxmap%loc_to_glob(loc_col), desc%lprm(1),& - & stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=loc_col - call psb_errpush(info,name,i_err=int_err,a_err='integer') - goto 9999 + + ! + ! Yes, we do have a large index space. Therefore we are + ! keeping on the local process a map of only the global + ! indices ending up here; this map is stored partly in + ! a hash of sorted lists, part in a hash table. + ! At assembly time + ! is transferred to a series of ordered linear lists, + ! hashed by the low order bits of the entries. + ! + loc_col = max(1,(m+np-1)/np) + loc_col = min(2*loc_col,m) + + allocate(desc%lprm(1), loc_idx(loc_col), stat=info) + if (info == psb_success_) then + if (np == 1) then + allocate(psb_repl_map :: desc%indxmap, stat=info) + else + allocate(psb_hash_map :: desc%indxmap, stat=info) end if + end if - ! set LOC_TO_GLOB array to all "-1" values - desc%lprm(1) = 0 - desc%idxmap%loc_to_glob(:) = -1 - k = 0 - do i=1,m - if (info == psb_success_) then - call parts(i,m,np,prc_v,nprocs) - if (nprocs > np) then - info=psb_err_partfunc_toomuchprocs_ - int_err(1)=3 - int_err(2)=np - int_err(3)=nprocs - int_err(4)=i - err=info - call psb_errpush(err,name,int_err) - goto 9999 - else if (nprocs <= 0) then - info=psb_err_partfunc_toofewprocs_ - int_err(1)=3 - int_err(2)=nprocs - int_err(3)=i - err=info - call psb_errpush(err,name,int_err) - goto 9999 - else - do j=1,nprocs - if ((prc_v(j) > np-1).or.(prc_v(j) < 0)) then - info=psb_err_partfunc_wrong_pid_ - int_err(1)=3 - int_err(2)=prc_v(j) - int_err(3)=i - err=info - call psb_errpush(err,name,int_err) - goto 9999 - end if - end do - endif - j=1 - do - if (j > nprocs) exit - if (prc_v(j) == me) exit - j=j+1 - enddo - - if (j <= nprocs) then - if (prc_v(j) == me) then - ! this point belongs to me - k = k + 1 - call psb_ensure_size((k+1),desc%idxmap%loc_to_glob,info,pad=-1) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + int_err(1)=loc_col + call psb_errpush(info,name,i_err=int_err,a_err='integer') + goto 9999 + end if + + ! set LOC_TO_GLOB array to all "-1" values + desc%lprm(1) = 0 + + k = 0 + do i=1,m + if (info == psb_success_) then + call parts(i,m,np,prc_v,nprocs) + if (nprocs > np) then + info=psb_err_partfunc_toomuchprocs_ + int_err(1)=3 + int_err(2)=np + int_err(3)=nprocs + int_err(4)=i + err=info + call psb_errpush(err,name,int_err) + goto 9999 + else if (nprocs <= 0) then + info=psb_err_partfunc_toofewprocs_ + int_err(1)=3 + int_err(2)=nprocs + int_err(3)=i + err=info + call psb_errpush(err,name,int_err) + goto 9999 + else + do j=1,nprocs + if ((prc_v(j) > np-1).or.(prc_v(j) < 0)) then + info=psb_err_partfunc_wrong_pid_ + int_err(1)=3 + int_err(2)=prc_v(j) + int_err(3)=i + err=info + call psb_errpush(err,name,int_err) + goto 9999 + end if + end do + endif + j=1 + do + if (j > nprocs) exit + if (prc_v(j) == me) exit + j=j+1 + enddo + + if (j <= nprocs) then + if (prc_v(j) == me) then + ! this point belongs to me + k = k + 1 + call psb_ensure_size((k+1),loc_idx,info,pad=-1) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_ensure_size') + goto 9999 + end if + loc_idx(k) = i + + if (nprocs > 1) then + call psb_ensure_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-1) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if - desc%idxmap%loc_to_glob(k) = i - if (nprocs > 1) then - call psb_ensure_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-1) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_ensure_size') - goto 9999 - end if - itmpov = itmpov + 1 - temp_ovrlap(itmpov) = i - itmpov = itmpov + 1 - temp_ovrlap(itmpov) = nprocs - temp_ovrlap(itmpov+1:itmpov+nprocs) = prc_v(1:nprocs) - itmpov = itmpov + nprocs - endif - end if + itmpov = itmpov + 1 + temp_ovrlap(itmpov) = i + itmpov = itmpov + 1 + temp_ovrlap(itmpov) = nprocs + temp_ovrlap(itmpov+1:itmpov+nprocs) = prc_v(1:nprocs) + itmpov = itmpov + nprocs + endif end if end if - enddo - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - loc_row = k - - else - - ! - ! No, we don't have a large index space. Therefore we can - ! afford to keep on the local process a map of all global - ! indices; for those we know are here we immediately store - ! the corresponding local index, for the others we encode - ! the index of the process owning them, so that during the - ! insertion phase we can use the information to build the - ! data exchange lists "on-the-fly". - ! - - do i=1,m - if (info == psb_success_) then - call parts(i,m,np,prc_v,nprocs) - if (nprocs > np) then - info=psb_err_partfunc_toomuchprocs_ - int_err(1)=3 - int_err(2)=np - int_err(3)=nprocs - int_err(4)=i - err=info - call psb_errpush(err,name,int_err) - goto 9999 - else if (nprocs <= 0) then - info=psb_err_partfunc_toofewprocs_ - int_err(1)=3 - int_err(2)=nprocs - int_err(3)=i - err=info - call psb_errpush(err,name,int_err) - goto 9999 - else - do j=1,nprocs - if ((prc_v(j) > np-1).or.(prc_v(j) < 0)) then - info=psb_err_partfunc_wrong_pid_ - int_err(1)=3 - int_err(2)=prc_v(j) - int_err(3)=i - err=info - call psb_errpush(err,name,int_err) - goto 9999 - end if - end do - endif - desc%idxmap%glob_to_loc(i) = -(np+prc_v(1)+1) - j=1 - do - if (j > nprocs) exit - if (prc_v(j) == me) exit - j=j+1 - enddo - if (j <= nprocs) then - if (prc_v(j) == me) then - ! this point belongs to me - counter=counter+1 - desc%idxmap%glob_to_loc(i) = counter - if (nprocs > 1) then - call psb_ensure_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-1) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_ensure_size') - goto 9999 - end if - itmpov = itmpov + 1 - temp_ovrlap(itmpov) = i - itmpov = itmpov + 1 - temp_ovrlap(itmpov) = nprocs - temp_ovrlap(itmpov+1:itmpov+nprocs) = prc_v(1:nprocs) - itmpov = itmpov + nprocs - endif - end if - end if - endif - enddo - ! estimate local cols number - loc_row=counter - loc_col=min(2*loc_row,m) - - allocate(desc%idxmap%loc_to_glob(loc_col),& - &desc%lprm(1),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 end if - - ! set LOC_TO_GLOB array to all "-1" values - desc%lprm(1) = 0 - desc%idxmap%loc_to_glob(:) = -1 - do i=1,m - k = desc%idxmap%glob_to_loc(i) - if (k > 0) then - desc%idxmap%loc_to_glob(k) = i - endif - enddo - - end if + enddo + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + loc_row = k ! check on parts function if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': End main loop:' ,loc_row,itmpov,info + select type(aa => desc%indxmap) + type is (psb_repl_map) + call aa%repl_map_init(ictxt,m,info) + class default + call aa%init(ictxt,loc_idx(1:k),info) + end select + + if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': error check:' ,err @@ -381,24 +292,11 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) 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 - - 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 - +!!$ 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' diff --git a/base/tools/psb_cdalv.f90 b/base/tools/psb_cdalv.f90 index cee3dcd5..4663c049 100644 --- a/base/tools/psb_cdalv.f90 +++ b/base/tools/psb_cdalv.f90 @@ -46,6 +46,9 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) use psb_sparse_mod use psi_mod + use psb_repl_map_mod + use psb_glist_map_mod + use psb_hash_map_mod implicit None !....Parameters... Integer, intent(in) :: ictxt, v(:) @@ -72,7 +75,7 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) call psb_info(ictxt, me, np) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': ',np,me - + m = size(v) n = m !... check m and n parameters.... @@ -134,20 +137,10 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) ! count local rows number loc_row = max(1,(m+np-1)/np) ! allocate work vector - if (psb_cd_choose_large_state(ictxt,m)) then - allocate(desc%matrix_data(psb_mdata_size_),& - &temp_ovrlap(max(1,2*loc_row)),stat=info) - if (info == psb_success_) then - desc%matrix_data(:) = 0 - desc%idxmap%state = psb_desc_large_ - end if - else - allocate(desc%idxmap%glob_to_loc(m),desc%matrix_data(psb_mdata_size_),& - &temp_ovrlap(max(1,2*loc_row)),stat=info) - if (info == psb_success_) then - desc%matrix_data(:) = 0 - desc%idxmap%state = psb_desc_normal_ - end if + allocate(desc%matrix_data(psb_mdata_size_),& + &temp_ovrlap(max(1,2*loc_row)),stat=info) + if (info == psb_success_) then + desc%matrix_data(:) = 0 end if if (info /= psb_success_) then info=psb_err_alloc_request_ @@ -167,140 +160,52 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) itmpov = 0 temp_ovrlap(:) = -1 - ! - ! We have to decide whether we have a "large" index space. - ! - if (psb_cd_choose_large_state(ictxt,m)) then - ! - ! Yes, we do have a large index space. Therefore we are - ! keeping on the local process a map of only the global - ! indices ending up here; this map is stored in an AVL - ! tree during the build stage, so as to guarantee log-time - ! serch and insertion of new items. At assembly time it - ! is transferred to a series of ordered linear lists, - ! hashed by the low order bits of the entries. - ! - - do i=1,m - - if (((v(i)-flag_) > np-1).or.((v(i)-flag_) < 0)) then - info=psb_err_partfunc_wrong_pid_ - int_err(1)=3 - int_err(2)=v(i) - flag_ - int_err(3)=i - exit - end if - - if ((v(i)-flag_) == me) then - ! this point belongs to me - counter=counter+1 - end if - enddo + do i=1,m - - loc_row=counter - ! check on parts function - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': End main loop:' ,loc_row,itmpov,info - - if (info /= psb_success_) then - call psb_errpush(info,name,i_err=int_err) - goto 9999 + if (((v(i)-flag_) > np-1).or.((v(i)-flag_) < 0)) then + info=psb_err_partfunc_wrong_pid_ + int_err(1)=3 + int_err(2)=v(i) - flag_ + int_err(3)=i + exit end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': error check:' ,err - ! estimate local cols number - loc_col = min(2*loc_row,m) - - allocate(desc%idxmap%loc_to_glob(loc_col), desc%lprm(1),& - & stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=loc_col - call psb_errpush(info,name,i_err=int_err,a_err='integer') - goto 9999 + if ((v(i)-flag_) == me) then + ! this point belongs to me + counter=counter+1 end if + enddo + loc_row=counter - ! set LOC_TO_GLOB array to all "-1" values - desc%lprm(1) = 0 - desc%idxmap%loc_to_glob(:) = -1 - k = 0 - do i=1,m - if ((v(i)-flag_) == me) then - k = k + 1 - desc%idxmap%loc_to_glob(k) = i - endif - enddo - - else - - - ! - ! No, we don't have a large index space. Therefore we can - ! afford to keep on the local process a map of all global - ! indices; for those we know are here we immediately store - ! the corresponding local index, for the others we encode - ! the index of the process owning them, so that during the - ! insertion phase we can use the information to build the - ! data exchange lists "on-the-fly". - ! - do i=1,m - - if (((v(i)-flag_) > np-1).or.((v(i)-flag_) < 0)) then - info=psb_err_partfunc_wrong_pid_ - int_err(1)=3 - int_err(2)=v(i) - flag_ - int_err(3)=i - exit - end if - - if ((v(i)-flag_) == me) then - ! this point belongs to me - counter=counter+1 - desc%idxmap%glob_to_loc(i) = counter - else - desc%idxmap%glob_to_loc(i) = -(np+(v(i)-flag_)+1) - end if - enddo - - - loc_row=counter - ! check on parts function - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': End main loop:' ,loc_row,itmpov,info - - if (info /= psb_success_) then - call psb_errpush(info,name,i_err=int_err) - goto 9999 + ! + ! We have to decide whether we have a "large" index space. + ! + if (np == 1) then + allocate(psb_repl_map :: desc%indxmap, stat=info) + else + if (psb_cd_choose_large_state(ictxt,m)) then + allocate(psb_hash_map :: desc%indxmap, stat=info) + else + allocate(psb_glist_map :: desc%indxmap, stat=info) end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': error check:' ,err + end if - ! estimate local cols number - loc_col = min(2*loc_row,m) - allocate(desc%idxmap%loc_to_glob(loc_col),& - &desc%lprm(1),stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=loc_col - call psb_errpush(info,name,i_err=int_err,a_err='integer') - goto 9999 - end if + select type(aa => desc%indxmap) + type is (psb_repl_map) + call aa%repl_map_init(ictxt,m,info) + type is (psb_hash_map) + call aa%hash_map_init(ictxt,v,info) + type is (psb_glist_map) + call aa%glist_map_init(ictxt,v,info) + class default + ! This cannot happen + info = psb_err_internal_error_ + call psb_errpush(info,name) + Goto 9999 + end select - ! set LOC_TO_GLOB array to all "-1" values - desc%lprm(1) = 0 - desc%idxmap%loc_to_glob(:) = -1 - do i=1,m - k = desc%idxmap%glob_to_loc(i) - if (k > 0) then - desc%idxmap%loc_to_glob(k) = i - endif - enddo - end if - call psi_bld_tmpovrl(temp_ovrlap,desc,info) deallocate(temp_ovrlap,stat=info) @@ -314,24 +219,6 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) 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 - - 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 - if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': end' diff --git a/base/tools/psb_cdcpy.f90 b/base/tools/psb_cdcpy.f90 index 09ce1916..38a65b16 100644 --- a/base/tools/psb_cdcpy.f90 +++ b/base/tools/psb_cdcpy.f90 @@ -45,7 +45,7 @@ subroutine psb_cdcpy(desc_in, desc_out, info) !....parameters... type(psb_desc_type), intent(in) :: desc_in - type(psb_desc_type), intent(out) :: desc_out + type(psb_desc_type), intent(inout) :: desc_out integer, intent(out) :: info !locals @@ -76,20 +76,22 @@ subroutine psb_cdcpy(desc_in, desc_out, info) call psb_safe_ab_cpy(desc_in%matrix_data,desc_out%matrix_data,info) if (info == psb_success_) call psb_safe_ab_cpy(desc_in%halo_index,desc_out%halo_index,info) if (info == psb_success_) call psb_safe_ab_cpy(desc_in%ext_index,desc_out%ext_index,info) - if (info == psb_success_) call psb_safe_ab_cpy(desc_in%ovrlap_index,desc_out%ovrlap_index,info) + if (info == psb_success_) call psb_safe_ab_cpy(desc_in%ovrlap_index,& + & desc_out%ovrlap_index,info) if (info == psb_success_) call psb_safe_ab_cpy(desc_in%bnd_elem,desc_out%bnd_elem,info) if (info == psb_success_) call psb_safe_ab_cpy(desc_in%ovrlap_elem,desc_out%ovrlap_elem,info) if (info == psb_success_) call psb_safe_ab_cpy(desc_in%ovr_mst_idx,desc_out%ovr_mst_idx,info) if (info == psb_success_) call psb_safe_ab_cpy(desc_in%lprm,desc_out%lprm,info) if (info == psb_success_) call psb_safe_ab_cpy(desc_in%idx_space,desc_out%idx_space,info) - if (info == psb_success_) call psb_idxmap_copy(desc_in%idxmap,desc_out%idxmap, info) -!!$ if (info == psb_success_) call psb_safe_ab_cpy(desc_in%loc_to_glob,desc_out%loc_to_glob,info) -!!$ if (info == psb_success_) call psb_safe_ab_cpy(desc_in%glob_to_loc,desc_out%glob_to_loc,info) -!!$ desc_out%hashvsize = desc_in%hashvsize -!!$ desc_out%hashvmask = desc_in%hashvmask -!!$ if (info == psb_success_) call psb_safe_ab_cpy(desc_in%hashv,desc_out%hashv,info) -!!$ if (info == psb_success_) call psb_safe_ab_cpy(desc_in%glb_lc,desc_out%glb_lc,info) -!!$ if (info == psb_success_) call CloneHashTable(desc_in%hash,desc_out%hash,info) + + if (allocated(desc_in%indxmap)) then + if (allocated(desc_out%indxmap)) then + call desc_out%indxmap%free() + deallocate(desc_out%indxmap) + end if + if (info == psb_success_)& + & allocate(desc_out%indxmap, source=desc_in%indxmap, stat=info) + end if if (info /= psb_success_) then info = psb_err_from_subroutine_ diff --git a/base/tools/psb_cdins.f90 b/base/tools/psb_cdins.f90 index 6c60bbac..333073c0 100644 --- a/base/tools/psb_cdins.f90 +++ b/base/tools/psb_cdins.f90 @@ -80,7 +80,7 @@ subroutine psb_cdinsrc(nz,ia,ja,desc_a,info,ila,jla) call psb_info(ictxt, me, np) if (.not.psb_is_bld_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -137,7 +137,7 @@ subroutine psb_cdinsrc(nz,ia,ja,desc_a,info,ila,jla) & call psb_cdins(nz,ja,desc_a,info,mask=(ila_(1:nz)>0)) deallocate(ila_) end if - + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -205,7 +205,7 @@ subroutine psb_cdinsc(nz,ja,desc,info,jla,mask) call psb_info(ictxt, me, np) if (.not.psb_is_bld_desc(desc)) then - info = psb_err_input_matrix_unassembled_ + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif diff --git a/base/tools/psb_cdprt.f90 b/base/tools/psb_cdprt.f90 index b3e19b9a..952718d5 100644 --- a/base/tools/psb_cdprt.f90 +++ b/base/tools/psb_cdprt.f90 @@ -67,9 +67,9 @@ subroutine psb_cdprt(iout,desc_p,glob,short) 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,*) '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' @@ -144,15 +144,15 @@ subroutine psb_cdprt(iout,desc_p,glob,short) 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,*) '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) @@ -168,16 +168,16 @@ subroutine psb_cdprt(iout,desc_p,glob,short) 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) +!!$ 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) +!!$ 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 @@ -193,16 +193,16 @@ subroutine psb_cdprt(iout,desc_p,glob,short) 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) +!!$ 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) +!!$ 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 @@ -219,16 +219,16 @@ subroutine psb_cdprt(iout,desc_p,glob,short) 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) +!!$ 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) +!!$ 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 @@ -240,7 +240,7 @@ subroutine psb_cdprt(iout,desc_p,glob,short) 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 +!!$ if (.not.lshort) write(iout,*) idx,desc_p%idxmap%loc_to_glob(idx),n_elem_Recv,proc enddo end if diff --git a/base/tools/psb_cdren.f90 b/base/tools/psb_cdren.f90 index e96bfda6..19eca791 100644 --- a/base/tools/psb_cdren.f90 +++ b/base/tools/psb_cdren.f90 @@ -125,7 +125,6 @@ subroutine psb_cdren(trans,iperm,desc_a,info) ! fix glob_to_loc/loc_to_glob mappings, then indices lists ! hmm, maybe we should just move all of this onto a different level, ! have a specialized subroutine, and do it in the solver context???? - call psi_renum_idxmap(n_col,desc_a%lprm,desc_a%idxmap,info) if (allocated(desc_a%halo_index)) & & call psi_renum_index(desc_a%lprm,desc_a%halo_index,info) if (allocated(desc_a%ovrlap_index)) & diff --git a/base/tools/psb_cdrep.f90 b/base/tools/psb_cdrep.f90 index e2ffc8c7..ad3d2d21 100644 --- a/base/tools/psb_cdrep.f90 +++ b/base/tools/psb_cdrep.f90 @@ -104,6 +104,7 @@ subroutine psb_cdrep(m, ictxt, desc, info) use psb_sparse_mod use psi_mod + use psb_repl_map_mod implicit None !....Parameters... Integer, intent(in) :: m,ictxt @@ -173,8 +174,7 @@ subroutine psb_cdrep(m, ictxt, desc, info) !count local rows number ! allocate work vector - allocate(desc%idxmap%glob_to_loc(m),desc%matrix_data(psb_mdata_size_),& - & desc%idxmap%loc_to_glob(m),desc%lprm(1),& + allocate(desc%matrix_data(psb_mdata_size_),& & desc%ovrlap_elem(0,3),stat=info) if (info /= psb_success_) then info=psb_err_alloc_request_ @@ -184,8 +184,6 @@ subroutine psb_cdrep(m, ictxt, desc, info) endif ! If the index space is replicated there's no point in not having ! the full map on the current process. - desc%idxmap%state = psb_desc_normal_ - desc%matrix_data(psb_m_) = m desc%matrix_data(psb_n_) = n @@ -195,23 +193,23 @@ subroutine psb_cdrep(m, ictxt, desc, info) call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_)) desc%matrix_data(psb_dec_type_) = psb_desc_bld_ - do i=1,m - desc%idxmap%glob_to_loc(i) = i - desc%idxmap%loc_to_glob(i) = i - enddo - tovr = -1 - thalo = -1 - text = -1 - desc%lprm(:) = 0 + allocate(psb_repl_map :: desc%indxmap, stat=info) + select type(aa => desc%indxmap) + type is (psb_repl_map) + call aa%repl_map_init(ictxt,m,info) + class default + ! This cannot happen + info = psb_err_internal_error_ + call psb_errpush(info,name) + Goto 9999 + end select + - call psi_cnv_dsc(thalo,tovr,text,desc,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_cvn_dsc') - goto 9999 - end if + tovr = -1 + call psi_bld_tmpovrl(tovr,desc,info) + desc%matrix_data(psb_dec_type_) = psb_desc_bld_ - desc%matrix_data(psb_dec_type_) = psb_desc_repl_ if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': end' diff --git a/base/tools/psb_cspins.f90 b/base/tools/psb_cspins.f90 index 7a35f82e..16ab4e5e 100644 --- a/base/tools/psb_cspins.f90 +++ b/base/tools/psb_cspins.f90 @@ -80,7 +80,7 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild) call psb_info(ictxt, me, np) if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -115,50 +115,27 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild) endif if (psb_is_bld_desc(desc_a)) then - if (psb_is_large_desc(desc_a)) then allocate(ila(nz),jla(nz),stat=info) if (info /= psb_success_) then ch_err='allocate' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla) - if (info /= psb_success_) then - ch_err='psb_cdins' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - end if - nrow = psb_cd_get_local_rows(desc_a) - ncol = psb_cd_get_local_cols(desc_a) - - if (a%is_bld()) then - call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_coins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - else - info = psb_err_invalid_a_and_cd_state_ - call psb_errpush(info,name) - goto 9999 - end if - - else - call psb_cdins(nz,ia,ja,desc_a,info) if (info /= psb_success_) then ch_err='psb_cdins' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if nrow = psb_cd_get_local_rows(desc_a) ncol = psb_cd_get_local_cols(desc_a) if (a%is_bld()) then - call a%csput(nz,ia,ja,val,1,nrow,1,ncol,info,gtl=desc_a%idxmap%glob_to_loc) + call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_coins' @@ -171,16 +148,14 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild) goto 9999 end if - end if else if (psb_is_asb_desc(desc_a)) then - if (psb_is_large_desc(desc_a)) then - allocate(ila(nz),jla(nz),stat=info) if (info /= psb_success_) then ch_err='allocate' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if @@ -199,18 +174,6 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild) goto 9999 end if - else - nrow = psb_cd_get_local_rows(desc_a) - ncol = psb_cd_get_local_cols(desc_a) - call a%csput(nz,ia,ja,val,1,nrow,1,ncol,& - & info,gtl=desc_a%idxmap%glob_to_loc) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_coins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if else info = psb_err_invalid_cd_state_ call psb_errpush(info,name) @@ -262,12 +225,12 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) call psb_info(ictxt, me, np) if (.not.psb_is_ok_desc(desc_ar)) then - info = psb_err_input_matrix_unassembled_ + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_ok_desc(desc_ac)) then - info = psb_err_input_matrix_unassembled_ + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -300,7 +263,8 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) allocate(ila(nz),jla(nz),stat=info) if (info /= psb_success_) then ch_err='allocate' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if ila(1:nz) = ia(1:nz) @@ -311,7 +275,8 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) if (info /= psb_success_) then ch_err='psb_cdins' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if @@ -329,43 +294,10 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) else if (psb_is_asb_desc(desc_ac)) then write(psb_err_unit,*) 'Why are you calling me on an assembled desc_ac?' -!!$ if (psb_is_large_desc(desc_a)) then -!!$ -!!$ allocate(ila(nz),jla(nz),stat=info) -!!$ if (info /= psb_success_) then -!!$ ch_err='allocate' -!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) -!!$ goto 9999 -!!$ end if -!!$ -!!$ ila(1:nz) = ia(1:nz) -!!$ jla(1:nz) = ja(1:nz) -!!$ call psb_glob_to_loc(ila(1:nz),desc_a,info,iact='I') -!!$ call psb_glob_to_loc(jla(1:nz),desc_a,info,iact='I') -!!$ nrow = psb_cd_get_local_rows(desc_a) -!!$ ncol = psb_cd_get_local_cols(desc_a) -!!$ -!!$ call psb_coins(nz,ila,jla,val,a,1,nrow,1,ncol,& -!!$ & info,rebuild=rebuild_) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ ch_err='psb_coins' -!!$ call psb_errpush(info,name,a_err=ch_err) -!!$ goto 9999 -!!$ end if -!!$ -!!$ else -!!$ nrow = psb_cd_get_local_rows(desc_a) -!!$ ncol = psb_cd_get_local_cols(desc_a) -!!$ call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,& -!!$ & info,gtl=desc_a%idxmap%glob_to_loc,rebuild=rebuild_) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ ch_err='psb_coins' -!!$ call psb_errpush(info,name,a_err=ch_err) -!!$ goto 9999 -!!$ end if -!!$ end if + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + else info = psb_err_invalid_cd_state_ call psb_errpush(info,name) diff --git a/base/tools/psb_dcdbldext.F90 b/base/tools/psb_dcdbldext.F90 index a998ba66..e2902533 100644 --- a/base/tools/psb_dcdbldext.F90 +++ b/base/tools/psb_dcdbldext.F90 @@ -74,7 +74,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) ! .. Array Arguments .. integer, intent(in) :: novr - Type(psb_dspmat_type), Intent(in) :: a + Type(psb_dspmat_type), Intent(in) :: a Type(psb_desc_type), Intent(in), target :: desc_a Type(psb_desc_type), Intent(out) :: desc_ov integer, intent(out) :: info @@ -82,7 +82,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) ! .. Local Scalars .. Integer :: i, j, np, me,m,& - & ictxt, lovr, lworks,lworkr, n_row,n_col, int_err(5),& + & ictxt, lovr, lworks,lworkr, n_row,n_col, n_col_prev, int_err(5),& & index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo Integer :: counter,counter_h, counter_o, counter_e,idx,gidx,proc,n_elem_recv,& & n_elem_send,tot_recv,tot_elem,cntov_o,& @@ -130,9 +130,18 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) goto 9999 endif + select case(extype_) + case(psb_ovt_xhal_,psb_ovt_asov_) + case default + call psb_errpush(psb_err_input_value_invalid_i_,& + & name,i_err=(/5,extype_,0,0,0/)) + goto 9999 + end select + if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& - & ':Calling desccpy' + & ': Calling desccpy' + call psb_cdcpy(desc_a,desc_ov,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ @@ -140,25 +149,35 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name,a_err=ch_err) goto 9999 end if + if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& - & ':From desccpy' + & ': From desccpy' - if (novr == 0) then + if ((novr == 0).or.(np==1)) then ! ! Just copy the input. + ! Should we return also when is_repl() ? ! return endif + if ((extype_ == psb_ovt_asov_).and.& + & (.not.desc_ov%indxmap%row_extendable())) then + ! Need to switch to a format that can support overlap, + ! so far: LIST or HASH. Encapsulate choice + ! in a separate method. + call psb_cd_switch_ovl_indxmap(desc_ov,info) + end if + + call psb_cd_set_ovl_bld(desc_ov,info) If (debug_level >= psb_debug_outer_)then Write(debug_unit,*) me,' ',trim(name),& - & ':BEGIN ',nhalo + & ': BEGIN ',nhalo, desc_ov%indxmap%get_state() call psb_barrier(ictxt) endif - ! ! Ok, since we are only estimating, do it as follows: ! LOVR= (NNZ/NROW)*N_HALO*NOVR This assumes that the local average @@ -183,11 +202,11 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) l_tmp_ovr_idx = novr*(3*Max(2*index_dim,1)+1) l_tmp_halo = novr*(3*Size(desc_a%halo_index)) - call psb_cd_set_ovl_bld(desc_ov,info) desc_ov%base_desc => desc_a If (debug_level >= psb_debug_outer_) then - Write(debug_unit,*) me,' ',trim(name),':Start',lworks,lworkr + Write(debug_unit,*) me,' ',trim(name),':Start',& + & lworks,lworkr, desc_ov%indxmap%get_state() call psb_barrier(ictxt) endif @@ -231,7 +250,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) Do j=0,n_elem_recv-1 idx = desc_a%ovrlap_index(counter+psb_elem_recv_+j) - call psb_map_l2g(idx,gidx,desc_ov%idxmap,info) + call desc_ov%indxmap%l2g(idx,gidx,info) If (gidx < 0) then info=-3 call psb_errpush(info,name) @@ -297,7 +316,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) counter = 1 counter_t = 1 - desc_ov%matrix_data(psb_n_row_)=desc_ov%matrix_data(psb_n_col_) + n_col_prev = psb_cd_get_local_cols(desc_ov) Do While (halo(counter) /= -1) tot_elem=0 @@ -325,14 +344,14 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) ! add recv elements in halo_index into ovrlap_index ! Do j=0,n_elem_recv-1 - If((counter+psb_elem_recv_+j)>Size(halo)) then + If ((counter+psb_elem_recv_+j)>Size(halo)) then info=-2 call psb_errpush(info,name) goto 9999 end If idx = halo(counter+psb_elem_recv_+j) - call psb_map_l2g(idx,gidx,desc_ov%idxmap,info) + call desc_ov%indxmap%l2g(idx,gidx,info) If (gidx < 0) then info=-3 call psb_errpush(info,name) @@ -376,7 +395,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) Do j=0,n_elem_send-1 idx = halo(counter+psb_elem_send_+j) - call psb_map_l2g(idx,gidx,desc_ov%idxmap,info) + call desc_ov%indxmap%l2g(idx,gidx,info) If (gidx < 0) then info=-3 call psb_errpush(info,name) @@ -412,9 +431,10 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if - call psb_map_l2g(icol(1:n_elem),& + call desc_ov%indxmap%l2g(icol(1:n_elem),& & works(idxs+tot_elem+1:idxs+tot_elem+n_elem),& - & desc_ov%idxmap,info) + & info) + tot_elem=tot_elem+n_elem End If @@ -491,114 +511,73 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': ISZR :',iszr - if (psb_is_large_desc(desc_ov)) then - call psb_ensure_size(iszr,maskr,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_ensure_size') - goto 9999 + call psb_ensure_size(iszr,maskr,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_ensure_size') + goto 9999 + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': going for first idx_cnv', desc_ov%indxmap%get_state() + + call psi_idx_cnv(iszr,workr,maskr,desc_ov,info) + iszs = count(maskr(1:iszr)<=0) + if (iszs > size(works)) call psb_realloc(iszs,works,info) + j = 0 + do i=1,iszr + if (maskr(i) < 0) then + j=j+1 + works(j) = workr(i) end if - call psi_idx_cnv(iszr,workr,maskr,desc_ov,info) - iszs = count(maskr(1:iszr)<=0) - if (iszs > size(works)) call psb_realloc(iszs,works,info) - j = 0 - do i=1,iszr - if (maskr(i) < 0) then - j=j+1 - works(j) = workr(i) - end if - end do - ! Eliminate duplicates from request - call psb_msort_unique(works(1:j),iszs) + end do + ! Eliminate duplicates from request + call psb_msort_unique(works(1:j),iszs) + + ! + ! fnd_owner on desc_a because we want the procs who + ! owned the rows from the beginning! + ! + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': going for fnd_owner', desc_ov%indxmap%get_state() + call psi_fnd_owner(iszs,works,temp,desc_a,info) + n_col = psb_cd_get_local_cols(desc_ov) - ! - ! fnd_owner on desc_a because we want the procs who - ! owned the rows from the beginning! - ! - call psi_fnd_owner(iszs,works,temp,desc_a,info) - n_col = psb_cd_get_local_cols(desc_ov) - - do i=1,iszs - idx = works(i) - n_col = psb_cd_get_local_cols(desc_ov) - call psi_idx_ins_cnv(idx,lidx,desc_ov,info) - if (psb_cd_get_local_cols(desc_ov) > n_col ) then - ! - ! This is a new index. Assigning a local index as - ! we receive them guarantees that all indices for HALO(I) - ! will be less than those for HALO(J) whenever I= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': Done fnd_owner', desc_ov%indxmap%get_state() + + do i=1,iszs + idx = works(i) n_col = psb_cd_get_local_cols(desc_ov) - - else - - Do i=1,iszr - idx=workr(i) - if (idx <1) then - write(psb_err_unit,*) me,'Error in CDBLDEXTBLD level',i_ovr,' : ',idx,i,iszr - else If (desc_ov%idxmap%glob_to_loc(idx) < -np) Then - ! - ! This is a new index. Assigning a local index as - ! we receive them guarantees that all indices for HALO(I) - ! will be less than those for HALO(J) whenever I= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ': Added into t_halo_in from recv',& - & proc_id,n_col,idx - else if (desc_ov%idxmap%glob_to_loc(idx) < 0) Then - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ':Wrong input to cdbldextbld?',& - & idx,desc_ov%idxmap%glob_to_loc(idx) - End If - End Do - desc_ov%matrix_data(psb_n_col_) = n_col - - end if + call psi_idx_ins_cnv(idx,lidx,desc_ov,info) + if (psb_cd_get_local_cols(desc_ov) > n_col ) then + ! + ! This is a new index. Assigning a local index as + ! we receive them guarantees that all indices for HALO(I) + ! will be less than those for HALO(J) whenever I0),count(jla(1:nz)>0) if (a%is_bld()) then - call a%csput(nz,ia,ja,val,1,nrow,1,ncol,info,gtl=desc_a%idxmap%glob_to_loc) + call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_coins' @@ -170,16 +148,14 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) goto 9999 end if - end if else if (psb_is_asb_desc(desc_a)) then - if (psb_is_large_desc(desc_a)) then - allocate(ila(nz),jla(nz),stat=info) if (info /= psb_success_) then ch_err='allocate' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if @@ -198,18 +174,6 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) goto 9999 end if - else - nrow = psb_cd_get_local_rows(desc_a) - ncol = psb_cd_get_local_cols(desc_a) - call a%csput(nz,ia,ja,val,1,nrow,1,ncol,& - & info,gtl=desc_a%idxmap%glob_to_loc) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_coins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if else info = psb_err_invalid_cd_state_ call psb_errpush(info,name) @@ -260,12 +224,12 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) call psb_info(ictxt, me, np) if (.not.psb_is_ok_desc(desc_ar)) then - info = psb_err_input_matrix_unassembled_ + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_ok_desc(desc_ac)) then - info = psb_err_input_matrix_unassembled_ + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -298,7 +262,8 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) allocate(ila(nz),jla(nz),stat=info) if (info /= psb_success_) then ch_err='allocate' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if ila(1:nz) = ia(1:nz) @@ -309,7 +274,8 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) if (info /= psb_success_) then ch_err='psb_cdins' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if @@ -327,43 +293,10 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) else if (psb_is_asb_desc(desc_ac)) then write(psb_err_unit,*) 'Why are you calling me on an assembled desc_ac?' -!!$ if (psb_is_large_desc(desc_a)) then -!!$ -!!$ allocate(ila(nz),jla(nz),stat=info) -!!$ if (info /= psb_success_) then -!!$ ch_err='allocate' -!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) -!!$ goto 9999 -!!$ end if -!!$ -!!$ ila(1:nz) = ia(1:nz) -!!$ jla(1:nz) = ja(1:nz) -!!$ call psb_glob_to_loc(ila(1:nz),desc_a,info,iact='I') -!!$ call psb_glob_to_loc(jla(1:nz),desc_a,info,iact='I') -!!$ nrow = psb_cd_get_local_rows(desc_a) -!!$ ncol = psb_cd_get_local_cols(desc_a) -!!$ -!!$ call psb_coins(nz,ila,jla,val,a,1,nrow,1,ncol,& -!!$ & info,rebuild=rebuild_) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ ch_err='psb_coins' -!!$ call psb_errpush(info,name,a_err=ch_err) -!!$ goto 9999 -!!$ end if -!!$ -!!$ else -!!$ nrow = psb_cd_get_local_rows(desc_a) -!!$ ncol = psb_cd_get_local_cols(desc_a) -!!$ call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,& -!!$ & info,gtl=desc_a%idxmap%glob_to_loc,rebuild=rebuild_) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ ch_err='psb_coins' -!!$ call psb_errpush(info,name,a_err=ch_err) -!!$ goto 9999 -!!$ end if -!!$ end if + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + else info = psb_err_invalid_cd_state_ call psb_errpush(info,name) diff --git a/base/tools/psb_icdasb.F90 b/base/tools/psb_icdasb.F90 index c9b5b94e..5d6e9efc 100644 --- a/base/tools/psb_icdasb.F90 +++ b/base/tools/psb_icdasb.F90 @@ -95,7 +95,7 @@ subroutine psb_icdasb(desc_a,info,ext_hv) call psb_errpush(info,name) goto 9999 endif - + info = psb_get_errstatus() if (info /= psb_success_) then ! Something went wrong in cdins/spins @@ -104,7 +104,7 @@ subroutine psb_icdasb(desc_a,info,ext_hv) call psb_errpush(info,name) goto 9999 end if - + if (present(ext_hv)) then ext_hv_ = ext_hv else @@ -113,40 +113,11 @@ subroutine psb_icdasb(desc_a,info,ext_hv) if (debug_level >= psb_debug_ext_) & & write(debug_unit, *) me,' ',trim(name),': start' - if (psb_is_bld_desc(desc_a)) then - - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': Checking rows insertion' - ! - ! check if all local row are inserted - ! Note: this may still be useful for the case of - ! cdall(..., vl=vl, globalcheck=.false.) - ! - do i=1,psb_cd_get_local_cols(desc_a) - if (desc_a%idxmap%loc_to_glob(i) < 0) then - info=3100 - exit - endif - enddo - - if (info /= psb_no_err_) then - call psb_errpush(info,name,i_err=int_err) + if (allocated(desc_a%indxmap)) then + call psi_ldsc_pre_halo(desc_a,ext_hv_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='ldsc_pre_halo') goto 9999 - endif - ! Trim size of loc_to_glob component. - call psb_realloc(psb_cd_get_local_cols(desc_a),desc_a%idxmap%loc_to_glob,info) - - ! If large index space, we have to pre-process and rebuild - ! the list of halo indices as if it was in small index space - if (psb_is_large_desc(desc_a)) then - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),& - & ': Large descriptor, calling ldsc_pre_halo' - call psi_ldsc_pre_halo(desc_a,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 end if ! Take out the lists for ovrlap, halo and ext... @@ -158,6 +129,7 @@ subroutine psb_icdasb(desc_a,info,ext_hv) & 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) + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_cnv_dsc') goto 9999 @@ -170,8 +142,17 @@ subroutine psb_icdasb(desc_a,info,ext_hv) goto 9999 end if + call desc_a%indxmap%asb(info) + 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) diff --git a/base/tools/psb_loc_to_glob.f90 b/base/tools/psb_loc_to_glob.f90 index 267a5743..3c8ead66 100644 --- a/base/tools/psb_loc_to_glob.f90 +++ b/base/tools/psb_loc_to_glob.f90 @@ -74,7 +74,7 @@ subroutine psb_loc_to_glob2(x,y,desc_a,info,iact) endif act=psb_toupper(act) - call psb_map_l2g(x,y,desc_a%idxmap,info) + call desc_a%indxmap%l2g(x,y,info) if (info /= psb_success_) then select case(act) @@ -179,7 +179,7 @@ subroutine psb_loc_to_glob(x,desc_a,info,iact) endif act = psb_toupper(act) - call psb_map_l2g(x,desc_a%idxmap,info) + call desc_a%indxmap%l2g(x,info) if (info /= psb_success_) then select case(act) diff --git a/base/tools/psb_scdbldext.F90 b/base/tools/psb_scdbldext.F90 index 3bfa2164..d004b991 100644 --- a/base/tools/psb_scdbldext.F90 +++ b/base/tools/psb_scdbldext.F90 @@ -63,6 +63,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) use psb_sparse_mod, psb_protect_name => psb_scdbldext use psi_mod + #ifdef MPI_MOD use mpi #endif @@ -73,7 +74,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) ! .. Array Arguments .. integer, intent(in) :: novr - Type(psb_sspmat_type), Intent(in) :: a + Type(psb_sspmat_type), Intent(in) :: a Type(psb_desc_type), Intent(in), target :: desc_a Type(psb_desc_type), Intent(out) :: desc_ov integer, intent(out) :: info @@ -81,7 +82,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) ! .. Local Scalars .. Integer :: i, j, np, me,m,& - & ictxt, lovr, lworks,lworkr, n_row,n_col, int_err(5),& + & ictxt, lovr, lworks,lworkr, n_row,n_col, n_col_prev, int_err(5),& & index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo Integer :: counter,counter_h, counter_o, counter_e,idx,gidx,proc,n_elem_recv,& & n_elem_send,tot_recv,tot_elem,cntov_o,& @@ -129,9 +130,18 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) goto 9999 endif + select case(extype_) + case(psb_ovt_xhal_,psb_ovt_asov_) + case default + call psb_errpush(psb_err_input_value_invalid_i_,& + & name,i_err=(/5,extype_,0,0,0/)) + goto 9999 + end select + if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& - & ':Calling desccpy' + & ': Calling desccpy' + call psb_cdcpy(desc_a,desc_ov,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ @@ -139,25 +149,35 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name,a_err=ch_err) goto 9999 end if + if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& - & ':From desccpy' + & ': From desccpy' - if (novr == 0) then + if ((novr == 0).or.(np==1)) then ! ! Just copy the input. + ! Should we return also when is_repl() ? ! return endif + if ((extype_ == psb_ovt_asov_).and.& + & (.not.desc_ov%indxmap%row_extendable())) then + ! Need to switch to a format that can support overlap, + ! so far: LIST or HASH. Encapsulate choice + ! in a separate method. + call psb_cd_switch_ovl_indxmap(desc_ov,info) + end if + + call psb_cd_set_ovl_bld(desc_ov,info) If (debug_level >= psb_debug_outer_)then Write(debug_unit,*) me,' ',trim(name),& - & ':BEGIN ',nhalo + & ': BEGIN ',nhalo, desc_ov%indxmap%get_state() call psb_barrier(ictxt) endif - ! ! Ok, since we are only estimating, do it as follows: ! LOVR= (NNZ/NROW)*N_HALO*NOVR This assumes that the local average @@ -182,11 +202,11 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) l_tmp_ovr_idx = novr*(3*Max(2*index_dim,1)+1) l_tmp_halo = novr*(3*Size(desc_a%halo_index)) - call psb_cd_set_ovl_bld(desc_ov,info) desc_ov%base_desc => desc_a If (debug_level >= psb_debug_outer_) then - Write(debug_unit,*) me,' ',trim(name),':Start',lworks,lworkr + Write(debug_unit,*) me,' ',trim(name),':Start',& + & lworks,lworkr, desc_ov%indxmap%get_state() call psb_barrier(ictxt) endif @@ -230,7 +250,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) Do j=0,n_elem_recv-1 idx = desc_a%ovrlap_index(counter+psb_elem_recv_+j) - call psb_map_l2g(idx,gidx,desc_ov%idxmap,info) + call desc_ov%indxmap%l2g(idx,gidx,info) If (gidx < 0) then info=-3 call psb_errpush(info,name) @@ -296,7 +316,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) counter = 1 counter_t = 1 - desc_ov%matrix_data(psb_n_row_)=desc_ov%matrix_data(psb_n_col_) + n_col_prev = psb_cd_get_local_cols(desc_ov) Do While (halo(counter) /= -1) tot_elem=0 @@ -331,12 +351,12 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) end If idx = halo(counter+psb_elem_recv_+j) - call psb_map_l2g(idx,gidx,desc_ov%idxmap,info) + call desc_ov%indxmap%l2g(idx,gidx,info) If (gidx < 0) then info=-3 call psb_errpush(info,name) goto 9999 - endif + endif call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) if (info /= psb_success_) then info=psb_err_from_subroutine_ @@ -375,7 +395,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) Do j=0,n_elem_send-1 idx = halo(counter+psb_elem_send_+j) - call psb_map_l2g(idx,gidx,desc_ov%idxmap,info) + call desc_ov%indxmap%l2g(idx,gidx,info) If (gidx < 0) then info=-3 call psb_errpush(info,name) @@ -411,9 +431,10 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if - call psb_map_l2g(icol(1:n_elem),& + call desc_ov%indxmap%l2g(icol(1:n_elem),& & works(idxs+tot_elem+1:idxs+tot_elem+n_elem),& - & desc_ov%idxmap,info) + & info) + tot_elem=tot_elem+n_elem End If @@ -490,114 +511,73 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': ISZR :',iszr - if (psb_is_large_desc(desc_ov)) then - call psb_ensure_size(iszr,maskr,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_ensure_size') - goto 9999 + call psb_ensure_size(iszr,maskr,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_ensure_size') + goto 9999 + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': going for first idx_cnv', desc_ov%indxmap%get_state() + + call psi_idx_cnv(iszr,workr,maskr,desc_ov,info) + iszs = count(maskr(1:iszr)<=0) + if (iszs > size(works)) call psb_realloc(iszs,works,info) + j = 0 + do i=1,iszr + if (maskr(i) < 0) then + j=j+1 + works(j) = workr(i) end if - call psi_idx_cnv(iszr,workr,maskr,desc_ov,info) - iszs = count(maskr(1:iszr)<=0) - if (iszs > size(works)) call psb_realloc(iszs,works,info) - j = 0 - do i=1,iszr - if (maskr(i) < 0) then - j=j+1 - works(j) = workr(i) - end if - end do - ! Eliminate duplicates from request - call psb_msort_unique(works(1:j),iszs) + end do + ! Eliminate duplicates from request + call psb_msort_unique(works(1:j),iszs) + + ! + ! fnd_owner on desc_a because we want the procs who + ! owned the rows from the beginning! + ! + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': going for fnd_owner', desc_ov%indxmap%get_state() + call psi_fnd_owner(iszs,works,temp,desc_a,info) + n_col = psb_cd_get_local_cols(desc_ov) - ! - ! fnd_owner on desc_a because we want the procs who - ! owned the rows from the beginning! - ! - call psi_fnd_owner(iszs,works,temp,desc_a,info) - n_col = psb_cd_get_local_cols(desc_ov) - - do i=1,iszs - idx = works(i) - n_col = psb_cd_get_local_cols(desc_ov) - call psi_idx_ins_cnv(idx,lidx,desc_ov,info) - if (psb_cd_get_local_cols(desc_ov) > n_col ) then - ! - ! This is a new index. Assigning a local index as - ! we receive them guarantees that all indices for HALO(I) - ! will be less than those for HALO(J) whenever I= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': Done fnd_owner', desc_ov%indxmap%get_state() + + do i=1,iszs + idx = works(i) n_col = psb_cd_get_local_cols(desc_ov) - - else - - Do i=1,iszr - idx=workr(i) - if (idx <1) then - write(psb_err_unit,*) me,'Error in CDBLDEXTBLD level',i_ovr,' : ',idx,i,iszr - else If (desc_ov%idxmap%glob_to_loc(idx) < -np) Then - ! - ! This is a new index. Assigning a local index as - ! we receive them guarantees that all indices for HALO(I) - ! will be less than those for HALO(J) whenever I= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ': Added into t_halo_in from recv',& - & proc_id,n_col,idx - else if (desc_ov%idxmap%glob_to_loc(idx) < 0) Then - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ':Wrong input to cdbldextbld?',& - & idx,desc_ov%idxmap%glob_to_loc(idx) - End If - End Do - desc_ov%matrix_data(psb_n_col_) = n_col - - end if + call psi_idx_ins_cnv(idx,lidx,desc_ov,info) + if (psb_cd_get_local_cols(desc_ov) > n_col ) then + ! + ! This is a new index. Assigning a local index as + ! we receive them guarantees that all indices for HALO(I) + ! will be less than those for HALO(J) whenever I= psb_debug_outer_) then - write(debug_unit,*) me,' ',trim(name),':Checktmp_o_i 1',tmp_ovr_idx(1:10) - write(debug_unit,*) me,' ',trim(name),':Calling Crea_index' - end if + write(debug_unit,*) me,' ',trim(name),':Checktmp_o_i 1',tmp_ovr_idx(1:10) + write(debug_unit,*) me,' ',trim(name),':Calling Crea_index' + end if call psi_crea_index(desc_ov,t_halo_in,t_halo_out,.false.,& & nxch,nsnd,nrcv,info) - + if (debug_level >= psb_debug_outer_) then write(debug_unit,*) me,' ',trim(name),':Done Crea_Index' call psb_barrier(ictxt) @@ -640,7 +620,6 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) ! 4. n_row(ov) = n_row(a) ! 5. n_col(ov) current. ! - desc_ov%matrix_data(psb_n_row_) = desc_a%matrix_data(psb_n_row_) call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) call psb_ensure_size((counter_h+counter_t+1),tmp_halo,info,pad=-1) if (info /= psb_success_) then @@ -668,6 +647,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) ! 4. n_row(ov) current. ! 5. n_col(ov) current. ! + call desc_ov%indxmap%set_lr(n_col_prev) call psb_ensure_size((cntov_o+counter_o+1),orig_ovr,info,pad=-1) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') @@ -714,7 +694,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) if (allocated(irow)) deallocate(irow,stat=info) if ((info == psb_success_).and.allocated(icol)) deallocate(icol,stat=info) if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err='deallocate',i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='deallocate',i_err=(/info,0,0,0,0/)) goto 9999 end if end if diff --git a/base/tools/psb_sspins.f90 b/base/tools/psb_sspins.f90 index 3ebebd77..3fd72b56 100644 --- a/base/tools/psb_sspins.f90 +++ b/base/tools/psb_sspins.f90 @@ -79,7 +79,7 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild) call psb_info(ictxt, me, np) if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -114,50 +114,27 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild) endif if (psb_is_bld_desc(desc_a)) then - if (psb_is_large_desc(desc_a)) then allocate(ila(nz),jla(nz),stat=info) if (info /= psb_success_) then ch_err='allocate' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla) - if (info /= psb_success_) then - ch_err='psb_cdins' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - end if - nrow = psb_cd_get_local_rows(desc_a) - ncol = psb_cd_get_local_cols(desc_a) - - if (a%is_bld()) then - call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_coins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - else - info = psb_err_invalid_a_and_cd_state_ - call psb_errpush(info,name) - goto 9999 - end if - - else - call psb_cdins(nz,ia,ja,desc_a,info) if (info /= psb_success_) then ch_err='psb_cdins' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if nrow = psb_cd_get_local_rows(desc_a) ncol = psb_cd_get_local_cols(desc_a) if (a%is_bld()) then - call a%csput(nz,ia,ja,val,1,nrow,1,ncol,info,gtl=desc_a%idxmap%glob_to_loc) + call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_coins' @@ -170,16 +147,14 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild) goto 9999 end if - end if else if (psb_is_asb_desc(desc_a)) then - if (psb_is_large_desc(desc_a)) then - allocate(ila(nz),jla(nz),stat=info) if (info /= psb_success_) then ch_err='allocate' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if @@ -198,18 +173,6 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild) goto 9999 end if - else - nrow = psb_cd_get_local_rows(desc_a) - ncol = psb_cd_get_local_cols(desc_a) - call a%csput(nz,ia,ja,val,1,nrow,1,ncol,& - & info,gtl=desc_a%idxmap%glob_to_loc) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_coins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if else info = psb_err_invalid_cd_state_ call psb_errpush(info,name) @@ -260,12 +223,12 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) call psb_info(ictxt, me, np) if (.not.psb_is_ok_desc(desc_ar)) then - info = psb_err_input_matrix_unassembled_ + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_ok_desc(desc_ac)) then - info = psb_err_input_matrix_unassembled_ + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -298,7 +261,8 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) allocate(ila(nz),jla(nz),stat=info) if (info /= psb_success_) then ch_err='allocate' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if ila(1:nz) = ia(1:nz) @@ -309,7 +273,8 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) if (info /= psb_success_) then ch_err='psb_cdins' - call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if @@ -327,43 +292,10 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) else if (psb_is_asb_desc(desc_ac)) then write(psb_err_unit,*) 'Why are you calling me on an assembled desc_ac?' -!!$ if (psb_is_large_desc(desc_a)) then -!!$ -!!$ allocate(ila(nz),jla(nz),stat=info) -!!$ if (info /= psb_success_) then -!!$ ch_err='allocate' -!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) -!!$ goto 9999 -!!$ end if -!!$ -!!$ ila(1:nz) = ia(1:nz) -!!$ jla(1:nz) = ja(1:nz) -!!$ call psb_glob_to_loc(ila(1:nz),desc_a,info,iact='I') -!!$ call psb_glob_to_loc(jla(1:nz),desc_a,info,iact='I') -!!$ nrow = psb_cd_get_local_rows(desc_a) -!!$ ncol = psb_cd_get_local_cols(desc_a) -!!$ -!!$ call psb_coins(nz,ila,jla,val,a,1,nrow,1,ncol,& -!!$ & info,rebuild=rebuild_) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ ch_err='psb_coins' -!!$ call psb_errpush(info,name,a_err=ch_err) -!!$ goto 9999 -!!$ end if -!!$ -!!$ else -!!$ nrow = psb_cd_get_local_rows(desc_a) -!!$ ncol = psb_cd_get_local_cols(desc_a) -!!$ call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,& -!!$ & info,gtl=desc_a%idxmap%glob_to_loc,rebuild=rebuild_) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ ch_err='psb_coins' -!!$ call psb_errpush(info,name,a_err=ch_err) -!!$ goto 9999 -!!$ end if -!!$ end if + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + else info = psb_err_invalid_cd_state_ call psb_errpush(info,name) diff --git a/base/tools/psb_zcdbldext.F90 b/base/tools/psb_zcdbldext.F90 index 7e0f1886..5238b1b4 100644 --- a/base/tools/psb_zcdbldext.F90 +++ b/base/tools/psb_zcdbldext.F90 @@ -63,6 +63,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) use psb_sparse_mod, psb_protect_name => psb_zcdbldext use psi_mod + #ifdef MPI_MOD use mpi #endif @@ -72,16 +73,17 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) #endif ! .. Array Arguments .. - integer, intent(in) :: novr + integer, intent(in) :: novr Type(psb_zspmat_type), Intent(in) :: a Type(psb_desc_type), Intent(in), target :: desc_a Type(psb_desc_type), Intent(out) :: desc_ov integer, intent(out) :: info integer, intent(in),optional :: extype + ! .. Local Scalars .. Integer :: i, j, np, me,m,& - & ictxt, lovr, lworks,lworkr, n_row,n_col, int_err(5),& + & ictxt, lovr, lworks,lworkr, n_row,n_col, n_col_prev, int_err(5),& & index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo Integer :: counter,counter_h, counter_o, counter_e,idx,gidx,proc,n_elem_recv,& & n_elem_send,tot_recv,tot_elem,cntov_o,& @@ -129,9 +131,18 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) goto 9999 endif + select case(extype_) + case(psb_ovt_xhal_,psb_ovt_asov_) + case default + call psb_errpush(psb_err_input_value_invalid_i_,& + & name,i_err=(/5,extype_,0,0,0/)) + goto 9999 + end select + if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& - & ':Calling desccpy' + & ': Calling desccpy' + call psb_cdcpy(desc_a,desc_ov,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ @@ -139,25 +150,35 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name,a_err=ch_err) goto 9999 end if + if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& - & ':From desccpy' + & ': From desccpy' - if (novr == 0) then + if ((novr == 0).or.(np==1)) then ! ! Just copy the input. + ! Should we return also when is_repl() ? ! return endif + if ((extype_ == psb_ovt_asov_).and.& + & (.not.desc_ov%indxmap%row_extendable())) then + ! Need to switch to a format that can support overlap, + ! so far: LIST or HASH. Encapsulate choice + ! in a separate method. + call psb_cd_switch_ovl_indxmap(desc_ov,info) + end if + + call psb_cd_set_ovl_bld(desc_ov,info) If (debug_level >= psb_debug_outer_)then Write(debug_unit,*) me,' ',trim(name),& - & ':BEGIN ',nhalo + & ': BEGIN ',nhalo, desc_ov%indxmap%get_state() call psb_barrier(ictxt) endif - ! ! Ok, since we are only estimating, do it as follows: ! LOVR= (NNZ/NROW)*N_HALO*NOVR This assumes that the local average @@ -182,11 +203,11 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) l_tmp_ovr_idx = novr*(3*Max(2*index_dim,1)+1) l_tmp_halo = novr*(3*Size(desc_a%halo_index)) - call psb_cd_set_ovl_bld(desc_ov,info) desc_ov%base_desc => desc_a If (debug_level >= psb_debug_outer_) then - Write(debug_unit,*) me,' ',trim(name),':Start',lworks,lworkr + Write(debug_unit,*) me,' ',trim(name),':Start',& + & lworks,lworkr, desc_ov%indxmap%get_state() call psb_barrier(ictxt) endif @@ -230,7 +251,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) Do j=0,n_elem_recv-1 idx = desc_a%ovrlap_index(counter+psb_elem_recv_+j) - call psb_map_l2g(idx,gidx,desc_ov%idxmap,info) + call desc_ov%indxmap%l2g(idx,gidx,info) If (gidx < 0) then info=-3 call psb_errpush(info,name) @@ -296,7 +317,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) counter = 1 counter_t = 1 - desc_ov%matrix_data(psb_n_row_)=desc_ov%matrix_data(psb_n_col_) + n_col_prev = psb_cd_get_local_cols(desc_ov) Do While (halo(counter) /= -1) tot_elem=0 @@ -324,14 +345,14 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) ! add recv elements in halo_index into ovrlap_index ! Do j=0,n_elem_recv-1 - If((counter+psb_elem_recv_+j)>Size(halo)) then + If ((counter+psb_elem_recv_+j)>Size(halo)) then info=-2 call psb_errpush(info,name) goto 9999 end If idx = halo(counter+psb_elem_recv_+j) - call psb_map_l2g(idx,gidx,desc_ov%idxmap,info) + call desc_ov%indxmap%l2g(idx,gidx,info) If (gidx < 0) then info=-3 call psb_errpush(info,name) @@ -375,7 +396,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) Do j=0,n_elem_send-1 idx = halo(counter+psb_elem_send_+j) - call psb_map_l2g(idx,gidx,desc_ov%idxmap,info) + call desc_ov%indxmap%l2g(idx,gidx,info) If (gidx < 0) then info=-3 call psb_errpush(info,name) @@ -411,9 +432,10 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if - call psb_map_l2g(icol(1:n_elem),& + call desc_ov%indxmap%l2g(icol(1:n_elem),& & works(idxs+tot_elem+1:idxs+tot_elem+n_elem),& - & desc_ov%idxmap,info) + & info) + tot_elem=tot_elem+n_elem End If @@ -490,114 +512,73 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': ISZR :',iszr - if (psb_is_large_desc(desc_ov)) then - call psb_ensure_size(iszr,maskr,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_ensure_size') - goto 9999 + call psb_ensure_size(iszr,maskr,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_ensure_size') + goto 9999 + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': going for first idx_cnv', desc_ov%indxmap%get_state() + + call psi_idx_cnv(iszr,workr,maskr,desc_ov,info) + iszs = count(maskr(1:iszr)<=0) + if (iszs > size(works)) call psb_realloc(iszs,works,info) + j = 0 + do i=1,iszr + if (maskr(i) < 0) then + j=j+1 + works(j) = workr(i) end if - call psi_idx_cnv(iszr,workr,maskr,desc_ov,info) - iszs = count(maskr(1:iszr)<=0) - if (iszs > size(works)) call psb_realloc(iszs,works,info) - j = 0 - do i=1,iszr - if (maskr(i) < 0) then - j=j+1 - works(j) = workr(i) - end if - end do - ! Eliminate duplicates from request - call psb_msort_unique(works(1:j),iszs) + end do + ! Eliminate duplicates from request + call psb_msort_unique(works(1:j),iszs) + + ! + ! fnd_owner on desc_a because we want the procs who + ! owned the rows from the beginning! + ! + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': going for fnd_owner', desc_ov%indxmap%get_state() + call psi_fnd_owner(iszs,works,temp,desc_a,info) + n_col = psb_cd_get_local_cols(desc_ov) - ! - ! fnd_owner on desc_a because we want the procs who - ! owned the rows from the beginning! - ! - call psi_fnd_owner(iszs,works,temp,desc_a,info) - n_col = psb_cd_get_local_cols(desc_ov) - - do i=1,iszs - idx = works(i) - n_col = psb_cd_get_local_cols(desc_ov) - call psi_idx_ins_cnv(idx,lidx,desc_ov,info) - if (psb_cd_get_local_cols(desc_ov) > n_col ) then - ! - ! This is a new index. Assigning a local index as - ! we receive them guarantees that all indices for HALO(I) - ! will be less than those for HALO(J) whenever I= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': Done fnd_owner', desc_ov%indxmap%get_state() + + do i=1,iszs + idx = works(i) n_col = psb_cd_get_local_cols(desc_ov) - - else - - Do i=1,iszr - idx=workr(i) - if (idx <1) then - write(psb_err_unit,*) me,'Error in CDBLDEXTBLD level',i_ovr,' : ',idx,i,iszr - else If (desc_ov%idxmap%glob_to_loc(idx) < -np) Then - ! - ! This is a new index. Assigning a local index as - ! we receive them guarantees that all indices for HALO(I) - ! will be less than those for HALO(J) whenever I= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ': Added into t_halo_in from recv',& - & proc_id,n_col,idx - else if (desc_ov%idxmap%glob_to_loc(idx) < 0) Then - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ':Wrong input to cdbldextbld?',& - & idx,desc_ov%idxmap%glob_to_loc(idx) - End If - End Do - desc_ov%matrix_data(psb_n_col_) = n_col - - end if + call psi_idx_ins_cnv(idx,lidx,desc_ov,info) + if (psb_cd_get_local_cols(desc_ov) > n_col ) then + ! + ! This is a new index. Assigning a local index as + ! we receive them guarantees that all indices for HALO(I) + ! will be less than those for HALO(J) whenever I