fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-20 04:42:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merged MixedI8 in new branch (to be later merged into development)

Browse Source
This commit is contained in:
Salvatore Filippone
2018-12-10 11:42:40 +00:00
parent 5371e39c16
commit 8d489f8ce2
921 changed files with 172036 additions and 57462 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/modules/desc/psb_desc_const_mod.f90
+7 -7
View File
@@ -35,7 +35,7 @@
! Auxiliary module for descriptor: constant values.
!
module psb_desc_const_mod
use psb_const_mod, only : psb_ipk_, psb_mpik_
use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_
!
! Communication, prolongation & restriction
!
@@ -101,11 +101,11 @@ module psb_desc_const_mod
!
! Constants for hashing into desc%hashv(:) and desc%glb_lc(:,:)
!
integer(psb_ipk_), parameter :: psb_hash_bits=16
integer(psb_ipk_), parameter :: psb_max_hash_bits=22
integer(psb_ipk_), parameter :: psb_hash_size=2**psb_hash_bits, psb_hash_mask=psb_hash_size-1
integer(psb_ipk_), parameter :: psb_hash_bits = 16
integer(psb_ipk_), parameter :: psb_max_hash_bits = 22
integer(psb_ipk_), parameter :: psb_hash_size = 2**psb_hash_bits, psb_hash_mask=psb_hash_size-1
integer(psb_ipk_), parameter :: psb_default_large_threshold=1*1024*1024
integer(psb_ipk_), parameter :: psb_hpnt_nentries_=7
integer(psb_ipk_), parameter :: psb_hpnt_nentries_ = 7
!
! Constants for desc_a handling
@@ -121,8 +121,8 @@ module psb_desc_const_mod
interface
subroutine psb_parts(glob_index,nrow,np,pv,nv)
import :: psb_ipk_
integer(psb_ipk_), intent (in) :: glob_index, nrow
import :: psb_ipk_, psb_lpk_
integer(psb_lpk_), intent (in) :: glob_index,nrow
integer(psb_ipk_), intent (in) :: np
integer(psb_ipk_), intent (out) :: nv, pv(*)
end subroutine psb_parts
base/modules/desc/psb_desc_mod.F90
+161 -46
View File
@@ -278,13 +278,27 @@ module psb_desc_mod
module procedure psb_cdtransfer
end interface psb_move_alloc
interface psb_free
module procedure psb_cdfree
end interface psb_free
interface psb_cd_set_large_threshold
module procedure psb_i_cd_set_large_threshold
end interface psb_cd_set_large_threshold
#if defined(IPK4) && defined(LPK8)
interface psb_cd_set_large_threshold
module procedure psb_l_cd_set_large_threshold
end interface psb_cd_set_large_threshold
#endif
private :: nullify_desc, cd_get_fmt,&
& cd_l2gs1, cd_l2gs2, cd_l2gv1, cd_l2gv2, cd_g2ls1,&
& cd_g2ls2, cd_g2lv1, cd_g2lv2, cd_g2ls1_ins,&
& cd_g2ls2_ins, cd_g2lv1_ins, cd_g2lv2_ins, cd_fnd_owner
integer(psb_ipk_), private, save :: cd_large_threshold=psb_default_large_threshold
integer(psb_lpk_), private, save :: cd_large_threshold=psb_default_large_threshold
contains
@@ -294,17 +308,17 @@ contains
!....Parameters...
class(psb_desc_type), intent(in) :: desc
integer(psb_long_int_k_) :: val
integer(psb_epk_) :: val
val = 0
val = val + psb_sizeof_int*psb_size(desc%halo_index)
val = val + psb_sizeof_int*psb_size(desc%ext_index)
val = val + psb_sizeof_int*psb_size(desc%bnd_elem)
val = val + psb_sizeof_int*psb_size(desc%ovrlap_index)
val = val + psb_sizeof_int*psb_size(desc%ovrlap_elem)
val = val + psb_sizeof_int*psb_size(desc%ovr_mst_idx)
val = val + psb_sizeof_int*psb_size(desc%lprm)
val = val + psb_sizeof_int*psb_size(desc%idx_space)
val = val + psb_sizeof_ip*psb_size(desc%halo_index)
val = val + psb_sizeof_ip*psb_size(desc%ext_index)
val = val + psb_sizeof_ip*psb_size(desc%bnd_elem)
val = val + psb_sizeof_ip*psb_size(desc%ovrlap_index)
val = val + psb_sizeof_ip*psb_size(desc%ovrlap_elem)
val = val + psb_sizeof_ip*psb_size(desc%ovr_mst_idx)
val = val + psb_sizeof_ip*psb_size(desc%lprm)
val = val + psb_sizeof_ip*psb_size(desc%idx_space)
if (allocated(desc%indxmap)) val = val + desc%indxmap%sizeof()
val = val + desc%v_halo_index%sizeof()
val = val + desc%v_ext_index%sizeof()
@@ -315,13 +329,21 @@ contains
subroutine psb_cd_set_large_threshold(ith)
subroutine psb_i_cd_set_large_threshold(ith)
implicit none
integer(psb_ipk_), intent(in) :: ith
if (ith > 0) then
cd_large_threshold = ith
end if
end subroutine psb_cd_set_large_threshold
end subroutine psb_i_cd_set_large_threshold
subroutine psb_l_cd_set_large_threshold(ith)
implicit none
integer(psb_lpk_), intent(in) :: ith
if (ith > 0) then
cd_large_threshold = ith
end if
end subroutine psb_l_cd_set_large_threshold
function psb_cd_get_large_threshold() result(val)
implicit none
@@ -333,7 +355,7 @@ contains
use psb_penv_mod
implicit none
integer(psb_ipk_), intent(in) :: m
integer(psb_lpk_), intent(in) :: m
logical :: val
!locals
val = (m > psb_cd_get_large_threshold())
@@ -344,7 +366,7 @@ contains
implicit none
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: m
integer(psb_lpk_), intent(in) :: m
logical :: val
!locals
integer(psb_ipk_) :: np,me
@@ -480,7 +502,7 @@ contains
function psb_cd_get_global_rows(desc) result(val)
implicit none
integer(psb_ipk_) :: val
integer(psb_lpk_) :: val
class(psb_desc_type), intent(in) :: desc
if (allocated(desc%indxmap)) then
@@ -493,7 +515,7 @@ contains
function psb_cd_get_global_cols(desc) result(val)
implicit none
integer(psb_ipk_) :: val
integer(psb_lpk_) :: val
class(psb_desc_type), intent(in) :: desc
if (allocated(desc%indxmap)) then
@@ -506,7 +528,7 @@ contains
function psb_cd_get_global_indices(desc,owned) result(val)
implicit none
integer(psb_ipk_), allocatable :: val(:)
integer(psb_lpk_), allocatable :: val(:)
class(psb_desc_type), intent(in) :: desc
logical, intent(in), optional :: owned
@@ -1078,7 +1100,6 @@ contains
Subroutine psb_cd_get_recv_idx(tmp,desc,data,info)
use psb_error_mod
use psb_penv_mod
use psb_realloc_mod
@@ -1090,8 +1111,8 @@ contains
! .. Local Scalars ..
integer(psb_ipk_) :: incnt, outcnt, j, np, me, ictxt, l_tmp,&
& idx, gidx, proc, n_elem_send, n_elem_recv
integer(psb_ipk_), pointer :: idxlist(:)
& idx, proc, n_elem_send, n_elem_recv
integer(psb_ipk_), pointer :: idxlist(:)
integer(psb_ipk_) :: debug_level, debug_unit, err_act
character(len=20) :: name
@@ -1139,7 +1160,7 @@ contains
Do j=0,n_elem_recv-1
idx = idxlist(incnt+psb_elem_recv_+j)
call psb_ensure_size((outcnt+3),tmp,info,pad=-ione)
call psb_ensure_size((outcnt+3),tmp,info,pad=-1_psb_ipk_)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size')
@@ -1162,6 +1183,100 @@ contains
return
end Subroutine psb_cd_get_recv_idx
Subroutine psb_cd_get_recv_idx_glob(tmp,desc,data,info)
use psb_error_mod
use psb_penv_mod
use psb_realloc_mod
Implicit None
integer(psb_lpk_), allocatable, intent(out) :: tmp(:)
integer(psb_ipk_), intent(in) :: data
Type(psb_desc_type), Intent(in), target :: desc
integer(psb_ipk_), intent(out) :: info
! .. Local Scalars ..
integer(psb_ipk_) :: incnt, outcnt, j, np, me, ictxt, l_tmp,&
& idx, proc, n_elem_send, n_elem_recv
integer(psb_ipk_), pointer :: idxlist(:)
integer(psb_lpk_) :: gidx
integer(psb_ipk_) :: debug_level, debug_unit, err_act
character(len=20) :: name
name = 'psb_cd_get_recv_idx'
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)
call psb_info(ictxt, me, np)
select case(data)
case(psb_comm_halo_)
idxlist => desc%halo_index
case(psb_comm_ovr_)
idxlist => desc%ovrlap_index
case(psb_comm_ext_)
idxlist => desc%ext_index
case(psb_comm_mov_)
idxlist => desc%ovr_mst_idx
write(psb_err_unit,*) 'Warning: unusual request getidx on ovr_mst_idx'
case default
info=psb_err_from_subroutine_
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)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
incnt = 1
outcnt = 1
tmp(:) = -1
Do While (idxlist(incnt) /= -1)
proc = idxlist(incnt+psb_proc_id_)
n_elem_recv = idxlist(incnt+psb_n_elem_recv_)
n_elem_send = idxlist(incnt+n_elem_recv+psb_n_elem_send_)
Do j=0,n_elem_recv-1
idx = idxlist(incnt+psb_elem_recv_+j)
call psb_ensure_size((outcnt+3),tmp,info,pad=-1_psb_lpk_)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size')
goto 9999
end if
call desc%indxmap%l2g(idx,gidx,info)
If (gidx < 0) then
info=-3
call psb_errpush(info,name)
goto 9999
endif
tmp(outcnt) = proc
tmp(outcnt+1) = 1
tmp(outcnt+2) = gidx
tmp(outcnt+3) = -1
outcnt = outcnt+3
end Do
incnt = incnt+n_elem_recv+n_elem_send+3
end Do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end Subroutine psb_cd_get_recv_idx_glob
subroutine psb_cd_cnv(desc, mold)
class(psb_desc_type), intent(inout), target :: desc
@@ -1179,7 +1294,7 @@ contains
use psb_error_mod
implicit none
class(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(inout) :: idx
integer(psb_lpk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
@@ -1190,7 +1305,7 @@ contains
call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then
call desc%indxmap%l2gs1(idx,info,mask=mask,owned=owned)
call desc%indxmap%l2gip(idx,info,mask=mask,owned=owned)
else
info = psb_err_invalid_cd_state_
end if
@@ -1214,7 +1329,7 @@ contains
implicit none
class(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout
integer(psb_lpk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
@@ -1227,7 +1342,7 @@ contains
call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then
call desc%indxmap%l2gs2(idxin,idxout,info,mask=mask,owned=owned)
call desc%indxmap%l2g(idxin,idxout,info,mask=mask,owned=owned)
else
info = psb_err_invalid_cd_state_
end if
@@ -1250,7 +1365,7 @@ contains
use psb_error_mod
implicit none
class(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
@@ -1262,7 +1377,7 @@ contains
call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then
call desc%indxmap%l2gv1(idx,info,mask=mask,owned=owned)
call desc%indxmap%l2gip(idx,info,mask=mask,owned=owned)
else
info = psb_err_invalid_cd_state_
end if
@@ -1285,7 +1400,7 @@ contains
implicit none
class(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:)
integer(psb_lpk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
@@ -1297,7 +1412,7 @@ contains
call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then
call desc%indxmap%l2gv2(idxin,idxout,info,mask=mask,owned=owned)
call desc%indxmap%l2g(idxin,idxout,info,mask=mask,owned=owned)
else
info = psb_err_invalid_cd_state_
end if
@@ -1320,7 +1435,7 @@ contains
use psb_error_mod
implicit none
class(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(inout) :: idx
integer(psb_lpk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
@@ -1332,7 +1447,7 @@ contains
call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then
call desc%indxmap%g2ls1(idx,info,mask=mask,owned=owned)
call desc%indxmap%g2lip(idx,info,mask=mask,owned=owned)
else
info = psb_err_invalid_cd_state_
end if
@@ -1354,7 +1469,7 @@ contains
use psb_error_mod
implicit none
class(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(in) :: idxin
integer(psb_lpk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
@@ -1368,7 +1483,7 @@ contains
call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then
call desc%indxmap%g2ls2(idxin,idxout,info,mask=mask,owned=owned)
call desc%indxmap%g2l(idxin,idxout,info,mask=mask,owned=owned)
else
info = psb_err_invalid_cd_state_
end if
@@ -1391,7 +1506,7 @@ contains
use psb_error_mod
implicit none
class(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
@@ -1403,7 +1518,7 @@ contains
call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then
call desc%indxmap%g2lv1(idx,info,mask=mask,owned=owned)
call desc%indxmap%g2lip(idx,info,mask=mask,owned=owned)
else
info = psb_err_invalid_cd_state_
end if
@@ -1425,7 +1540,7 @@ contains
use psb_error_mod
implicit none
class(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(in) :: idxin(:)
integer(psb_lpk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
@@ -1440,7 +1555,7 @@ contains
call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then
call desc%indxmap%g2lv2(idxin,idxout,info,mask=mask,owned=owned)
call desc%indxmap%g2l(idxin,idxout,info,mask=mask,owned=owned)
else
info = psb_err_invalid_cd_state_
end if
@@ -1464,7 +1579,7 @@ contains
use psb_error_mod
implicit none
class(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(inout) :: idx
integer(psb_lpk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
integer(psb_ipk_), intent(in), optional :: lidx
@@ -1476,7 +1591,7 @@ contains
call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then
call desc%indxmap%g2ls1_ins(idx,info,mask=mask,lidx=lidx)
call desc%indxmap%g2lip_ins(idx,info,mask=mask,lidx=lidx)
else
info = psb_err_invalid_cd_state_
end if
@@ -1498,7 +1613,7 @@ contains
use psb_error_mod
implicit none
class(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(in) :: idxin
integer(psb_lpk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
@@ -1513,7 +1628,7 @@ contains
call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then
call desc%indxmap%g2ls2_ins(idxin,idxout,info,mask=mask,lidx=lidx)
call desc%indxmap%g2l_ins(idxin,idxout,info,mask=mask,lidx=lidx)
else
info = psb_err_invalid_cd_state_
end if
@@ -1536,7 +1651,7 @@ contains
use psb_error_mod
implicit none
class(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:)
@@ -1550,7 +1665,7 @@ contains
call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then
call desc%indxmap%g2lv1_ins(idx,info,mask=mask,lidx=lidx)
call desc%indxmap%g2lip_ins(idx,info,mask=mask,lidx=lidx)
else
info = psb_err_invalid_cd_state_
end if
@@ -1572,7 +1687,7 @@ contains
use psb_error_mod
implicit none
class(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(in) :: idxin(:)
integer(psb_lpk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
@@ -1587,7 +1702,7 @@ contains
call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then
call desc%indxmap%g2lv2_ins(idxin,idxout,info,mask=mask,lidx=lidx)
call desc%indxmap%g2l_ins(idxin,idxout,info,mask=mask,lidx=lidx)
else
info = psb_err_invalid_cd_state_
end if
@@ -1609,7 +1724,7 @@ contains
subroutine cd_fnd_owner(idx,iprc,desc,info)
use psb_error_mod
implicit none
integer(psb_ipk_), intent(in) :: idx(:)
integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(out) :: info
base/modules/desc/psb_gen_block_map_mod.f90
+1113 -144
View File
File diff suppressed because it is too large Load Diff
base/modules/desc/psb_glist_map_mod.f90
+9 -8
View File
@@ -67,12 +67,12 @@ contains
function glist_sizeof(idxmap) result(val)
implicit none
class(psb_glist_map), intent(in) :: idxmap
integer(psb_long_int_k_) :: val
integer(psb_epk_) :: val
val = idxmap%psb_list_map%sizeof()
if (allocated(idxmap%vgp)) &
& val = val + size(idxmap%vgp)*psb_sizeof_int
& val = val + size(idxmap%vgp)*psb_sizeof_ip
end function glist_sizeof
@@ -96,12 +96,13 @@ contains
use psb_error_mod
implicit none
class(psb_glist_map), intent(inout) :: idxmap
integer(psb_mpik_), intent(in) :: ictxt
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: vg(:)
integer(psb_ipk_), intent(out) :: info
! To be implemented
integer(psb_mpik_) :: iam, np
integer(psb_ipk_) :: i, n, nl
integer(psb_mpk_) :: iam, np
integer(psb_ipk_) :: nl
integer(psb_lpk_) :: i, n
info = 0
@@ -153,12 +154,12 @@ contains
use psb_penv_mod
use psb_sort_mod
implicit none
integer(psb_ipk_), intent(in) :: idx(:)
integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_glist_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info
integer(psb_mpik_) :: ictxt, iam, np
integer(psb_ipk_) :: nv, i, ngp
integer(psb_mpk_) :: ictxt, iam, np
integer(psb_lpk_) :: nv, i, ngp
ictxt = idxmap%get_ctxt()
call psb_info(ictxt,iam,np)
base/modules/desc/psb_hash_map_mod.f90
+190 -123
View File
@@ -60,8 +60,9 @@ module psb_hash_map_mod
type, extends(psb_indx_map) :: psb_hash_map
integer(psb_ipk_) :: hashvsize, hashvmask
integer(psb_ipk_), allocatable :: hashv(:), glb_lc(:,:), loc_to_glob(:)
integer(psb_lpk_) :: hashvsize, hashvmask
integer(psb_ipk_), allocatable :: hashv(:)
integer(psb_lpk_), allocatable :: glb_lc(:,:), loc_to_glob(:)
type(psb_hash_type) :: hash
contains
@@ -78,20 +79,20 @@ module psb_hash_map_mod
procedure, nopass :: 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) :: ll2gs1 => hash_l2gs1
procedure, pass(idxmap) :: ll2gs2 => hash_l2gs2
procedure, pass(idxmap) :: ll2gv1 => hash_l2gv1
procedure, pass(idxmap) :: ll2gv2 => 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) :: lg2ls1 => hash_g2ls1
procedure, pass(idxmap) :: lg2ls2 => hash_g2ls2
procedure, pass(idxmap) :: lg2lv1 => hash_g2lv1
procedure, pass(idxmap) :: lg2lv2 => 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) :: lg2ls1_ins => hash_g2ls1_ins
procedure, pass(idxmap) :: lg2ls2_ins => hash_g2ls2_ins
procedure, pass(idxmap) :: lg2lv1_ins => hash_g2lv1_ins
procedure, pass(idxmap) :: lg2lv2_ins => hash_g2lv2_ins
procedure, pass(idxmap) :: hash_cpy
generic, public :: assignment(=) => hash_cpy
@@ -104,14 +105,14 @@ module psb_hash_map_mod
& 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
& hash_bld_g2l_map, hash_inner_cnvs2, hash_inner_cnvs1, &
& hash_inner_cnv2, hash_inner_cnv1, hash_row_extendable
integer(psb_ipk_), private :: laddsz=500
interface hash_inner_cnv
module procedure hash_inner_cnvs1, hash_inner_cnvs2,&
& hash_inner_cnv1, hash_inner_cnv2
module procedure hash_inner_cnvs2, hash_inner_cnv2,&
& hash_inner_cnvs1, hash_inner_cnv1
end interface hash_inner_cnv
private :: hash_inner_cnv
@@ -126,16 +127,16 @@ contains
function hash_sizeof(idxmap) result(val)
implicit none
class(psb_hash_map), intent(in) :: idxmap
integer(psb_long_int_k_) :: val
integer(psb_epk_) :: val
val = idxmap%psb_indx_map%sizeof()
val = val + 2 * psb_sizeof_int
val = val + 2 * psb_sizeof_ip
if (allocated(idxmap%hashv)) &
& val = val + size(idxmap%hashv)*psb_sizeof_int
& val = val + size(idxmap%hashv)*psb_sizeof_ip
if (allocated(idxmap%glb_lc)) &
& val = val + size(idxmap%glb_lc)*psb_sizeof_int
& val = val + size(idxmap%glb_lc)*psb_sizeof_lp
if (allocated(idxmap%loc_to_glob)) &
& val = val + size(idxmap%loc_to_glob)*psb_sizeof_int
& val = val + size(idxmap%loc_to_glob)*psb_sizeof_lp
val = val + psb_sizeof(idxmap%hash)
end function hash_sizeof
@@ -159,11 +160,11 @@ contains
subroutine hash_l2gs1(idx,idxmap,info,mask,owned)
implicit none
class(psb_hash_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx
integer(psb_lpk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
integer(psb_ipk_) :: idxv(1)
integer(psb_lpk_) :: idxv(1)
info = 0
if (present(mask)) then
if (.not.mask) return
@@ -179,13 +180,21 @@ contains
implicit none
class(psb_hash_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout
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)
integer(psb_lpk_) :: idxv(1)
info = 0
if (present(mask)) then
if (.not.mask) return
end if
idxv(1) = idxin
call idxmap%l2gip(idxv,info,owned=owned)
idxout = idxv(1)
end subroutine hash_l2gs2
@@ -193,7 +202,7 @@ contains
subroutine hash_l2gv1(idx,idxmap,info,mask,owned)
implicit none
class(psb_hash_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
@@ -249,7 +258,7 @@ contains
implicit none
class(psb_hash_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:)
integer(psb_lpk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
@@ -270,11 +279,11 @@ contains
subroutine hash_g2ls1(idx,idxmap,info,mask,owned)
implicit none
class(psb_hash_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx
integer(psb_lpk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
integer(psb_ipk_) :: idxv(1)
integer(psb_lpk_) :: idxv(1)
info = 0
if (present(mask)) then
@@ -290,14 +299,21 @@ contains
subroutine hash_g2ls2(idxin,idxout,idxmap,info,mask,owned)
implicit none
class(psb_hash_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin
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
idxout = idxin
call idxmap%g2lip(idxout,info,mask,owned)
if (present(mask)) then
if (.not.mask) return
end if
idxv(1) = idxin
call idxmap%g2lip(idxv,info,owned=owned)
idxout = idxv(1)
end subroutine hash_g2ls2
@@ -307,12 +323,13 @@ contains
use psb_sort_mod
implicit none
class(psb_hash_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_ipk_) :: i, is, mglob, ip, lip, nrow, ncol, nrm
integer(psb_mpik_) :: ictxt, iam, np
integer(psb_ipk_) :: i, lip, nrow, nrm, is
integer(psb_lpk_) :: ncol, ip, tlip, mglob
integer(psb_mpk_) :: ictxt, iam, np
logical :: owned_
info = 0
@@ -357,9 +374,12 @@ contains
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)
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,&
& idxmap%glb_lc,nrm)
if (lip < 0) then
call psb_hash_searchkey(ip,tlip,idxmap%hash,info)
lip = tlip
end if
if (owned_) then
if (lip<=nrow) then
idx(i) = lip
@@ -393,9 +413,12 @@ contains
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)
call hash_inner_cnv(ip,lip,idxmap%hashvmask,&
& idxmap%hashv,idxmap%glb_lc,nrm)
if (lip < 0) then
call psb_hash_searchkey(ip,tlip,idxmap%hash,info)
lip = tlip
end if
if (owned_) then
if (lip<=nrow) then
idx(i) = lip
@@ -419,20 +442,23 @@ contains
end subroutine hash_g2lv1
subroutine hash_g2lv2(idxin,idxout,idxmap,info,mask,owned)
use psb_realloc_mod
implicit none
class(psb_hash_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:)
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_ipk_) :: is, im
integer(psb_lpk_), allocatable :: tidx(:)
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%g2lip(idxout(1:im),info,mask,owned)
call psb_realloc(im,tidx,info)
tidx(1:im) = idxin(1:im)
call idxmap%g2lip(tidx(1:im),info,mask,owned)
idxout(1:im) = tidx(1:im)
if (is > im) then
write(0,*) 'g2lv2 err -3'
info = -3
@@ -447,12 +473,13 @@ contains
use psb_sort_mod
implicit none
class(psb_hash_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(inout) :: idx
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_) :: idxv(1), lidxv(1)
integer(psb_lpk_) :: idxv(1)
integer(psb_ipk_) :: lidxv(1)
info = 0
if (present(mask)) then
@@ -473,15 +500,28 @@ contains
subroutine hash_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx)
implicit none
class(psb_hash_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(in) :: idxin
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_) :: idxv(1)
integer(psb_ipk_) :: lidxv(1)
idxout = idxin
call idxmap%g2lip_ins(idxout,info,mask=mask,lidx=lidx)
info = 0
if (present(mask)) then
if (.not.mask) return
end if
idxv(1) = idxin
if (present(lidx)) then
lidxv(1) = lidx
call idxmap%g2lip_ins(idxv,info,lidx=lidxv)
else
call idxmap%g2lip_ins(idxv,info)
end if
idxout = idxv(1)
end subroutine hash_g2ls2_ins
@@ -493,13 +533,14 @@ contains
use psb_penv_mod
implicit none
class(psb_hash_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(inout) :: idx(:)
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_) :: i, is, mglob, ip, lip, nrow, ncol, &
& nxt, err_act
integer(psb_ipk_) :: i, is, lip, nrow, ncol, &
& err_act
integer(psb_lpk_) :: mglob, ip, nxt, tlip
integer(psb_ipk_) :: ictxt, me, np
character(len=20) :: name,ch_err
@@ -540,23 +581,24 @@ contains
idx(i) = -1
cycle
endif
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,ncol)
if (lip < 0) then
call hash_inner_cnv(ip,lip,idxmap%hashvmask,&
& idxmap%hashv,idxmap%glb_lc,ncol)
if (lip < 0) then
tlip = lip
nxt = lidx(i)
if (nxt <= nrow) then
idx(i) = -1
cycle
endif
call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info)
call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info)
if (info >=0) then
if (nxt == lip) then
if (nxt == tlip) then
ncol = max(ncol,nxt)
call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-ione,addsz=laddsz)
call psb_ensure_size(ncol,idxmap%loc_to_glob,info,&
& pad=-1_psb_lpk_,addsz=laddsz)
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,izero,izero,izero,izero/))
&a_err='psb_ensure_size',i_err=(/info/))
goto 9999
end if
idxmap%loc_to_glob(nxt) = ip
@@ -564,9 +606,8 @@ contains
endif
info = psb_success_
else
ch_err='SearchInsKeyVal'
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,izero,izero,izero,izero/))
& a_err='SearchInsKeyVal',i_err=(/info/))
goto 9999
end if
end if
@@ -586,25 +627,25 @@ contains
idx(i) = -1
cycle
endif
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,ncol)
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,&
& idxmap%glb_lc,ncol)
if (lip < 0) then
nxt = lidx(i)
if (nxt <= nrow) then
idx(i) = -1
cycle
endif
call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info)
call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info)
lip = tlip
if (info >=0) then
if (nxt == lip) then
ncol = max(nxt,ncol)
call psb_ensure_size(ncol,idxmap%loc_to_glob,info,&
& pad=-ione,addsz=laddsz)
call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-1_psb_lpk_,addsz=laddsz)
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,izero,izero,izero,izero/))
&a_err='psb_ensure_size',i_err=(/info/))
goto 9999
end if
idxmap%loc_to_glob(nxt) = ip
@@ -612,9 +653,8 @@ contains
endif
info = psb_success_
else
ch_err='SearchInsKeyVal'
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,izero,izero,izero,izero/))
& a_err='SearchInsKeyVal',i_err=(/info/))
goto 9999
end if
end if
@@ -636,19 +676,22 @@ contains
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)
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,&
& idxmap%glb_lc,ncol)
if (lip < 0) then
call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info)
lip = tlip
end if
if (info >=0) then
if (nxt == lip) then
ncol = nxt
call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-ione,addsz=laddsz)
call psb_ensure_size(ncol,idxmap%loc_to_glob,info,&
& pad=-1_psb_lpk_,addsz=laddsz)
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,izero,izero,izero,izero/))
& a_err='psb_ensure_size',i_err=(/info/))
goto 9999
end if
idxmap%loc_to_glob(nxt) = ip
@@ -656,9 +699,8 @@ contains
endif
info = psb_success_
else
ch_err='SearchInsKeyVal'
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,izero,izero,izero,izero/))
& a_err='SearchInsKeyVal',i_err=(/info/))
goto 9999
end if
idx(i) = lip
@@ -678,14 +720,18 @@ contains
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)
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,&
& idxmap%glb_lc,ncol)
if (lip < 0) then
call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info)
lip = tlip
end if
if (info >=0) then
if (nxt == lip) then
ncol = nxt
call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-ione,addsz=laddsz)
call psb_ensure_size(ncol,idxmap%loc_to_glob,info,&
& pad=-1_psb_lpk_,addsz=laddsz)
if (info /= psb_success_) then
info=1
ch_err='psb_ensure_size'
@@ -725,20 +771,23 @@ contains
end subroutine hash_g2lv1_ins
subroutine hash_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx)
use psb_realloc_mod
implicit none
class(psb_hash_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:)
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_), allocatable :: tidx(:)
integer(psb_ipk_) :: is, im
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%g2lip_ins(idxout(1:im),info,mask=mask,lidx=lidx)
call psb_realloc(im,tidx,info)
tidx(1:im) = idxin(1:im)
call idxmap%g2lip_ins(tidx(1:im),info,mask=mask,lidx=lidx)
idxout(1:im) = tidx(1:im)
if (is > im) then
write(0,*) 'g2lv2_ins err -3'
info = -3
@@ -756,13 +805,15 @@ contains
use psb_realloc_mod
implicit none
class(psb_hash_map), intent(inout) :: idxmap
integer(psb_mpik_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: vl(:)
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_lpk_), intent(in) :: vl(:)
integer(psb_ipk_), intent(out) :: info
! To be implemented
integer(psb_mpik_) :: iam, np
integer(psb_ipk_) :: i, nlu, nl, m, nrt,int_err(5)
integer(psb_ipk_), allocatable :: vlu(:), ix(:)
integer(psb_mpk_) :: iam, np
integer(psb_ipk_) :: i, nlu, nl, int_err(5)
integer(psb_lpk_) :: m, nrt
integer(psb_lpk_), allocatable :: vlu(:)
integer(psb_lpk_), allocatable :: ix(:)
character(len=20), parameter :: name='hash_map_init_vl'
info = 0
@@ -827,13 +878,14 @@ contains
use psb_error_mod
implicit none
class(psb_hash_map), intent(inout) :: idxmap
integer(psb_mpik_), intent(in) :: ictxt
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: vg(:)
integer(psb_ipk_), intent(out) :: info
! To be implemented
integer(psb_mpik_) :: iam, np
integer(psb_ipk_) :: i, j, nl, n, int_err(5)
integer(psb_ipk_), allocatable :: vlu(:)
integer(psb_mpk_) :: iam, np
integer(psb_ipk_) :: i, j, nl, int_err(5)
integer(psb_lpk_) :: n
integer(psb_lpk_), allocatable :: vlu(:)
info = 0
call psb_info(ictxt,iam,np)
@@ -886,11 +938,12 @@ contains
use psb_realloc_mod
implicit none
class(psb_hash_map), intent(inout) :: idxmap
integer(psb_mpik_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: vlu(:), nl, ntot
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_lpk_), intent(in) :: vlu(:), ntot
integer(psb_ipk_), intent(in) :: nl
integer(psb_ipk_), intent(out) :: info
! To be implemented
integer(psb_mpik_) :: iam, np
integer(psb_mpk_) :: iam, np
integer(psb_ipk_) :: i, j, lc2, nlu, m, nrt,int_err(5)
character(len=20), parameter :: name='hash_map_init_vlu'
@@ -943,9 +996,10 @@ contains
class(psb_hash_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(out) :: info
! To be implemented
integer(psb_mpik_) :: ictxt, iam, np
integer(psb_mpk_) :: ictxt, iam, np
integer(psb_ipk_) :: i, j, m, nl
integer(psb_ipk_) :: key, ih, nh, idx, nbits, hsize, hmask
integer(psb_ipk_) :: ih, nh, idx, nbits
integer(psb_lpk_) :: key, hsize, hmask
character(len=20), parameter :: name='hash_map_init_vlu'
info = 0
@@ -984,7 +1038,7 @@ contains
idxmap%hashvmask = hmask
if (info == psb_success_) &
& call psb_realloc(hsize+1,idxmap%hashv,info,lb=0_psb_ipk_)
& call psb_realloc(hsize+1,idxmap%hashv,info,lb=0_psb_lpk_)
if (info /= psb_success_) then
! !$ ch_err='psb_realloc'
! !$ call psb_errpush(info,name,a_err=ch_err)
@@ -1046,7 +1100,7 @@ contains
class(psb_hash_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(out) :: info
integer(psb_mpik_) :: ictxt, iam, np
integer(psb_mpk_) :: ictxt, iam, np
integer(psb_ipk_) :: nhal
info = 0
@@ -1081,11 +1135,13 @@ contains
subroutine hash_inner_cnvs1(x,hashmask,hashv,glb_lc,nrm)
integer(psb_ipk_), intent(in) :: hashmask,hashv(0:),glb_lc(:,:)
integer(psb_ipk_), intent(inout) :: x
implicit none
integer(psb_lpk_), intent(in) :: hashmask,glb_lc(:,:)
integer(psb_ipk_), intent(in) :: hashv(0:)
integer(psb_lpk_), intent(inout) :: x
integer(psb_ipk_), intent(in) :: nrm
integer(psb_ipk_) :: ih, key, idx,nh,tmp,lb,ub,lm
integer(psb_ipk_) :: idx,nh,tmp,lb,ub,lm
integer(psb_lpk_) :: key, ih
!
! When a large descriptor is assembled the indices
! are kept in a (hashed) list of ordered lists.
@@ -1128,11 +1184,13 @@ contains
end subroutine hash_inner_cnvs1
subroutine hash_inner_cnvs2(x,y,hashmask,hashv,glb_lc,nrm)
integer(psb_ipk_), intent(in) :: hashmask,hashv(0:),glb_lc(:,:)
integer(psb_ipk_), intent(in) :: x
implicit none
integer(psb_ipk_), intent(in) :: hashv(0:)
integer(psb_lpk_), intent(in) :: hashmask, x, glb_lc(:,:)
integer(psb_ipk_), intent(out) :: y
integer(psb_ipk_), intent(in) :: nrm
integer(psb_ipk_) :: ih, key, idx,nh,tmp,lb,ub,lm
integer(psb_ipk_) :: idx,nh,tmp,lb,ub,lm
integer(psb_lpk_) :: ih, key
!
! When a large descriptor is assembled the indices
! are kept in a (hashed) list of ordered lists.
@@ -1176,12 +1234,15 @@ contains
subroutine hash_inner_cnv1(n,x,hashmask,hashv,glb_lc,mask,nrm)
integer(psb_ipk_), intent(in) :: n,hashmask,hashv(0:),glb_lc(:,:)
implicit none
integer(psb_ipk_), intent(in) :: n, hashv(0:)
integer(psb_lpk_), intent(in) :: glb_lc(:,:),hashmask
logical, intent(in), optional :: mask(:)
integer(psb_ipk_), intent(in), optional :: nrm
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_ipk_) :: i, ih, key, idx,nh,tmp,lb,ub,lm
integer(psb_ipk_) :: i, nh,tmp,lb,ub,lm
integer(psb_lpk_) :: ih, key, idx
!
! When a large descriptor is assembled the indices
! are kept in a (hashed) list of ordered lists.
@@ -1267,13 +1328,16 @@ contains
end subroutine hash_inner_cnv1
subroutine hash_inner_cnv2(n,x,y,hashmask,hashv,glb_lc,mask,nrm)
integer(psb_ipk_), intent(in) :: n, hashmask,hashv(0:),glb_lc(:,:)
implicit none
integer(psb_ipk_), intent(in) :: n, hashv(0:)
integer(psb_lpk_), intent(in) :: hashmask,glb_lc(:,:)
logical, intent(in), optional :: mask(:)
integer(psb_ipk_), intent(in), optional :: nrm
integer(psb_ipk_), intent(in) :: x(:)
integer(psb_lpk_), intent(in) :: x(:)
integer(psb_ipk_), intent(out) :: y(:)
integer(psb_ipk_) :: i, ih, key, idx,nh,tmp,lb,ub,lm
integer(psb_ipk_) :: i, idx,nh,tmp,lb,ub,lm
integer(psb_lpk_) :: ih, key
!
! When a large descriptor is assembled the indices
! are kept in a (hashed) list of ordered lists.
@@ -1434,6 +1498,7 @@ contains
use psb_penv_mod
use psb_error_mod
use psb_realloc_mod
implicit none
class(psb_hash_map), intent(in) :: idxmap
type(psb_hash_map), intent(out) :: outmap
integer(psb_ipk_) :: info
@@ -1461,9 +1526,11 @@ contains
implicit none
class(psb_hash_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, nr,nc,k, nl, ntot
integer(psb_mpik_) :: ictxt, me, np
integer(psb_ipk_), allocatable :: idx(:),lidx(:)
integer(psb_ipk_) :: err_act, nr,nc,k, nl
integer(psb_lpk_) :: ntot
integer(psb_mpk_) :: ictxt, me, np
integer(psb_ipk_), allocatable :: lidx(:)
integer(psb_lpk_), allocatable :: idx(:)
character(len=20) :: name='hash_reinit'
logical, parameter :: debug=.false.
base/modules/desc/psb_hash_mod.F90
+578
View File
@@ -0,0 +1,578 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! 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.
!
!
!
!
module psb_hash_mod
use psb_const_mod
use psb_desc_const_mod
use psb_cbind_const_mod
!> \class psb_hash_mod
!! \brief Simple hash module for storing integer keys.
!!
!! This module implements a very simple minded hash table.
!! The hash is based on the idea of open addressing with double hashing;
!! the primary hash function h1(K) is simply the remainder modulo 2^N, while
!! the secondary hash function is 1 if H1(k) == 0, otherwise IOR((2^N-H1(k)),1)
!! (See Knuth: TAOCP, Vol. 3, sec. 6.4)
!!
!! These hash functions are not very smart; however they are very simple and fast.
!! The intended usage of this hash table is to store indices of halo points, which
!! are supposed to be few compared to the internal indices
!! (which are stored elsewhere).
!! Therefore, either the table has a very low occupancy, and this scheme will work,
!! or we have lots more to worry about in parallel performance than the efficiency
!! of this hashing scheme.
!!
!!
! For us a hash is a Nx2 table.
! Note: we are assuming that the keys are positive numbers.
! Allocatable scalars would be a nice solution...
!
type psb_hash_type
integer(psb_ipk_) :: nbits, hsize, hmask, nk
integer(psb_lpk_), allocatable :: table(:,:)
integer(psb_lpk_) :: nsrch, nacc
end type psb_hash_type
integer(psb_ipk_), parameter :: HashDuplicate = 123, HashOK=0, HashOutOfMemory=-512,&
& HashFreeEntry = -1, HashNotFound = -256
interface psb_hashval
#if defined(IPK4)
function psb_c_hashval_32(key) bind(c) result(res)
import psb_c_ipk
implicit none
integer(psb_c_ipk), value :: key
integer(psb_c_ipk) :: res
end function psb_c_hashval_32
#endif
#if defined(IPK4) && defined(LPK8)
function psb_c_hashval_64_32(key) bind(c) result(res)
import psb_c_ipk, psb_c_lpk
implicit none
integer(psb_c_lpk), value :: key
integer(psb_c_ipk) :: res
end function psb_c_hashval_64_32
#endif
#if defined(IPK8)
function psb_c_hashval_64(key) bind(c) result(res)
import psb_c_ipk
implicit none
integer(psb_c_ipk), value :: key
integer(psb_c_ipk) :: res
end function psb_c_hashval_64
#endif
end interface psb_hashval
interface psb_hash_init
module procedure psb_hash_init_lv, psb_hash_init_ln
end interface psb_hash_init
interface psb_sizeof
module procedure psb_sizeof_hash_type
end interface
interface psb_hash_searchinskey
module procedure psb_hash_lsearchinskey
end interface psb_hash_searchinskey
interface psb_hash_searchkey
module procedure psb_hash_lsearchkey
end interface psb_hash_searchkey
#if defined(IPK4) && defined(LPK8)
interface psb_hash_init
module procedure psb_hash_init_v, psb_hash_init_n
end interface
interface psb_hash_searchinskey
module procedure psb_hash_isearchinskey
end interface psb_hash_searchinskey
interface psb_hash_searchkey
module procedure psb_hash_isearchkey
end interface psb_hash_searchkey
#endif
interface psb_move_alloc
module procedure HashTransfer
end interface
interface psb_hash_copy
module procedure HashCopy
end interface
interface psb_free
module procedure HashFree
end interface
contains
function psb_Sizeof_hash_type(hash) result(val)
type(psb_hash_type) :: hash
integer(psb_epk_) :: val
val = 4*psb_sizeof_ip + 2*psb_sizeof_lp
if (allocated(hash%table)) &
& val = val + psb_sizeof_lp * size(hash%table)
end function psb_Sizeof_hash_type
function psb_hash_avg_acc(hash)
type(psb_hash_type), intent(in) :: hash
real(psb_dpk_) :: psb_hash_avg_acc
psb_hash_avg_acc = dble(hash%nacc)/dble(hash%nsrch)
end function psb_hash_avg_acc
subroutine HashFree(hashin,info)
use psb_realloc_mod
type(psb_hash_type) :: hashin
integer(psb_ipk_) :: info
info = psb_success_
if (allocated(hashin%table)) then
deallocate(hashin%table,stat=info)
end if
hashin%nbits = 0
hashin%hsize = 0
hashin%hmask = 0
hashin%nk = 0
end subroutine HashFree
subroutine HashTransfer(hashin,hashout,info)
use psb_realloc_mod
type(psb_hash_type) :: hashin
type(psb_hash_type) :: hashout
integer(psb_ipk_), intent(out) :: info
info = HashOk
hashout%nbits = hashin%nbits
hashout%hsize = hashin%hsize
hashout%hmask = hashin%hmask
hashout%nk = hashin%nk
hashout%nsrch = hashin%nsrch
hashout%nacc = hashin%nacc
call psb_move_alloc(hashin%table, hashout%table,info)
end subroutine HashTransfer
subroutine HashCopy(hashin,hashout,info)
use psb_realloc_mod
type(psb_hash_type) :: hashin
type(psb_hash_type) :: hashout
integer(psb_ipk_), intent(out) :: info
info = HashOk
hashout%nbits = hashin%nbits
hashout%hsize = hashin%hsize
hashout%hmask = hashin%hmask
hashout%nk = hashin%nk
hashout%nsrch = hashin%nsrch
hashout%nacc = hashin%nacc
call psb_safe_ab_cpy(hashin%table, hashout%table,info)
end subroutine HashCopy
subroutine CloneHashTable(hashin,hashout,info)
type(psb_hash_type), pointer :: hashin
type(psb_hash_type), pointer :: hashout
integer(psb_ipk_), intent(out) :: info
if (associated(hashout)) then
deallocate(hashout,stat=info)
!if (info /= psb_success_) return
end if
if (associated(hashin)) then
allocate(hashout,stat=info)
if (info /= psb_success_) return
call HashCopy(hashin,hashout,info)
end if
end subroutine CloneHashTable
subroutine psb_hash_init_v(v,hash,info)
integer(psb_ipk_), intent(in) :: v(:)
type(psb_hash_type), intent(out) :: hash
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i,j,nbits, nv
info = psb_success_
nv = size(v)
call psb_hash_init(nv,hash,info)
if (info /= psb_success_) return
do i=1,nv
call psb_hash_searchinskey(v(i),j,i,hash,info)
if ((j /= i).or.(info /= HashOK)) then
write(psb_err_unit,*) 'Error from hash_ins',i,v(i),j,info
info = HashNotFound
return
end if
end do
end subroutine psb_hash_init_v
subroutine psb_hash_init_lv(v,hash,info)
integer(psb_lpk_), intent(in) :: v(:)
type(psb_hash_type), intent(out) :: hash
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_) :: i,j, nv
info = psb_success_
nv = size(v)
call psb_hash_init(nv,hash,info)
if (info /= psb_success_) return
do i=1,nv
call psb_hash_searchinskey(v(i),j,i,hash,info)
if ((j /= i).or.(info /= HashOK)) then
write(psb_err_unit,*) 'Error from hash_ins',i,v(i),j,info
info = HashNotFound
return
end if
end do
end subroutine psb_hash_init_lv
subroutine psb_hash_init_n(nv,hash,info)
integer(psb_ipk_), intent(in) :: nv
type(psb_hash_type), intent(out) :: hash
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: hsize,nbits
info = psb_success_
nbits = psb_hash_bits
hsize = 2**nbits
!
! Figure out the smallest power of 2 bigger than NV
! Note: in our intended usage NV will be the size of the
! local index space, NOT the global index space.
!
do
if (hsize < 0) then
write(psb_err_unit,*) 'Error: hash size overflow ',hsize,nbits
info = -2
return
end if
if (hsize > nv) exit
nbits = nbits + 1
hsize = hsize * 2
end do
hash%nbits = nbits
hash%hsize = hsize
hash%hmask = hsize-1
hash%nsrch = 0
hash%nacc = 0
allocate(hash%table(0:hsize-1,2),stat=info)
if (info /= psb_success_) then
write(psb_err_unit,*) 'Error: memory allocation failure ',hsize
info = HashOutOfMemory
return
end if
hash%table = HashFreeEntry
hash%nk = 0
end subroutine psb_hash_init_n
subroutine psb_hash_init_ln(nv,hash,info)
integer(psb_lpk_), intent(in) :: nv
type(psb_hash_type), intent(out) :: hash
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: hsize,nbits
info = psb_success_
nbits = psb_hash_bits
hsize = 2**nbits
!
! Figure out the smallest power of 2 bigger than NV
! Note: in our intended usage NV will be the size of the
! local index space, NOT the global index space.
!
do
if (hsize < 0) then
write(psb_err_unit,*) 'Error: hash size overflow ',hsize,nbits
info = -2
return
end if
if (hsize > nv) exit
nbits = nbits + 1
hsize = hsize * 2
end do
hash%nbits = nbits
hash%hsize = hsize
hash%hmask = hsize-1
hash%nsrch = 0
hash%nacc = 0
allocate(hash%table(0:hsize-1,2),stat=info)
if (info /= psb_success_) then
write(psb_err_unit,*) 'Error: memory allocation failure ',hsize
info = HashOutOfMemory
return
end if
hash%table = HashFreeEntry
hash%nk = 0
end subroutine psb_hash_init_ln
subroutine psb_hash_realloc(hash,info)
type(psb_hash_type), intent(inout) :: hash
integer(psb_ipk_), intent(out) :: info
type(psb_hash_type) :: nhash
integer(psb_lpk_) :: key, val, nextval,i
info = HashOk
call psb_hash_init((hash%hsize+1),nhash,info)
if (info /= HashOk) then
info = HashOutOfMemory
return
endif
do i=0, hash%hsize-1
key = hash%table(i,1)
nextval = hash%table(i,2)
if (key /= HashFreeEntry) then
call psb_hash_searchinskey(key,val,nextval,nhash,info)
if (info /= psb_success_) then
info = HashOutOfMemory
return
end if
end if
end do
call HashTransfer(nhash,hash,info)
end subroutine psb_hash_realloc
recursive subroutine psb_hash_lsearchinskey(key,val,nextval,hash,info)
integer(psb_lpk_), intent(in) :: key,nextval
type(psb_hash_type) :: hash
integer(psb_lpk_), intent(out) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: hsize,hmask, hk, hd
info = HashOK
hsize = hash%hsize
hmask = hash%hmask
hk = iand(psb_hashval(key),hmask)
if (hk == 0) then
hd = 1
else
hd = hsize - hk
hd = ior(hd,1)
end if
if (.not.allocated(hash%table)) then
info = HashOutOfMemory
return
end if
hash%nsrch = hash%nsrch + 1
do
hash%nacc = hash%nacc + 1
if (hash%table(hk,1) == key) then
val = hash%table(hk,2)
info = HashDuplicate
return
end if
if (hash%table(hk,1) == HashFreeEntry) then
if (hash%nk == hash%hsize -1) then
!
! Note: because of the way we allocate things at CDALL
! time this is really unlikely; if we get here, we
! have at least as many halo indices as internals, which
! means we're already in trouble. But we try to keep going.
!
call psb_hash_realloc(hash,info)
if (info /= HashOk) then
info = HashOutOfMemory
return
else
call psb_hash_searchinskey(key,val,nextval,hash,info)
return
end if
else
hash%nk = hash%nk + 1
hash%table(hk,1) = key
hash%table(hk,2) = nextval
val = nextval
return
end if
end if
hk = hk - hd
if (hk < 0) hk = hk + hsize
end do
end subroutine psb_hash_lsearchinskey
recursive subroutine psb_hash_isearchinskey(key,val,nextval,hash,info)
integer(psb_ipk_), intent(in) :: key,nextval
type(psb_hash_type) :: hash
integer(psb_ipk_), intent(out) :: val, info
integer(psb_ipk_) :: hsize,hmask, hk, hd
info = HashOK
hsize = hash%hsize
hmask = hash%hmask
hk = iand(psb_hashval(key),hmask)
if (hk == 0) then
hd = 1
else
hd = hsize - hk
hd = ior(hd,1)
end if
if (.not.allocated(hash%table)) then
info = HashOutOfMemory
return
end if
hash%nsrch = hash%nsrch + 1
do
hash%nacc = hash%nacc + 1
if (hash%table(hk,1) == key) then
val = hash%table(hk,2)
info = HashDuplicate
return
end if
if (hash%table(hk,1) == HashFreeEntry) then
if (hash%nk == hash%hsize -1) then
!
! Note: because of the way we allocate things at CDALL
! time this is really unlikely; if we get here, we
! have at least as many halo indices as internals, which
! means we're already in trouble. But we try to keep going.
!
call psb_hash_realloc(hash,info)
if (info /= HashOk) then
info = HashOutOfMemory
return
else
call psb_hash_searchinskey(key,val,nextval,hash,info)
return
end if
else
hash%nk = hash%nk + 1
hash%table(hk,1) = key
hash%table(hk,2) = nextval
val = nextval
return
end if
end if
hk = hk - hd
if (hk < 0) hk = hk + hsize
end do
end subroutine psb_hash_isearchinskey
subroutine psb_hash_isearchkey(key,val,hash,info)
integer(psb_ipk_), intent(in) :: key
type(psb_hash_type) :: hash
integer(psb_ipk_), intent(out) :: val, info
integer(psb_ipk_) :: hsize,hmask, hk, hd
info = HashOK
if (.not.allocated(hash%table) ) then
val = HashFreeEntry
return
end if
hsize = hash%hsize
hmask = hash%hmask
hk = iand(psb_hashval(key),hmask)
if (hk == 0) then
hd = 1
else
hd = hsize - hk
hd = ior(hd,1)
end if
hash%nsrch = hash%nsrch + 1
do
hash%nacc = hash%nacc + 1
if (hash%table(hk,1) == key) then
val = hash%table(hk,2)
return
end if
if (hash%table(hk,1) == HashFreeEntry) then
val = HashFreeEntry
! !$ info = HashNotFound
return
end if
hk = hk - hd
if (hk < 0) hk = hk + hsize
end do
end subroutine psb_hash_isearchkey
subroutine psb_hash_lsearchkey(key,val,hash,info)
integer(psb_lpk_), intent(in) :: key
type(psb_hash_type) :: hash
integer(psb_lpk_), intent(out) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: hsize,hmask, hk, hd
info = HashOK
if (.not.allocated(hash%table) ) then
val = HashFreeEntry
return
end if
hsize = hash%hsize
hmask = hash%hmask
hk = iand(psb_hashval(key),hmask)
if (hk == 0) then
hd = 1
else
hd = hsize - hk
hd = ior(hd,1)
end if
hash%nsrch = hash%nsrch + 1
do
hash%nacc = hash%nacc + 1
if (hash%table(hk,1) == key) then
val = hash%table(hk,2)
return
end if
if (hash%table(hk,1) == HashFreeEntry) then
val = HashFreeEntry
! !$ info = HashNotFound
return
end if
hk = hk - hd
if (hk < 0) hk = hk + hsize
end do
end subroutine psb_hash_lsearchkey
end module psb_hash_mod
base/modules/desc/psb_hashval.c
+49
View File
@@ -0,0 +1,49 @@
#include <stdint.h>
/*
This is based on the djb2 hashing algorithm
see e.g. http://www.cse.yorku.ca/~oz/hash.html
*/
#define IVAL 5381
#define H32MASK 0x7FFFFFFF
#define H64MASK 0x7FFFFFFFFFFFFFFF
#define BMASK 0xFF
int32_t psb_c_hashval_32(int32_t inkey)
{
uint32_t key, val, i;
key = inkey;
val = IVAL;
for (i=0; i<4; i++) {
val = ((val<<5)+val)+(key & BMASK);
key >>= 8;
}
val &= H32MASK;
return(val);
}
int64_t psb_c_hashval_64(int64_t inkey)
{
uint64_t key, val, i;
key = inkey;
val = IVAL;
for (i=0; i<8; i++) {
val = ((val<<5)+val)+(key & BMASK);
key >>= 8;
}
val &= H64MASK;
return(val);
}
int32_t psb_c_hashval_64_32(int64_t inkey)
{
uint32_t key, val, i;
key = inkey;
val = IVAL;
for (i=0; i<8; i++) {
val = ((val<<5)+val)+(key & BMASK);
key >>= 8;
}
val &= H32MASK;
return(val);
}
base/modules/desc/psb_indx_map_mod.f90
+397 -49
View File
@@ -108,13 +108,13 @@ module psb_indx_map_mod
!> State of the map
integer(psb_ipk_) :: state = psb_desc_null_
!> Communication context
integer(psb_mpik_) :: ictxt = -1
integer(psb_mpk_) :: ictxt = -1
!> MPI communicator
integer(psb_mpik_) :: mpic = -1
integer(psb_mpk_) :: mpic = -1
!> Number of global rows
integer(psb_ipk_) :: global_rows = -1
integer(psb_lpk_) :: global_rows = -1
!> Number of global columns
integer(psb_ipk_) :: global_cols = -1
integer(psb_lpk_) :: global_cols = -1
!> Number of local rows
integer(psb_ipk_) :: local_rows = -1
!> Number of local columns
@@ -141,19 +141,26 @@ module psb_indx_map_mod
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) :: set_gri => base_set_gri
procedure, pass(idxmap) :: set_gci => base_set_gci
procedure, pass(idxmap) :: set_grl => base_set_grl
procedure, pass(idxmap) :: set_gcl => base_set_gcl
generic, public :: set_gr => set_grl
generic, public :: set_gc => set_gcl
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_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, nopass :: 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, nopass :: get_fmt => base_get_fmt
procedure, pass(idxmap) :: asb => base_asb
@@ -161,26 +168,44 @@ module psb_indx_map_mod
procedure, pass(idxmap) :: clone => base_clone
procedure, pass(idxmap) :: reinit => base_reinit
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 => l2gs2, l2gv2
generic, public :: l2gip => l2gs1, l2gv1
!!$ procedure, pass(idxmap) :: l2gs1 => base_l2gs1
!!$ procedure, pass(idxmap) :: l2gs2 => base_l2gs2
!!$ procedure, pass(idxmap) :: l2gv1 => base_l2gv1
!!$ procedure, pass(idxmap) :: l2gv2 => base_l2gv2
procedure, pass(idxmap) :: ll2gs1 => base_ll2gs1
procedure, pass(idxmap) :: ll2gs2 => base_ll2gs2
procedure, pass(idxmap) :: ll2gv1 => base_ll2gv1
procedure, pass(idxmap) :: ll2gv2 => base_ll2gv2
!!$ generic, public :: l2g => l2gs2, l2gv2
!!$ generic, public :: l2gip => l2gs1, l2gv1
generic, public :: l2g => ll2gs2, ll2gv2
generic, public :: l2gip => ll2gs1, ll2gv1
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 => g2ls2, g2lv2
generic, public :: g2lip => g2ls1, g2lv1
!!$ procedure, pass(idxmap) :: g2ls1 => base_g2ls1
!!$ procedure, pass(idxmap) :: g2ls2 => base_g2ls2
!!$ procedure, pass(idxmap) :: g2lv1 => base_g2lv1
!!$ procedure, pass(idxmap) :: g2lv2 => base_g2lv2
procedure, pass(idxmap) :: lg2ls1 => base_lg2ls1
procedure, pass(idxmap) :: lg2ls2 => base_lg2ls2
procedure, pass(idxmap) :: lg2lv1 => base_lg2lv1
procedure, pass(idxmap) :: lg2lv2 => base_lg2lv2
!!$ generic, public :: g2l => g2ls2, g2lv2
!!$ generic, public :: g2lip => g2ls1, g2lv1
generic, public :: g2l => lg2ls2, lg2lv2
generic, public :: g2lip => lg2ls1, lg2lv1
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 => g2ls2_ins, g2lv2_ins
generic, public :: g2lip_ins => g2ls1_ins, g2lv1_ins
!!$ 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
procedure, pass(idxmap) :: lg2ls1_ins => base_lg2ls1_ins
procedure, pass(idxmap) :: lg2ls2_ins => base_lg2ls2_ins
procedure, pass(idxmap) :: lg2lv1_ins => base_lg2lv1_ins
procedure, pass(idxmap) :: lg2lv2_ins => base_lg2lv2_ins
!!$ generic, public :: g2l_ins => g2ls2_ins, g2lv2_ins
!!$ generic, public :: g2lip_ins => g2ls1_ins, g2lv1_ins
generic, public :: g2l_ins => lg2ls2_ins, lg2lv2_ins
generic, public :: g2lip_ins => lg2ls1_ins, lg2lv1_ins
procedure, pass(idxmap) :: fnd_owner => psb_indx_map_fnd_owner
procedure, pass(idxmap) :: init_vl => base_init_vl
@@ -191,13 +216,17 @@ module psb_indx_map_mod
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_get_mpic, base_sizeof, base_set_null, &
& base_set_grl, base_set_gcl, &
& 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_g2ls1_ins, base_g2ls2_ins, base_g2lv1_ins, base_g2lv2_ins, &
& base_ll2gs1, base_ll2gs2, base_ll2gv1, base_ll2gv2,&
& base_lg2ls1, base_lg2ls2, base_lg2lv1, base_lg2lv2,&
& base_lg2ls1_ins, base_lg2ls2_ins, base_lg2lv1_ins,&
& base_lg2lv2_ins, base_init_vl, base_is_null,&
& base_row_extendable, base_clone, base_reinit
!> Function: psb_indx_map_fnd_owner
@@ -220,9 +249,9 @@ module psb_indx_map_mod
interface
subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
import :: psb_indx_map, psb_ipk_
import :: psb_indx_map, psb_ipk_, psb_lpk_
implicit none
integer(psb_ipk_), intent(in) :: idx(:)
integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_indx_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info
@@ -255,7 +284,7 @@ contains
function base_get_gr(idxmap) result(val)
implicit none
class(psb_indx_map), intent(in) :: idxmap
integer(psb_ipk_) :: val
integer(psb_lpk_) :: val
val = idxmap%global_rows
@@ -265,7 +294,7 @@ contains
function base_get_gc(idxmap) result(val)
implicit none
class(psb_indx_map), intent(in) :: idxmap
integer(psb_ipk_) :: val
integer(psb_lpk_) :: val
val = idxmap%global_cols
@@ -295,7 +324,7 @@ contains
function base_get_ctxt(idxmap) result(val)
implicit none
class(psb_indx_map), intent(in) :: idxmap
integer(psb_mpik_) :: val
integer(psb_mpk_) :: val
val = idxmap%ictxt
@@ -305,7 +334,7 @@ contains
function base_get_mpic(idxmap) result(val)
implicit none
class(psb_indx_map), intent(in) :: idxmap
integer(psb_mpik_) :: val
integer(psb_mpk_) :: val
val = idxmap%mpic
@@ -323,26 +352,42 @@ contains
subroutine base_set_ctxt(idxmap,val)
implicit none
class(psb_indx_map), intent(inout) :: idxmap
integer(psb_mpik_), intent(in) :: val
integer(psb_mpk_), intent(in) :: val
idxmap%ictxt = val
end subroutine base_set_ctxt
subroutine base_set_gr(idxmap,val)
subroutine base_set_gri(idxmap,val)
implicit none
class(psb_indx_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(in) :: val
idxmap%global_rows = val
end subroutine base_set_gr
end subroutine base_set_gri
subroutine base_set_gc(idxmap,val)
subroutine base_set_gci(idxmap,val)
implicit none
class(psb_indx_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(in) :: val
idxmap%global_cols = val
end subroutine base_set_gc
end subroutine base_set_gci
subroutine base_set_grl(idxmap,val)
implicit none
class(psb_indx_map), intent(inout) :: idxmap
integer(psb_lpk_), intent(in) :: val
idxmap%global_rows = val
end subroutine base_set_grl
subroutine base_set_gcl(idxmap,val)
implicit none
class(psb_indx_map), intent(inout) :: idxmap
integer(psb_lpk_), intent(in) :: val
idxmap%global_cols = val
end subroutine base_set_gcl
subroutine base_set_lr(idxmap,val)
implicit none
@@ -363,7 +408,7 @@ contains
subroutine base_set_mpic(idxmap,val)
implicit none
class(psb_indx_map), intent(inout) :: idxmap
integer(psb_mpik_), intent(in) :: val
integer(psb_mpk_), intent(in) :: val
idxmap%mpic = val
end subroutine base_set_mpic
@@ -434,9 +479,9 @@ contains
function base_sizeof(idxmap) result(val)
implicit none
class(psb_indx_map), intent(in) :: idxmap
integer(psb_long_int_k_) :: val
integer(psb_epk_) :: val
val = 8 * psb_sizeof_int
val = 8 * psb_sizeof_ip
end function base_sizeof
@@ -541,6 +586,107 @@ contains
end subroutine base_l2gv2
!>
!! \memberof psb_indx_map
!! \brief Local to global, scalar, in place
subroutine base_ll2gs1(idx,idxmap,info,mask,owned)
use psb_error_mod
implicit none
class(psb_indx_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_ipk_) :: err_act
character(len=20) :: name='base_ll2g'
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())
call psb_error_handler(err_act)
return
end subroutine base_ll2gs1
subroutine base_ll2gs2(idxin,idxout,idxmap,info,mask,owned)
use psb_error_mod
implicit none
class(psb_indx_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_ipk_) :: err_act
character(len=20) :: name='base_ll2g'
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())
call psb_error_handler(err_act)
end subroutine base_ll2gs2
subroutine base_ll2gv1(idx,idxmap,info,mask,owned)
use psb_error_mod
implicit none
class(psb_indx_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_ipk_) :: err_act
character(len=20) :: name='base_ll2g'
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())
call psb_error_handler(err_act)
return
end subroutine base_ll2gv1
subroutine base_ll2gv2(idxin,idxout,idxmap,info,mask,owned)
use psb_error_mod
implicit none
class(psb_indx_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_ipk_) :: err_act
character(len=20) :: name='base_ll2g'
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())
call psb_error_handler(err_act)
return
end subroutine base_ll2gv2
subroutine base_g2ls1(idx,idxmap,info,mask,owned)
use psb_error_mod
@@ -644,6 +790,106 @@ contains
end subroutine base_g2lv2
subroutine base_lg2ls1(idx,idxmap,info,mask,owned)
use psb_error_mod
implicit none
class(psb_indx_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_ipk_) :: err_act
character(len=20) :: name='base_lg2l'
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())
call psb_error_handler(err_act)
return
end subroutine base_lg2ls1
subroutine base_lg2ls2(idxin,idxout,idxmap,info,mask,owned)
use psb_error_mod
implicit none
class(psb_indx_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_ipk_) :: err_act
character(len=20) :: name='base_lg2l'
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())
call psb_error_handler(err_act)
return
end subroutine base_lg2ls2
subroutine base_lg2lv1(idx,idxmap,info,mask,owned)
use psb_error_mod
implicit none
class(psb_indx_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_ipk_) :: err_act
character(len=20) :: name='base_lg2l'
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())
call psb_error_handler(err_act)
return
end subroutine base_lg2lv1
subroutine base_lg2lv2(idxin,idxout,idxmap,info,mask,owned)
use psb_error_mod
implicit none
class(psb_indx_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_ipk_) :: err_act
character(len=20) :: name='base_lg2l'
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())
call psb_error_handler(err_act)
return
end subroutine base_lg2lv2
subroutine base_g2ls1_ins(idx,idxmap,info,mask, lidx)
@@ -749,6 +995,108 @@ contains
end subroutine base_g2lv2_ins
subroutine base_lg2ls1_ins(idx,idxmap,info,mask, lidx)
use psb_error_mod
implicit none
class(psb_indx_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_) :: err_act
character(len=20) :: name='base_lg2l_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())
call psb_error_handler(err_act)
return
end subroutine base_lg2ls1_ins
subroutine base_lg2ls2_ins(idxin,idxout,idxmap,info,mask, lidx)
use psb_error_mod
implicit none
class(psb_indx_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_ipk_) :: err_act
character(len=20) :: name='base_lg2l_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())
call psb_error_handler(err_act)
return
end subroutine base_lg2ls2_ins
subroutine base_lg2lv1_ins(idx,idxmap,info,mask, lidx)
use psb_error_mod
implicit none
class(psb_indx_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_) :: err_act
character(len=20) :: name='base_lg2l_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())
call psb_error_handler(err_act)
return
end subroutine base_lg2lv1_ins
subroutine base_lg2lv2_ins(idxin,idxout,idxmap,info,mask,lidx)
use psb_error_mod
implicit none
class(psb_indx_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_ipk_) :: err_act
character(len=20) :: name='base_lg2l_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())
call psb_error_handler(err_act)
return
end subroutine base_lg2lv2_ins
subroutine base_asb(idxmap,info)
use psb_error_mod
implicit none
@@ -808,8 +1156,8 @@ contains
use psb_error_mod
implicit none
class(psb_indx_map), intent(inout) :: idxmap
integer(psb_mpik_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: vl(:)
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_lpk_), intent(in) :: vl(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=20) :: name='base_init_vl'
base/modules/desc/psb_list_map_mod.f90
+596 -77
View File
@@ -46,9 +46,10 @@ module psb_list_map_mod
type, extends(psb_indx_map) :: psb_list_map
integer(psb_ipk_) :: pnt_h = -1
integer(psb_ipk_), allocatable :: loc_to_glob(:), glob_to_loc(:)
integer(psb_lpk_), allocatable :: loc_to_glob(:)
integer(psb_ipk_), allocatable :: glob_to_loc(:)
contains
procedure, pass(idxmap) :: init_vl => list_initvl
procedure, pass(idxmap) :: init_vl => list_initlvl
procedure, pass(idxmap) :: sizeof => list_sizeof
procedure, pass(idxmap) :: asb => list_asb
@@ -58,20 +59,35 @@ module psb_list_map_mod
procedure, nopass :: get_fmt => list_get_fmt
procedure, nopass :: 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) :: 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) :: 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_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) :: 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
@@ -94,14 +110,14 @@ contains
function list_sizeof(idxmap) result(val)
implicit none
class(psb_list_map), intent(in) :: idxmap
integer(psb_long_int_k_) :: val
integer(psb_epk_) :: val
val = idxmap%psb_indx_map%sizeof()
if (allocated(idxmap%loc_to_glob)) &
& val = val + size(idxmap%loc_to_glob)*psb_sizeof_int
& val = val + size(idxmap%loc_to_glob)*psb_sizeof_ip
if (allocated(idxmap%glob_to_loc)) &
& val = val + size(idxmap%glob_to_loc)*psb_sizeof_int
& val = val + size(idxmap%glob_to_loc)*psb_sizeof_ip
end function list_sizeof
@@ -120,14 +136,122 @@ contains
end subroutine list_free
subroutine list_l2gs1(idx,idxmap,info,mask,owned)
!!$ subroutine list_l2gs1(idx,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_list_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(inout) :: idx
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask
!!$ logical, intent(in), optional :: owned
!!$ integer(psb_ipk_) :: 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_l2gs1
!!$
!!$ subroutine list_l2gs2(idxin,idxout,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_list_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), 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
!!$
!!$ idxout = idxin
!!$ call idxmap%l2gip(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(psb_ipk_), intent(inout) :: idx(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask(:)
!!$ logical, intent(in), optional :: owned
!!$ integer(psb_ipk_) :: 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(psb_ipk_), 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_ipk_) :: 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_l2gv2
!!$
subroutine list_ll2gs1(idx,idxmap,info,mask,owned)
implicit none
class(psb_list_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx
integer(psb_lpk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
integer(psb_ipk_) :: idxv(1)
integer(psb_lpk_) :: idxv(1)
info = 0
if (present(mask)) then
if (.not.mask) return
@@ -137,13 +261,13 @@ contains
call idxmap%l2gip(idxv,info,owned=owned)
idx = idxv(1)
end subroutine list_l2gs1
end subroutine list_ll2gs1
subroutine list_l2gs2(idxin,idxout,idxmap,info,mask,owned)
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_ipk_), intent(out) :: idxout
integer(psb_lpk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
@@ -151,17 +275,17 @@ contains
idxout = idxin
call idxmap%l2gip(idxout,info,mask,owned)
end subroutine list_l2gs2
end subroutine list_ll2gs2
subroutine list_l2gv1(idx,idxmap,info,mask,owned)
subroutine list_ll2gv1(idx,idxmap,info,mask,owned)
implicit none
class(psb_list_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_ipk_) :: i
integer(psb_lpk_) :: i
logical :: owned_
info = 0
@@ -207,17 +331,17 @@ contains
end if
end subroutine list_l2gv1
end subroutine list_ll2gv1
subroutine list_l2gv2(idxin,idxout,idxmap,info,mask,owned)
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_ipk_), intent(out) :: idxout(:)
integer(psb_lpk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_ipk_) :: is, im
integer(psb_lpk_) :: is, im
is = size(idxin)
im = min(is,size(idxout))
@@ -225,17 +349,139 @@ contains
call idxmap%l2gip(idxout(1:im),info,mask,owned)
if (is > im) info = -3
end subroutine list_l2gv2
end subroutine list_ll2gv2
!!$
!!$ subroutine list_g2ls1(idx,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_list_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(inout) :: idx
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask
!!$ logical, intent(in), optional :: owned
!!$ integer(psb_ipk_) :: 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_g2ls1
!!$
!!$ subroutine list_g2ls2(idxin,idxout,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_list_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), 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
!!$
!!$ idxout = idxin
!!$ call idxmap%g2lip(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(psb_ipk_), intent(inout) :: idx(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask(:)
!!$ logical, intent(in), optional :: owned
!!$ integer(psb_ipk_) :: 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_g2lv1
!!$
!!$ subroutine list_g2lv2(idxin,idxout,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_list_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), 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_ipk_) :: is, im
!!$
!!$ is = size(idxin)
!!$ im = min(is,size(idxout))
!!$ idxout(1:im) = idxin(1:im)
!!$ call idxmap%g2lip(idxout(1:im),info,mask,owned)
!!$ if (is > im) info = -3
!!$
!!$ end subroutine list_g2lv2
subroutine list_g2ls1(idx,idxmap,info,mask,owned)
subroutine list_lg2ls1(idx,idxmap,info,mask,owned)
implicit none
class(psb_list_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx
integer(psb_lpk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
integer(psb_ipk_) :: idxv(1)
integer(psb_lpk_) :: idxv(1)
info = 0
if (present(mask)) then
@@ -246,32 +492,39 @@ contains
call idxmap%g2lip(idxv,info,owned=owned)
idx = idxv(1)
end subroutine list_g2ls1
end subroutine list_lg2ls1
subroutine list_g2ls2(idxin,idxout,idxmap,info,mask,owned)
subroutine list_lg2ls2(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(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
idxout = idxin
call idxmap%g2lip(idxout,info,mask,owned)
integer(psb_lpk_) :: idxv(1)
end subroutine list_g2ls2
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_g2lv1(idx,idxmap,info,mask,owned)
subroutine list_lg2lv1(idx,idxmap,info,mask,owned)
use psb_sort_mod
implicit none
class(psb_list_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_ipk_) :: i, is, ix
integer(psb_lpk_) :: i, is, ix
logical :: owned_
info = 0
@@ -327,40 +580,249 @@ contains
end if
end subroutine list_g2lv1
end subroutine list_lg2lv1
subroutine list_g2lv2(idxin,idxout,idxmap,info,mask,owned)
subroutine list_lg2lv2(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(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))
idxout(1:im) = idxin(1:im)
call idxmap%g2lip(idxout(1:im),info,mask,owned)
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_g2lv2
end subroutine list_lg2lv2
!!$ subroutine list_g2ls1_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_ipk_), intent(inout) :: idx
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask
!!$ integer(psb_ipk_), intent(in), optional :: lidx
!!$
!!$ integer(psb_ipk_) :: idxv(1), 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_g2ls1_ins
!!$
!!$ subroutine list_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx)
!!$ implicit none
!!$ class(psb_list_map), intent(inout) :: idxmap
!!$ integer(psb_ipk_), 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_g2ls2_ins
!!$
!!$
!!$ subroutine list_g2lv1_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_ipk_), intent(inout) :: idx(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask(:)
!!$ integer(psb_ipk_), intent(in), optional :: lidx(:)
!!$
!!$ integer(psb_ipk_) :: i, is, ix, lix
!!$
!!$ 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_g2lv1_ins
!!$
!!$ subroutine list_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx)
!!$ implicit none
!!$ class(psb_list_map), intent(inout) :: idxmap
!!$ integer(psb_ipk_), 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_ipk_) :: is, im
!!$
!!$ is = size(idxin)
!!$ im = min(is,size(idxout))
!!$ idxout(1:im) = idxin(1:im)
!!$ call idxmap%g2lip_ins(idxout(1:im),info,mask=mask,lidx=lidx)
!!$ if (is > im) info = -3
!!$
!!$ end subroutine list_g2lv2_ins
!!$
subroutine list_g2ls1_ins(idx,idxmap,info,mask,lidx)
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_ipk_), intent(inout) :: idx
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_) :: idxv(1), lidxv(1)
integer(psb_lpk_) :: idxv(1)
integer(psb_ipk_) :: lidxv(1)
info = 0
if (present(mask)) then
@@ -376,34 +838,49 @@ contains
idx = idxv(1)
end subroutine list_g2ls1_ins
end subroutine list_lg2ls1_ins
subroutine list_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx)
subroutine list_lg2ls2_ins(idxin,idxout,idxmap,info,mask,lidx)
implicit none
class(psb_list_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(in) :: idxin
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)
integer(psb_lpk_) :: idxv(1)
integer(psb_ipk_) :: lidxv(1)
info = 0
if (present(mask)) then
if (.not.mask) return
end if
idxv(1) = idxin
if (present(lidx)) then
lidxv(1) = lidx
call idxmap%g2lip_ins(idxv,info,lidx=lidxv)
else
call idxmap%g2lip_ins(idxv,info)
end if
idxout = idxv(1)
end subroutine list_g2ls2_ins
end subroutine list_lg2ls2_ins
subroutine list_g2lv1_ins(idx,idxmap,info,mask,lidx)
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_ipk_), intent(inout) :: idx(:)
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_) :: i, is, ix, lix
integer(psb_ipk_) :: ix, lix
integer(psb_lpk_) :: i, is
info = 0
is = size(idx)
@@ -530,26 +1007,34 @@ contains
info = -1
end if
end subroutine list_g2lv1_ins
end subroutine list_lg2lv1_ins
subroutine list_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx)
subroutine list_lg2lv2_ins(idxin,idxout,idxmap,info,mask,lidx)
implicit none
class(psb_list_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:)
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_ipk_) :: is, im
integer(psb_lpk_) :: is, im
integer(psb_lpk_), allocatable :: idxv(:)
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%g2lip_ins(idxout(1:im),info,mask=mask,lidx=lidx)
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_g2lv2_ins
end subroutine list_lg2lv2_ins
@@ -559,12 +1044,46 @@ contains
use psb_error_mod
implicit none
class(psb_list_map), intent(inout) :: idxmap
integer(psb_mpik_), intent(in) :: ictxt
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: vl(:)
integer(psb_ipk_), intent(out) :: info
! To be implemented
integer(psb_ipk_) :: i, ix, nl, n, nrt
integer(psb_mpik_) :: iam, np
integer(psb_lpk_) :: nl
integer(psb_lpk_), allocatable :: lvl(:)
integer(psb_mpk_) :: iam, np
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)
allocate(lvl(nl),stat=info)
if (info /= 0) then
info = -1
return
end if
lvl(1:nl) = vl(1:nl)
call idxmap%init_vl(ictxt,lvl,info)
end subroutine list_initvl
subroutine list_initlvl(idxmap,ictxt,vl,info)
use psb_penv_mod
use psb_error_mod
implicit none
class(psb_list_map), intent(inout) :: idxmap
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_lpk_), intent(in) :: vl(:)
integer(psb_ipk_), intent(out) :: info
! To be implemented
integer(psb_lpk_) :: i, ix, nl, n, nrt
integer(psb_mpk_) :: iam, np
info = 0
call psb_info(ictxt,iam,np)
@@ -615,7 +1134,7 @@ contains
idxmap%local_cols = nl
call idxmap%set_state(psb_desc_bld_)
end subroutine list_initvl
end subroutine list_initlvl
subroutine list_asb(idxmap,info)
@@ -628,7 +1147,7 @@ contains
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: nhal
integer(psb_mpik_) :: ictxt, iam, np
integer(psb_mpk_) :: ictxt, iam, np
info = 0
ictxt = idxmap%get_ctxt()
base/modules/desc/psb_repl_map_mod.f90
+79 -49
View File
@@ -58,20 +58,20 @@ module psb_repl_map_mod
procedure, pass(idxmap) :: reinit => repl_reinit
procedure, nopass :: 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) :: ll2gs1 => repl_l2gs1
procedure, pass(idxmap) :: ll2gs2 => repl_l2gs2
procedure, pass(idxmap) :: ll2gv1 => repl_l2gv1
procedure, pass(idxmap) :: ll2gv2 => 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) :: lg2ls1 => repl_g2ls1
procedure, pass(idxmap) :: lg2ls2 => repl_g2ls2
procedure, pass(idxmap) :: lg2lv1 => repl_g2lv1
procedure, pass(idxmap) :: lg2lv2 => 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) :: lg2ls1_ins => repl_g2ls1_ins
procedure, pass(idxmap) :: lg2ls2_ins => repl_g2ls2_ins
procedure, pass(idxmap) :: lg2lv1_ins => repl_g2lv1_ins
procedure, pass(idxmap) :: lg2lv2_ins => repl_g2lv2_ins
procedure, pass(idxmap) :: fnd_owner => repl_fnd_owner
@@ -96,7 +96,7 @@ contains
function repl_sizeof(idxmap) result(val)
implicit none
class(psb_repl_map), intent(in) :: idxmap
integer(psb_long_int_k_) :: val
integer(psb_epk_) :: val
val = idxmap%psb_indx_map%sizeof()
@@ -107,11 +107,11 @@ contains
subroutine repl_l2gs1(idx,idxmap,info,mask,owned)
implicit none
class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx
integer(psb_lpk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
integer(psb_ipk_) :: idxv(1)
integer(psb_lpk_) :: idxv(1)
info = 0
if (present(mask)) then
if (.not.mask) return
@@ -127,13 +127,20 @@ contains
implicit none
class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout
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)
integer(psb_lpk_) :: idxv(1)
info = 0
if (present(mask)) then
if (.not.mask) return
end if
idxv(1) = idxin
call idxmap%l2gip(idxv,info,owned=owned)
idxout = idxv(1)
end subroutine repl_l2gs2
@@ -141,11 +148,11 @@ contains
subroutine repl_l2gv1(idx,idxmap,info,mask,owned)
implicit none
class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_ipk_) :: i
integer(psb_lpk_) :: i
logical :: owned_
info = 0
@@ -191,12 +198,12 @@ contains
implicit none
class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:)
integer(psb_lpk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_ipk_) :: is, im
integer(psb_ipk_) :: i
integer(psb_lpk_) :: is, im
integer(psb_lpk_) :: i
logical :: owned_
info = 0
@@ -247,11 +254,11 @@ contains
subroutine repl_g2ls1(idx,idxmap,info,mask,owned)
implicit none
class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx
integer(psb_lpk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
integer(psb_ipk_) :: idxv(1)
integer(psb_lpk_) :: idxv(1)
info = 0
if (present(mask)) then
@@ -267,26 +274,35 @@ contains
subroutine repl_g2ls2(idxin,idxout,idxmap,info,mask,owned)
implicit none
class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin
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
idxout = idxin
call idxmap%g2lip(idxout,info,mask,owned)
integer(psb_lpk_) :: idxv(1)
info = 0
if (present(mask)) then
if (.not.mask) return
end if
end subroutine repl_g2ls2
idxv(1) = idxin
call idxmap%g2lip(idxv,info,owned=owned)
idxout = idxv(1)
end subroutine repl_g2ls2
subroutine repl_g2lv1(idx,idxmap,info,mask,owned)
implicit none
class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_ipk_) :: i, is
integer(psb_lpk_) :: i, is
logical :: owned_
info = 0
@@ -363,13 +379,13 @@ contains
subroutine repl_g2lv2(idxin,idxout,idxmap,info,mask,owned)
implicit none
class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:)
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_ipk_) :: is, im,i
integer(psb_lpk_) :: is, im,i
logical :: owned_
info = 0
@@ -453,12 +469,13 @@ contains
use psb_sort_mod
implicit none
class(psb_repl_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(inout) :: idx
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_) :: idxv(1),lidxv(1)
integer(psb_lpk_) :: idxv(1)
integer(psb_ipk_) :: lidxv(1)
info = 0
if (present(mask)) then
@@ -478,14 +495,27 @@ contains
subroutine repl_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx)
implicit none
class(psb_repl_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(in) :: idxin
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)
integer(psb_lpk_) :: idxv(1)
integer(psb_ipk_) :: lidxv(1)
info = 0
if (present(mask)) then
if (.not.mask) return
end if
idxv(1) = idxin
if (present(lidx)) then
lidxv(1) = lidx
call idxmap%g2lip_ins(idxv,info,lidx=lidxv)
else
call idxmap%g2lip_ins(idxv,info)
end if
idxout = idxv(1)
end subroutine repl_g2ls2_ins
@@ -495,12 +525,12 @@ contains
use psb_sort_mod
implicit none
class(psb_repl_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(inout) :: idx(:)
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_) :: i, is
integer(psb_lpk_) :: i, is
info = 0
is = size(idx)
@@ -579,13 +609,13 @@ contains
subroutine repl_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx)
implicit none
class(psb_repl_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:)
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_ipk_) :: is, im, i
integer(psb_lpk_) :: is, im, i
info = 0
@@ -669,12 +699,12 @@ contains
subroutine repl_fnd_owner(idx,iprc,idxmap,info)
use psb_penv_mod
implicit none
integer(psb_ipk_), intent(in) :: idx(:)
integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: nv
integer(psb_mpik_) :: ictxt, iam, np
integer(psb_mpk_) :: ictxt, iam, np
ictxt = idxmap%get_ctxt()
call psb_info(ictxt,iam,np)
@@ -695,11 +725,11 @@ contains
use psb_error_mod
implicit none
class(psb_repl_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(in) :: nl
integer(psb_mpik_), intent(in) :: ictxt
integer(psb_lpk_), intent(in) :: nl
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(out) :: info
! To be implemented
integer(psb_mpik_) :: iam, np
integer(psb_mpk_) :: iam, np
info = 0
call psb_info(ictxt,iam,np)
@@ -729,7 +759,7 @@ contains
class(psb_repl_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(out) :: info
integer(psb_mpik_) :: ictxt, iam, np
integer(psb_mpk_) :: ictxt, iam, np
info = 0
ictxt = idxmap%get_ctxt()