From b462db7444d1e885f02ad5f4fc75b72a7cd0c87f Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 21 Feb 2018 08:31:22 +0000 Subject: [PATCH] Modified list_map and gen_block_map for large integers; to be tested properly. --- base/modules/desc/psb_gen_block_map_mod.f90 | 4 +- base/modules/desc/psb_hash_map_mod.f90 | 7 +- base/modules/desc/psb_list_map_mod.f90 | 479 +++++++++++++++++++- util/psb_partidx_mod.F90 | 130 +++++- 4 files changed, 610 insertions(+), 10 deletions(-) diff --git a/base/modules/desc/psb_gen_block_map_mod.f90 b/base/modules/desc/psb_gen_block_map_mod.f90 index 1b926b37..ff6aadae 100644 --- a/base/modules/desc/psb_gen_block_map_mod.f90 +++ b/base/modules/desc/psb_gen_block_map_mod.f90 @@ -52,8 +52,8 @@ module psb_gen_block_map_mod use psb_hash_mod type, extends(psb_indx_map) :: psb_gen_block_map - integer(psb_ipk_) :: min_glob_row = -1 - integer(psb_ipk_) :: max_glob_row = -1 + integer(psb_lpk_) :: min_glob_row = -1 + integer(psb_lpk_) :: max_glob_row = -1 integer(psb_ipk_), allocatable :: loc_to_glob(:), srt_l2g(:,:), vnl(:) type(psb_hash_type) :: hash contains diff --git a/base/modules/desc/psb_hash_map_mod.f90 b/base/modules/desc/psb_hash_map_mod.f90 index 68a8faa6..20472808 100644 --- a/base/modules/desc/psb_hash_map_mod.f90 +++ b/base/modules/desc/psb_hash_map_mod.f90 @@ -743,6 +743,9 @@ contains end subroutine hash_g2lv2_ins + ! + ! init from VL, with checks on input. + ! subroutine hash_init_vl(idxmap,ictxt,vl,info) use psb_penv_mod use psb_error_mod @@ -870,7 +873,9 @@ contains end subroutine hash_init_vg - + ! + ! init from VL, with no checks on input + ! subroutine hash_init_vlu(idxmap,ictxt,ntot,nl,vlu,info) use psb_penv_mod use psb_error_mod diff --git a/base/modules/desc/psb_list_map_mod.f90 b/base/modules/desc/psb_list_map_mod.f90 index 1080b42d..17a9e4c5 100644 --- a/base/modules/desc/psb_list_map_mod.f90 +++ b/base/modules/desc/psb_list_map_mod.f90 @@ -66,16 +66,31 @@ module psb_list_map_mod 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) :: ll2gs1 => list_ll2gs1 + procedure, pass(idxmap) :: ll2gs2 => list_ll2gs2 + procedure, pass(idxmap) :: ll2gv1 => list_ll2gv1 + procedure, pass(idxmap) :: ll2gv2 => list_ll2gv2 + + 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) :: lg2ls1 => list_lg2ls1 + procedure, pass(idxmap) :: lg2ls2 => list_lg2ls2 + procedure, pass(idxmap) :: lg2lv1 => list_lg2lv1 + procedure, pass(idxmap) :: lg2lv2 => list_lg2lv2 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 + procedure, pass(idxmap) :: lg2ls1_ins => list_lg2ls1_ins + procedure, pass(idxmap) :: lg2ls2_ins => list_lg2ls2_ins + procedure, pass(idxmap) :: lg2lv1_ins => list_lg2lv1_ins + procedure, pass(idxmap) :: lg2lv2_ins => list_lg2lv2_ins + end type psb_list_map private :: list_initvl, list_sizeof, list_asb, list_free,& @@ -231,6 +246,114 @@ contains end subroutine list_l2gv2 + subroutine list_ll2gs1(idx,idxmap,info,mask,owned) + implicit none + class(psb_list_map), intent(in) :: idxmap + integer(psb_lpk_), intent(inout) :: idx + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + integer(psb_lpk_) :: idxv(1) + info = 0 + if (present(mask)) then + if (.not.mask) return + end if + + idxv(1) = idx + call idxmap%l2gip(idxv,info,owned=owned) + idx = idxv(1) + + end subroutine list_ll2gs1 + + subroutine list_ll2gs2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_list_map), intent(in) :: idxmap + integer(psb_ipk_), intent(in) :: idxin + integer(psb_lpk_), intent(out) :: idxout + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + + idxout = idxin + call idxmap%l2gip(idxout,info,mask,owned) + + end subroutine list_ll2gs2 + + + subroutine list_ll2gv1(idx,idxmap,info,mask,owned) + implicit none + class(psb_list_map), intent(in) :: idxmap + integer(psb_lpk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer(psb_lpk_) :: 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_ll2gv1 + + subroutine list_ll2gv2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_list_map), intent(in) :: idxmap + integer(psb_ipk_), intent(in) :: idxin(:) + integer(psb_lpk_), intent(out) :: idxout(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer(psb_lpk_) :: is, im + + is = size(idxin) + im = min(is,size(idxout)) + idxout(1:im) = idxin(1:im) + call idxmap%l2gip(idxout(1:im),info,mask,owned) + if (is > im) info = -3 + + end subroutine list_ll2gv2 + + subroutine list_g2ls1(idx,idxmap,info,mask,owned) implicit none class(psb_list_map), intent(in) :: idxmap @@ -353,6 +476,141 @@ contains + subroutine list_lg2ls1(idx,idxmap,info,mask,owned) + implicit none + class(psb_list_map), intent(in) :: idxmap + integer(psb_lpk_), intent(inout) :: idx + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + integer(psb_lpk_) :: idxv(1) + info = 0 + + if (present(mask)) then + if (.not.mask) return + end if + + idxv(1) = idx + call idxmap%g2lip(idxv,info,owned=owned) + idx = idxv(1) + + end subroutine list_lg2ls1 + + subroutine list_lg2ls2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_list_map), intent(in) :: idxmap + integer(psb_lpk_), intent(in) :: idxin + integer(psb_ipk_), intent(out) :: idxout + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + integer(psb_lpk_) :: idxv(1) + + info = 0 + if (present(mask)) then + if (.not.mask) return + end if + + idxv = idxin + call idxmap%g2lip(idxv,info,owned=owned) + idxout = idxv(1) + + end subroutine list_lg2ls2 + + + subroutine list_lg2lv1(idx,idxmap,info,mask,owned) + use psb_sort_mod + implicit none + class(psb_list_map), intent(in) :: idxmap + integer(psb_lpk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer(psb_lpk_) :: i, 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_lg2lv1 + + subroutine list_lg2lv2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_list_map), intent(in) :: idxmap + integer(psb_lpk_), intent(in) :: idxin(:) + integer(psb_ipk_), intent(out) :: idxout(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer(psb_lpk_), allocatable :: idxv(:) + integer(psb_ipk_) :: is, im + + is = size(idxin) + im = min(is,size(idxout)) + allocate(idxv(im),stat=info) + if (info /= 0) then + info = -5 + return + end if + idxv(1:im) = idxin(1:im) + call idxmap%g2lip(idxv(1:im),info,mask,owned) + idxout(1:im) = idxv(1:im) + if (is > im) info = -3 + + end subroutine list_lg2lv2 + + + subroutine list_g2ls1_ins(idx,idxmap,info,mask,lidx) use psb_realloc_mod use psb_sort_mod @@ -555,6 +813,219 @@ contains end subroutine list_g2lv2_ins + + subroutine list_lg2ls1_ins(idx,idxmap,info,mask,lidx) + use psb_realloc_mod + use psb_sort_mod + implicit none + class(psb_list_map), intent(inout) :: idxmap + integer(psb_lpk_), intent(inout) :: idx + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask + integer(psb_ipk_), intent(in), optional :: lidx + + integer(psb_lpk_) :: idxv(1) + integer(psb_ipk_) :: lidxv(1) + + info = 0 + if (present(mask)) then + if (.not.mask) return + end if + idxv(1) = idx + if (present(lidx)) then + lidxv(1) = lidx + call idxmap%g2lip_ins(idxv,info,lidx=lidxv) + else + call idxmap%g2lip_ins(idxv,info) + end if + + idx = idxv(1) + + end subroutine list_lg2ls1_ins + + subroutine list_lg2ls2_ins(idxin,idxout,idxmap,info,mask,lidx) + implicit none + class(psb_list_map), intent(inout) :: idxmap + integer(psb_lpk_), intent(in) :: idxin + integer(psb_ipk_), intent(out) :: idxout + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask + integer(psb_ipk_), intent(in), optional :: lidx + + idxout = idxin + call idxmap%g2lip_ins(idxout,info,mask=mask,lidx=lidx) + + end subroutine list_lg2ls2_ins + + + subroutine list_lg2lv1_ins(idx,idxmap,info,mask,lidx) + use psb_realloc_mod + use psb_sort_mod + implicit none + class(psb_list_map), intent(inout) :: idxmap + integer(psb_lpk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask(:) + integer(psb_ipk_), intent(in), optional :: lidx(:) + + integer(psb_ipk_) :: ix, lix + integer(psb_lpk_) :: i, is + + info = 0 + is = size(idx) + + if (present(mask)) then + if (size(mask) < size(idx)) then + info = -1 + return + end if + end if + if (present(lidx)) then + if (size(lidx) < 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(lidx)) 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 = lidx(i) + call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) + if ((ix <= idxmap%local_rows).or.(info /= 0)) then + info = -4 + return + end if + idxmap%local_cols = max(ix,idxmap%local_cols) + 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 = lidx(i) + call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) + if ((ix <= idxmap%local_rows).or.(info /= 0)) then + info = -4 + return + end if + idxmap%local_cols = max(ix,idxmap%local_cols) + 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 if (.not.present(lidx)) 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=laddsz) + 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=laddsz) + 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 + end if + + else + idx = -1 + info = -1 + end if + + end subroutine list_lg2lv1_ins + + subroutine list_lg2lv2_ins(idxin,idxout,idxmap,info,mask,lidx) + implicit none + class(psb_list_map), intent(inout) :: idxmap + integer(psb_lpk_), intent(in) :: idxin(:) + integer(psb_ipk_), intent(out) :: idxout(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask(:) + integer(psb_ipk_), intent(in), optional :: lidx(:) + + integer(psb_lpk_) :: is, im + integer(psb_lpk_), allocatable :: idxv(:) + + is = size(idxin) + im = min(is,size(idxout)) + allocate(idxv(im),stat=info) + if (info /= 0) then + info = -5 + return + end if + + idxv(1:im) = idxin(1:im) + call idxmap%g2lip_ins(idxv(1:im),info,mask=mask,lidx=lidx) + idxout(1:im) = idxv(1:im) + if (is > im) info = -3 + + end subroutine list_lg2lv2_ins + + subroutine list_initvl(idxmap,ictxt,vl,info) diff --git a/util/psb_partidx_mod.F90 b/util/psb_partidx_mod.F90 index 433f87fb..544e78a1 100644 --- a/util/psb_partidx_mod.F90 +++ b/util/psb_partidx_mod.F90 @@ -47,9 +47,9 @@ module psb_partidx_mod end interface idx2ijk interface ijk2idx - module procedure ijk2idx3d, ijk2idxv, ijk2idx2d!,& -!!$ & ijk2idx3d, ijk2idxv, ijk2lidx2d,& -!!$ & lijk2lidx3d, lijk2lidxv, lijk2lidx2d + module procedure ijk2idx3d, ijk2idxv, ijk2idx2d,& + & ijk2lidx3d, ijk2lidxv, ijk2lidx2d,& + & lijk2lidx3d, lijk2lidxv, lijk2lidx2d end interface ijk2idx @@ -387,6 +387,130 @@ contains call ijk2idx(idx,[i,j],[nx,ny],base) end subroutine ijk2idx2d + subroutine ijk2lidxv(idx,coords,dims,base) + use psb_base_mod, only : psb_ipk_, psb_lpk_ + implicit none + integer(psb_ipk_), intent(in) :: coords(:),dims(:) + integer(psb_lpk_), intent(out) :: idx + integer(psb_ipk_), intent(in), optional :: base + + integer(psb_ipk_) :: base_, i, sz + if (present(base)) then + base_ = base + else + base_ = 1 + end if + sz = size(coords) + if (sz /= size(dims)) then + write(0,*) 'Error: size mismatch ',size(coords),size(dims) + idx = 0 + return + end if + + idx = coords(1) - base_ + do i=2, sz + idx = (idx * dims(i)) + coords(i) - base_ + end do + idx = idx + base_ + + end subroutine ijk2lidxv + ! + ! Given a triple (I,J,K) and the domain size (NX,NY,NZ) + ! compute the global index IDX + ! Optional argument: base 0 or 1, default 1 + ! + ! This mapping is equivalent to a loop nesting: + ! idx = base + ! do i=1,nx + ! do j=1,ny + ! do k=1,nz + ! ijk2idx(i,j,k) = idx + ! idx = idx + 1 + subroutine ijk2lidx3d(idx,i,j,k,nx,ny,nz,base) + use psb_base_mod, only : psb_ipk_, psb_lpk_ + implicit none + integer(psb_lpk_), intent(out) :: idx + integer(psb_ipk_), intent(in) :: i,j,k,nx,ny,nz + integer(psb_ipk_), intent(in), optional :: base + + ! idx = ((i-base_)*nz*ny + (j-base_)*nz + k - base_) + base_ + call ijk2idx(idx,[i,j,k],[nx,ny,nz],base) + end subroutine ijk2lidx3d + + subroutine ijk2lidx2d(idx,i,j,nx,ny,base) + use psb_base_mod, only : psb_ipk_, psb_lpk_ + implicit none + integer(psb_lpk_), intent(out) :: idx + integer(psb_ipk_), intent(in) :: i,j,nx,ny + integer(psb_ipk_), intent(in), optional :: base + + ! idx = ((i-base_)*ny + (j-base_) + base_ + call ijk2idx(idx,[i,j],[nx,ny],base) + end subroutine ijk2lidx2d + + + subroutine lijk2lidxv(idx,coords,dims,base) + use psb_base_mod, only : psb_ipk_, psb_lpk_ + implicit none + integer(psb_lpk_), intent(in) :: coords(:),dims(:) + integer(psb_lpk_), intent(out) :: idx + integer(psb_ipk_), intent(in), optional :: base + + integer(psb_lpk_) :: base_, i, sz + if (present(base)) then + base_ = base + else + base_ = 1 + end if + sz = size(coords) + if (sz /= size(dims)) then + write(0,*) 'Error: size mismatch ',size(coords),size(dims) + idx = 0 + return + end if + + idx = coords(1) - base_ + do i=2, sz + idx = (idx * dims(i)) + coords(i) - base_ + end do + idx = idx + base_ + + end subroutine lijk2lidxv + ! + ! Given a triple (I,J,K) and the domain size (NX,NY,NZ) + ! compute the global index IDX + ! Optional argument: base 0 or 1, default 1 + ! + ! This mapping is equivalent to a loop nesting: + ! idx = base + ! do i=1,nx + ! do j=1,ny + ! do k=1,nz + ! ijk2idx(i,j,k) = idx + ! idx = idx + 1 + subroutine lijk2lidx3d(idx,i,j,k,nx,ny,nz,base) + use psb_base_mod, only : psb_ipk_, psb_lpk_ + implicit none + integer(psb_lpk_), intent(out) :: idx + integer(psb_lpk_), intent(in) :: i,j,k,nx,ny,nz + integer(psb_ipk_), intent(in), optional :: base + + ! idx = ((i-base_)*nz*ny + (j-base_)*nz + k - base_) + base_ + call ijk2idx(idx,[i,j,k],[nx,ny,nz],base) + end subroutine lijk2lidx3d + + subroutine lijk2lidx2d(idx,i,j,nx,ny,base) + use psb_base_mod, only : psb_ipk_, psb_lpk_ + implicit none + integer(psb_lpk_), intent(out) :: idx + integer(psb_lpk_), intent(in) :: i,j,nx,ny + integer(psb_ipk_), intent(in), optional :: base + + ! idx = ((i-base_)*ny + (j-base_) + base_ + call ijk2idx(idx,[i,j],[nx,ny],base) + end subroutine lijk2lidx2d + + ! ! dist1Didx ! Given an index space [base : N-(1-base)] and