fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Work on psb_hash_map_mod

Browse Source
omp-threadsafe
Salvatore Filippone 2 years ago
parent 0480610822
commit 49d37911ca
1 changed files with 257 additions and 255 deletions
Show Stats Download Patch File Download Diff File

504
base/modules/desc/psb_hash_map_mod.f90 → base/modules/desc/psb_hash_map_mod.F90
Unescape Escape View File

@ -636,7 +636,9 @@ contains
use psb_realloc_mod
use psb_sort_mod
use psb_penv_mod
!$ use omp_lib
#ifdef OPENMP
use omp_lib
#endif
implicit none
@ -655,230 +657,12 @@ contains
logical :: use_openmp = .false.
logical, volatile :: isLoopValid
!$ integer(kind = OMP_lock_kind) :: ins_lck
!$ use_openmp = .true.
if (.true.) then
info = psb_success_
name = 'hash_g2l_ins'
call psb_erractionsave(err_act)
ctxt = idxmap%get_ctxt()
call psb_info(ctxt, me, np)
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
mglob = idxmap%get_gr()
nrow = idxmap%get_lr()
if (idxmap%is_bld()) then
if (present(lidx)) then
if (present(mask)) then
do i = 1, is
ncol = idxmap%get_lc()
if (mask(i)) then
ip = idx(i)
if ((ip < 1 ).or.(ip>mglob) ) then
idx(i) = -1
cycle
endif
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,tlip,nxt,idxmap%hash,info)
if (info >=0) then
if (nxt == tlip) then
ncol = max(ncol,nxt)
call psb_ensure_size(ncol,idxmap%loc_to_glob,info,&
& pad=-1_psb_lpk_,addsz=laddsz)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_ai_,name,&
&a_err='psb_ensure_size',i_err=(/info/))
goto 9999
end if
idxmap%loc_to_glob(nxt) = ip
call idxmap%set_lc(ncol)
endif
info = psb_success_
else
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='SearchInsKeyVal',i_err=(/info/))
goto 9999
end if
end if
idx(i) = lip
info = psb_success_
else
idx(i) = -1
end if
enddo
else if (.not.present(mask)) then
do i = 1, is
ncol = idxmap%get_lc()
ip = idx(i)
if ((ip < 1 ).or.(ip>mglob)) then
idx(i) = -1
cycle
endif
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,&
& idxmap%glb_lc,ncol)
if (lip < 0) then
nxt = lidx(i)
if (nxt <= nrow) then
idx(i) = -1
cycle
endif
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=-1_psb_lpk_,addsz=laddsz)
if (info /= psb_success_) then
info=1
call psb_errpush(psb_err_from_subroutine_ai_,name,&
&a_err='psb_ensure_size',i_err=(/info/))
goto 9999
end if
idxmap%loc_to_glob(nxt) = ip
call idxmap%set_lc(ncol)
endif
info = psb_success_
else
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='SearchInsKeyVal',i_err=(/info/))
goto 9999
end if
end if
idx(i) = lip
info = psb_success_
enddo
end if
else if (.not.present(lidx)) then
if (present(mask)) then
do i = 1, is
ncol = idxmap%get_lc()
if (mask(i)) then
ip = idx(i)
if ((ip < 1 ).or.(ip>mglob)) then
idx(i) = -1
cycle
endif
nxt = ncol + 1
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,&
& idxmap%glb_lc,ncol)
if (lip < 0) 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=-1_psb_lpk_,addsz=laddsz)
if (info /= psb_success_) then
info=1
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='psb_ensure_size',i_err=(/info/))
goto 9999
end if
idxmap%loc_to_glob(nxt) = ip
call idxmap%set_lc(ncol)
endif
info = psb_success_
else
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='SearchInsKeyVal',i_err=(/info/))
goto 9999
end if
idx(i) = lip
info = psb_success_
else
idx(i) = -1
end if
enddo
else if (.not.present(mask)) then
do i = 1, is
ncol = idxmap%get_lc()
ip = idx(i)
if ((ip < 1 ).or.(ip>mglob)) then
idx(i) = -1
cycle
endif
nxt = ncol + 1
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,&
& idxmap%glb_lc,ncol)
if (lip < 0) 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=-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/))
goto 9999
end if
idxmap%loc_to_glob(nxt) = ip
call idxmap%set_lc(ncol)
endif
info = psb_success_
else
ch_err='SearchInsKeyVal'
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,izero,izero,izero,izero/))
goto 9999
end if
idx(i) = lip
info = psb_success_
enddo
end if
end if
else
! Wrong state
idx = -1
info = -1
end if
else
#ifdef OPENMP
integer(kind = OMP_lock_kind) :: ins_lck
#endif
if (use_openmp) then
#ifdef OPENMP
info = psb_success_
name = 'hash_g2l_ins'
call psb_erractionsave(err_act)
@ -906,11 +690,10 @@ contains
nrow = idxmap%get_lr()
if (idxmap%is_bld()) then
if (use_openmp) then
!$ call OMP_init_lock(ins_lck)
call OMP_init_lock(ins_lck)
isLoopValid = .true.
ncol = idxmap%get_lc()
end if
if (present(lidx)) then
if (present(mask)) then
@ -947,7 +730,7 @@ contains
! We check again if the index is already in 'idxmap', this
! time inside a critical region (we assume that the index
! is often already existing).
!$ call OMP_set_lock(ins_lck)
call OMP_set_lock(ins_lck)
call hash_inner_cnv(ip,lip,idxmap%hashvmask,&
& idxmap%hashv,idxmap%glb_lc,ncol)
! Index not found
@ -962,7 +745,7 @@ contains
if (nxt == tlip) then
ncol = MAX(ncol,nxt)
!$ call OMP_unset_lock(ins_lck)
call OMP_unset_lock(ins_lck)
call psb_ensure_size(ncol,idxmap%loc_to_glob,info,&
& pad=-1_psb_lpk_,addsz=laddsz)
@ -977,13 +760,13 @@ contains
idxmap%loc_to_glob(nxt) = ip
else
!$ call OMP_unset_lock(ins_lck)
call OMP_unset_lock(ins_lck)
end if
info = psb_success_
else
!$ call OMP_unset_lock(ins_lck)
call OMP_unset_lock(ins_lck)
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='SearchInsKeyVal',i_err=(/info/))
@ -992,7 +775,7 @@ contains
cycle
end if
else
!$ call OMP_unset_lock(ins_lck)
call OMP_unset_lock(ins_lck)
end if
end if
@ -1056,7 +839,9 @@ contains
end if
enddo
end if
else if (.not.present(mask)) then
if (use_openmp) then
!$OMP PARALLEL DO default(none) schedule(STATIC) &
!$OMP shared(name,is,idx,lidx,mglob,idxmap,ncol,nrow,ins_lck,laddsz) &
@ -1087,14 +872,14 @@ contains
! We check again if the index is already in 'idxmap', this
! time inside a critical region (we assume that the index
! is often already existing).
!$ call OMP_set_lock(ins_lck)
call OMP_set_lock(ins_lck)
call hash_inner_cnv(ip,lip,idxmap%hashvmask,&
& idxmap%hashv,idxmap%glb_lc,ncol)
if (lip < 0) then
! Locking system to handle concurrent write/access. Under checking!
call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info)
!$ call OMP_unset_lock(ins_lck)
call OMP_unset_lock(ins_lck)
if (info >= 0) then
! 'nxt' is not equal to 'tlip' when the key is already inside
@ -1103,7 +888,7 @@ contains
if (nxt == tlip) then
ncol = MAX(ncol,nxt)
!$ call OMP_unset_lock(ins_lck)
call OMP_unset_lock(ins_lck)
! Under checking!
call psb_ensure_size(ncol,idxmap%loc_to_glob,info,&
@ -1119,12 +904,12 @@ contains
idxmap%loc_to_glob(nxt) = ip
else
!$ call OMP_unset_lock(ins_lck)
call OMP_unset_lock(ins_lck)
end if
info = psb_success_
else
!$ call OMP_unset_lock(ins_lck)
call OMP_unset_lock(ins_lck)
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='SearchInsKeyVal',i_err=(/info/))
@ -1133,7 +918,7 @@ contains
cycle
end if
else
!$ call OMP_unset_lock(ins_lck)
call OMP_unset_lock(ins_lck)
end if
end if
@ -1225,7 +1010,7 @@ contains
! We check again if the index is already in 'idxmap', this
! time inside a critical region (we assume that the index
! is often already existing).
!$ call OMP_set_lock(ins_lck)
call OMP_set_lock(ins_lck)
call hash_inner_cnv(ip,lip,idxmap%hashvmask,&
& idxmap%hashv,idxmap%glb_lc,ncol)
@ -1235,7 +1020,7 @@ contains
call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info)
lip = tlip
else
!$ call OMP_unset_lock(ins_lck)
call OMP_unset_lock(ins_lck)
end if
idx(i) = lip
@ -1249,7 +1034,7 @@ contains
if (nxt == tlip) then
ncol = MAX(ncol,nxt)
!$ call OMP_unset_lock(ins_lck)
call OMP_unset_lock(ins_lck)
call psb_ensure_size(ncol,idxmap%loc_to_glob,info,&
& pad=-1_psb_lpk_,addsz=laddsz)
@ -1264,12 +1049,12 @@ contains
idxmap%loc_to_glob(nxt) = ip
else
!$ call OMP_unset_lock(ins_lck)
call OMP_unset_lock(ins_lck)
end if
info = psb_success_
else
!$ call OMP_unset_lock(ins_lck)
call OMP_unset_lock(ins_lck)
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='SearchInsKeyVal',i_err=(/info/))
@ -1360,7 +1145,7 @@ contains
! We check again if the index is already in 'idxmap', this
! time inside a critical region (we assume that the index
! is often already existing).
!$ call OMP_set_lock(ins_lck)
call OMP_set_lock(ins_lck)
call hash_inner_cnv(ip,lip,idxmap%hashvmask,&
& idxmap%hashv,idxmap%glb_lc,ncol)
@ -1370,7 +1155,7 @@ contains
call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info)
lip = tlip
else
!$ call OMP_unset_lock(ins_lck)
call OMP_unset_lock(ins_lck)
end if
idx(i) = lip
@ -1383,7 +1168,7 @@ contains
! to the existing mapping.
if (nxt == tlip) then
ncol = MAX(ncol,nxt)
!$ call OMP_unset_lock(ins_lck)
call OMP_unset_lock(ins_lck)
call psb_ensure_size(ncol,idxmap%loc_to_glob,info,&
& pad=-1_psb_lpk_,addsz=laddsz)
@ -1392,19 +1177,19 @@ contains
call psb_errpush(psb_err_from_subroutine_ai_,name,&
&a_err='psb_ensure_size',i_err=(/info/))
!$ isLoopValid = .false.
isLoopValid = .false.
cycle
end if
idxmap%loc_to_glob(nxt) = ip
else
!$ call OMP_unset_lock(ins_lck)
call OMP_unset_lock(ins_lck)
end if
info = psb_success_
else
!$ call OMP_unset_lock(ins_lck)
call OMP_unset_lock(ins_lck)
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='SearchInsKeyVal',i_err=(/info/))
@ -1466,10 +1251,227 @@ contains
end if
end if
if (use_openmp) then
!$ call OMP_destroy_lock(ins_lck)
call OMP_destroy_lock(ins_lck)
else
! Wrong state
idx = -1
info = -1
end if
#endif
else if (.not.use_openmp) then
info = psb_success_
name = 'hash_g2l_ins'
call psb_erractionsave(err_act)
ctxt = idxmap%get_ctxt()
call psb_info(ctxt, me, np)
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
mglob = idxmap%get_gr()
nrow = idxmap%get_lr()
if (idxmap%is_bld()) then
if (present(lidx)) then
if (present(mask)) then
do i = 1, is
ncol = idxmap%get_lc()
if (mask(i)) then
ip = idx(i)
if ((ip < 1 ).or.(ip>mglob) ) then
idx(i) = -1
cycle
endif
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,tlip,nxt,idxmap%hash,info)
if (info >=0) then
if (nxt == tlip) then
ncol = max(ncol,nxt)
call psb_ensure_size(ncol,idxmap%loc_to_glob,info,&
& pad=-1_psb_lpk_,addsz=laddsz)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_ai_,name,&
&a_err='psb_ensure_size',i_err=(/info/))
goto 9999
end if
idxmap%loc_to_glob(nxt) = ip
call idxmap%set_lc(ncol)
endif
info = psb_success_
else
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='SearchInsKeyVal',i_err=(/info/))
goto 9999
end if
end if
idx(i) = lip
info = psb_success_
else
idx(i) = -1
end if
enddo
else if (.not.present(mask)) then
do i = 1, is
ncol = idxmap%get_lc()
ip = idx(i)
if ((ip < 1 ).or.(ip>mglob)) then
idx(i) = -1
cycle
endif
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,&
& idxmap%glb_lc,ncol)
if (lip < 0) then
nxt = lidx(i)
if (nxt <= nrow) then
idx(i) = -1
cycle
endif
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=-1_psb_lpk_,addsz=laddsz)
if (info /= psb_success_) then
info=1
call psb_errpush(psb_err_from_subroutine_ai_,name,&
&a_err='psb_ensure_size',i_err=(/info/))
goto 9999
end if
idxmap%loc_to_glob(nxt) = ip
call idxmap%set_lc(ncol)
endif
info = psb_success_
else
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='SearchInsKeyVal',i_err=(/info/))
goto 9999
end if
end if
idx(i) = lip
info = psb_success_
enddo
end if
else if (.not.present(lidx)) then
if (present(mask)) then
do i = 1, is
ncol = idxmap%get_lc()
if (mask(i)) then
ip = idx(i)
if ((ip < 1 ).or.(ip>mglob)) then
idx(i) = -1
cycle
endif
nxt = ncol + 1
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,&
& idxmap%glb_lc,ncol)
if (lip < 0) 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=-1_psb_lpk_,addsz=laddsz)
if (info /= psb_success_) then
info=1
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='psb_ensure_size',i_err=(/info/))
goto 9999
end if
idxmap%loc_to_glob(nxt) = ip
call idxmap%set_lc(ncol)
endif
info = psb_success_
else
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='SearchInsKeyVal',i_err=(/info/))
goto 9999
end if
idx(i) = lip
info = psb_success_
else
idx(i) = -1
end if
enddo
else if (.not.present(mask)) then
do i = 1, is
ncol = idxmap%get_lc()
ip = idx(i)
if ((ip < 1 ).or.(ip>mglob)) then
idx(i) = -1
cycle
endif
nxt = ncol + 1
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,&
& idxmap%glb_lc,ncol)
if (lip < 0) 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=-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/))
goto 9999
end if
idxmap%loc_to_glob(nxt) = ip
call idxmap%set_lc(ncol)
endif
info = psb_success_
else
ch_err='SearchInsKeyVal'
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,izero,izero,izero,izero/))
goto 9999
end if
idx(i) = lip
info = psb_success_
enddo
end if
end if
else
! Wrong state
idx = -1
Write Preview
Loading…
Cancel
Save