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

Bit of cleanup in psb_hash_map_mod

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

523
base/modules/desc/psb_hash_map_mod.F90
Unescape Escape View File

@ -690,164 +690,20 @@ contains
nrow = idxmap%get_lr() nrow = idxmap%get_lr()
if (idxmap%is_bld()) then if (idxmap%is_bld()) then
call OMP_init_lock(ins_lck) call OMP_init_lock(ins_lck)
isLoopValid = .true. isLoopValid = .true.
ncol = idxmap%get_lc() ncol = idxmap%get_lc()
if (present(lidx)) then if (present(lidx)) then
if (present(mask)) then if (present(mask)) then
if (use_openmp) then !$OMP PARALLEL DO default(none) schedule(STATIC) &
!$OMP PARALLEL DO default(none) schedule(STATIC) & !$OMP shared(name,is,mask,lidx,idx,mglob,idxmap,ncol,nrow,ins_lck,laddsz) &
!$OMP shared(name,is,mask,lidx,idx,mglob,idxmap,ncol,nrow,ins_lck,laddsz) & !$OMP private(i,ip,lip,tlip,nxt,info) &
!$OMP private(i,ip,lip,tlip,nxt,info) & !$OMP reduction(.AND.:isLoopValid)
!$OMP reduction(.AND.:isLoopValid) do i = 1, is
do i = 1, is
if (mask(i)) then
ip = idx(i)
if ((ip < 1 ).or.(ip>mglob)) then
idx(i) = -1
cycle
endif
! At first, we check the index presence in 'idxmap'. Usually
! the index is found. If it is not found, we repeat the checking,
! but inside a critical region.
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
! 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 hash_inner_cnv(ip,lip,idxmap%hashvmask,&
& idxmap%hashv,idxmap%glb_lc,ncol)
! Index not found
if (lip < 0) then
! Locking system to handle concurrent hashmap read/write.
call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info)
if (info >= 0) then
! 'nxt' is not equal to 'tlip' when the key is already inside
! the hash map. In that case 'tlip' is the value corresponding
! to the existing mapping.
if (nxt == tlip) then
ncol = MAX(ncol,nxt)
call OMP_unset_lock(ins_lck)
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/))
isLoopValid = .false.
cycle
end if
idxmap%loc_to_glob(nxt) = ip
else
call OMP_unset_lock(ins_lck)
end if
info = psb_success_
else
call OMP_unset_lock(ins_lck)
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='SearchInsKeyVal',i_err=(/info/))
isLoopValid = .false.
cycle
end if
else
call OMP_unset_lock(ins_lck)
end if
end if
idx(i) = lip
info = psb_success_
else
idx(i) = -1
end if
end do
!$OMP END PARALLEL DO
call idxmap%set_lc(ncol)
if (.not. isLoopValid) then
goto 9999
end if
else
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
end if
else if (.not.present(mask)) then
if (use_openmp) then if (mask(i)) then
!$OMP PARALLEL DO default(none) schedule(STATIC) &
!$OMP shared(name,is,idx,lidx,mglob,idxmap,ncol,nrow,ins_lck,laddsz) &
!$OMP private(i,ip,lip,tlip,nxt,info) &
!$OMP reduction(.AND.:isLoopValid)
do i = 1, is
ip = idx(i) ip = idx(i)
if ((ip < 1 ).or.(ip>mglob)) then if ((ip < 1 ).or.(ip>mglob)) then
@ -855,14 +711,15 @@ contains
cycle cycle
endif endif
! In OMP logic the index research limit is turned off. It is ! At first, we check the index presence in 'idxmap'. Usually
! a correct way to fit the subroutine? ! the index is found. If it is not found, we repeat the checking,
! but inside a critical region.
call hash_inner_cnv(ip,lip,idxmap%hashvmask,& call hash_inner_cnv(ip,lip,idxmap%hashvmask,&
& idxmap%hashv,idxmap%glb_lc,ncol) & idxmap%hashv,idxmap%glb_lc,ncol)
if (lip < 0) then if (lip < 0) then
tlip = lip tlip = lip
nxt = lidx(i) nxt = lidx(i)
if (nxt <= nrow) then if (nxt <= nrow) then
idx(i) = -1 idx(i) = -1
@ -872,14 +729,13 @@ contains
! We check again if the index is already in 'idxmap', this ! We check again if the index is already in 'idxmap', this
! time inside a critical region (we assume that the index ! time inside a critical region (we assume that the index
! is often already existing). ! is often already existing).
call OMP_set_lock(ins_lck) call OMP_set_lock(ins_lck)
call hash_inner_cnv(ip,lip,idxmap%hashvmask,& call hash_inner_cnv(ip,lip,idxmap%hashvmask,&
& idxmap%hashv,idxmap%glb_lc,ncol) & idxmap%hashv,idxmap%glb_lc,ncol)
! Index not found
if (lip < 0) then if (lip < 0) then
! Locking system to handle concurrent write/access. Under checking! ! Locking system to handle concurrent hashmap read/write.
call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info)
call OMP_unset_lock(ins_lck)
if (info >= 0) then if (info >= 0) then
! 'nxt' is not equal to 'tlip' when the key is already inside ! 'nxt' is not equal to 'tlip' when the key is already inside
@ -890,7 +746,6 @@ contains
ncol = MAX(ncol,nxt) 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,& call psb_ensure_size(ncol,idxmap%loc_to_glob,info,&
& pad=-1_psb_lpk_,addsz=laddsz) & pad=-1_psb_lpk_,addsz=laddsz)
@ -904,10 +759,11 @@ contains
idxmap%loc_to_glob(nxt) = ip idxmap%loc_to_glob(nxt) = ip
else else
call OMP_unset_lock(ins_lck) call OMP_unset_lock(ins_lck)
end if end if
info = psb_success_ info = psb_success_
else else
call OMP_unset_lock(ins_lck) call OMP_unset_lock(ins_lck)
@ -924,108 +780,58 @@ contains
idx(i) = lip idx(i) = lip
info = psb_success_ info = psb_success_
end do else
!$OMP END PARALLEL DO idx(i) = -1
call idxmap%set_lc(ncol)
if (.not. isLoopValid) then
goto 9999
end if end if
end do
!$OMP END PARALLEL DO
else call idxmap%set_lc(ncol)
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 (.not. isLoopValid) then
if (nxt == lip) then goto 9999
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 end if
end if
else if (.not.present(lidx)) then
if (present(mask)) then else if (.not.present(mask)) then
if (use_openmp) then
!$OMP PARALLEL DO default(none) schedule(STATIC) &
!$OMP shared(name,is,idx,mask,mglob,idxmap,ncol,nrow,ins_lck,laddsz) &
!$OMP private(i,ip,lip,tlip,nxt,info) &
!$OMP reduction(.AND.:isLoopValid)
do i = 1, is
ncol = idxmap%get_lc()
info = 0
if (mask(i)) then
ip = idx(i)
if ((ip < 1 ).or.(ip>mglob)) then
idx(i) = -1
cycle
endif
nxt = ncol + 1 !$OMP PARALLEL DO default(none) schedule(STATIC) &
! At first, we check the index presence in 'idxmap'. Usually !$OMP shared(name,is,idx,lidx,mglob,idxmap,ncol,nrow,ins_lck,laddsz) &
! the index is found. If it is not found, we repeat the checking, !$OMP private(i,ip,lip,tlip,nxt,info) &
! but inside a critical region. !$OMP reduction(.AND.:isLoopValid)
call hash_inner_cnv(ip,lip,idxmap%hashvmask,& do i = 1, is
& idxmap%hashv,idxmap%glb_lc,ncol) ip = idx(i)
if (lip < 0) then if ((ip < 1 ).or.(ip>mglob)) then
idx(i) = -1
cycle
endif
! We check again if the index is already in 'idxmap', this ! In OMP logic the index research limit is turned off. It is
! time inside a critical region (we assume that the index ! a correct way to fit the subroutine?
! is often already existing). call hash_inner_cnv(ip,lip,idxmap%hashvmask,&
call OMP_set_lock(ins_lck) & idxmap%hashv,idxmap%glb_lc,ncol)
call hash_inner_cnv(ip,lip,idxmap%hashvmask,&
& idxmap%hashv,idxmap%glb_lc,ncol)
! Index not found
if (lip < 0) then
! Locking system to handle concurrent hashmap write/access.
call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info)
lip = tlip
else
call OMP_unset_lock(ins_lck)
end if
idx(i) = lip if (lip < 0) then
info = psb_success_ tlip = lip
end if nxt = lidx(i)
if (nxt <= nrow) then
idx(i) = -1
cycle
endif
! 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 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)
if (info >= 0) then if (info >= 0) then
! 'nxt' is not equal to 'tlip' when the key is already inside ! 'nxt' is not equal to 'tlip' when the key is already inside
@ -1036,6 +842,7 @@ contains
ncol = MAX(ncol,nxt) 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,& call psb_ensure_size(ncol,idxmap%loc_to_glob,info,&
& pad=-1_psb_lpk_,addsz=laddsz) & pad=-1_psb_lpk_,addsz=laddsz)
@ -1062,71 +869,36 @@ contains
isLoopValid = .false. isLoopValid = .false.
cycle cycle
end if end if
else else
idx(i) = -1 call OMP_unset_lock(ins_lck)
end if end if
end do
!$OMP END PARALLEL DO
call idxmap%set_lc(ncol)
if (.not. isLoopValid) then
goto 9999
end if end if
else idx(i) = lip
do i = 1, is info = psb_success_
ncol = idxmap%get_lc() end do
if (mask(i)) then !$OMP END PARALLEL DO
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 call idxmap%set_lc(ncol)
if (nxt == lip) then
ncol = nxt if (.not. isLoopValid) then
call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& goto 9999
& 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
end if end if
else if (.not.present(mask)) then
if (use_openmp) then
!$OMP PARALLEL DO default(none) schedule(STATIC) &
!$OMP shared(name,is,idx,mglob,idxmap,ncol,nrow,ins_lck,laddsz) &
!$OMP private(i,ip,lip,tlip,nxt,info) &
!$OMP reduction(.AND.:isLoopValid)
do i = 1, is
end if
else if (.not.present(lidx)) then
if (present(mask)) then
!$OMP PARALLEL DO default(none) schedule(STATIC) &
!$OMP shared(name,is,idx,mask,mglob,idxmap,ncol,nrow,ins_lck,laddsz) &
!$OMP private(i,ip,lip,tlip,nxt,info) &
!$OMP reduction(.AND.:isLoopValid)
do i = 1, is
ncol = idxmap%get_lc()
info = 0
if (mask(i)) then
ip = idx(i) ip = idx(i)
if ((ip < 1 ).or.(ip>mglob)) then if ((ip < 1 ).or.(ip>mglob)) then
@ -1134,6 +906,7 @@ contains
cycle cycle
endif endif
nxt = ncol + 1
! At first, we check the index presence in 'idxmap'. Usually ! At first, we check the index presence in 'idxmap'. Usually
! the index is found. If it is not found, we repeat the checking, ! the index is found. If it is not found, we repeat the checking,
! but inside a critical region. ! but inside a critical region.
@ -1167,6 +940,7 @@ contains
! the hash map. In that case 'tlip' is the value corresponding ! the hash map. In that case 'tlip' is the value corresponding
! to the existing mapping. ! to the existing mapping.
if (nxt == tlip) then if (nxt == tlip) then
ncol = MAX(ncol,nxt) ncol = MAX(ncol,nxt)
call OMP_unset_lock(ins_lck) call OMP_unset_lock(ins_lck)
@ -1187,7 +961,6 @@ contains
end if end if
info = psb_success_ info = psb_success_
else else
call OMP_unset_lock(ins_lck) call OMP_unset_lock(ins_lck)
@ -1197,57 +970,105 @@ contains
isLoopValid = .false. isLoopValid = .false.
cycle cycle
end if end if
end do
!$OMP END PARALLEL DO
call idxmap%set_lc(ncol) else
idx(i) = -1
if (.not. isLoopValid) then
goto 9999
end if end if
end do
!$OMP END PARALLEL DO
else call idxmap%set_lc(ncol)
do i = 1, is
ncol = idxmap%get_lc() if (.not. isLoopValid) then
ip = idx(i) goto 9999
if ((ip < 1 ).or.(ip>mglob)) then end if
idx(i) = -1
cycle else if (.not.present(mask)) then
endif !$OMP PARALLEL DO default(none) schedule(STATIC) &
nxt = ncol + 1 !$OMP shared(name,is,idx,mglob,idxmap,ncol,nrow,ins_lck,laddsz) &
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& !$OMP private(i,ip,lip,tlip,nxt,info) &
& idxmap%glb_lc,ncol) !$OMP reduction(.AND.:isLoopValid)
do i = 1, is
ip = idx(i)
if ((ip < 1 ).or.(ip>mglob)) then
idx(i) = -1
cycle
endif
! At first, we check the index presence in 'idxmap'. Usually
! the index is found. If it is not found, we repeat the checking,
! but inside a critical region.
call hash_inner_cnv(ip,lip,idxmap%hashvmask,&
& idxmap%hashv,idxmap%glb_lc,ncol)
if (lip < 0) then
! 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 hash_inner_cnv(ip,lip,idxmap%hashvmask,&
& idxmap%hashv,idxmap%glb_lc,ncol)
! Index not found
if (lip < 0) then if (lip < 0) then
! Locking system to handle concurrent hashmap write/access.
call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info)
lip = tlip lip = tlip
else
call OMP_unset_lock(ins_lck)
end if end if
if (info >=0) then idx(i) = lip
if (nxt == lip) then info = psb_success_
ncol = nxt end if
call psb_ensure_size(ncol,idxmap%loc_to_glob,info,&
& pad=-1_psb_lpk_,addsz=laddsz) if (info >= 0) then
if (info /= psb_success_) then ! 'nxt' is not equal to 'tlip' when the key is already inside
info=1 ! the hash map. In that case 'tlip' is the value corresponding
ch_err='psb_ensure_size' ! to the existing mapping.
call psb_errpush(psb_err_from_subroutine_ai_,name,& if (nxt == tlip) then
&a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) ncol = MAX(ncol,nxt)
goto 9999 call OMP_unset_lock(ins_lck)
end if
idxmap%loc_to_glob(nxt) = ip call psb_ensure_size(ncol,idxmap%loc_to_glob,info,&
call idxmap%set_lc(ncol) & pad=-1_psb_lpk_,addsz=laddsz)
endif
info = psb_success_ if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_ai_,name,&
&a_err='psb_ensure_size',i_err=(/info/))
isLoopValid = .false.
cycle
end if
idxmap%loc_to_glob(nxt) = ip
else else
ch_err='SearchInsKeyVal' call OMP_unset_lock(ins_lck)
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,izero,izero,izero,izero/))
goto 9999
end if end if
idx(i) = lip
info = psb_success_ info = psb_success_
enddo
else
call OMP_unset_lock(ins_lck)
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='SearchInsKeyVal',i_err=(/info/))
isLoopValid = .false.
cycle
end if
end do
!$OMP END PARALLEL DO
call idxmap%set_lc(ncol)
if (.not. isLoopValid) then
goto 9999
end if end if
end if end if
end if end if

Write Preview
Loading…
Cancel
Save