From 784cc65e518374dfaa618be2f6d731030b2f58a4 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 10 Feb 2023 07:45:44 -0500 Subject: [PATCH] Temporarily revert hash_map_mod waiting for a proper fix --- base/modules/desc/psb_hash_map_mod.f90 | 871 ++++++++++++++++--------- 1 file changed, 547 insertions(+), 324 deletions(-) diff --git a/base/modules/desc/psb_hash_map_mod.f90 b/base/modules/desc/psb_hash_map_mod.f90 index 06e68451..528450ae 100644 --- a/base/modules/desc/psb_hash_map_mod.f90 +++ b/base/modules/desc/psb_hash_map_mod.f90 @@ -659,49 +659,410 @@ contains !$ use_openmp = .true. - info = psb_success_ - name = 'hash_g2l_ins' - call psb_erractionsave(err_act) + 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) + ctxt = idxmap%get_ctxt() + call psb_info(ctxt, me, np) - is = size(idx) + is = size(idx) - if (present(mask)) then - if (size(mask) < size(idx)) then - info = -1 - return + 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 - end if - if (present(lidx)) then - if (size(lidx) < size(idx)) then + + 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 - return end if - end if + else - mglob = idxmap%get_gr() - nrow = idxmap%get_lr() + info = psb_success_ + name = 'hash_g2l_ins' + call psb_erractionsave(err_act) - if (idxmap%is_bld()) then - if (use_openmp) then - !$ call OMP_init_lock(ins_lck) - isLoopValid = .true. - ncol = idxmap%get_lc() + 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 (present(mask)) then - if (use_openmp) then - !$OMP PARALLEL DO default(none) schedule(STATIC) & - !$OMP shared(name,is,mask,lidx,idx,mglob,idxmap,ncol,nrow,ins_lck,laddsz) & - !$OMP private(i,ip,lip,tlip,nxt,info) & - !$OMP reduction(.AND.:isLoopValid) - do i = 1, is + 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 (use_openmp) then + !$ call OMP_init_lock(ins_lck) + isLoopValid = .true. + ncol = idxmap%get_lc() + end if + + if (present(lidx)) then + if (present(mask)) then + if (use_openmp) then + !$OMP PARALLEL DO default(none) schedule(STATIC) & + !$OMP shared(name,is,mask,lidx,idx,mglob,idxmap,ncol,nrow,ins_lck,laddsz) & + !$OMP private(i,ip,lip,tlip,nxt,info) & + !$OMP reduction(.AND.:isLoopValid) + 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 (mask(i)) then + 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 + !$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) if ((ip < 1 ).or.(ip>mglob)) then @@ -709,9 +1070,8 @@ contains 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. + ! In OMP logic the index research limit is turned off. It is + ! a correct way to fit the subroutine? call hash_inner_cnv(ip,lip,idxmap%hashvmask,& & idxmap%hashv,idxmap%glb_lc,ncol) @@ -729,11 +1089,12 @@ contains ! 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 + & idxmap%hashv,idxmap%glb_lc,ncol) + if (lip < 0) then - ! Locking system to handle concurrent hashmap read/write. + ! 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 ! 'nxt' is not equal to 'tlip' when the key is already inside @@ -744,12 +1105,13 @@ contains ncol = MAX(ncol,nxt) !$ call OMP_unset_lock(ins_lck) + ! Under checking! 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/)) + &a_err='psb_ensure_size',i_err=(/info/)) isLoopValid = .false. cycle @@ -761,7 +1123,6 @@ contains end if info = psb_success_ - else !$ call OMP_unset_lock(ins_lck) @@ -778,43 +1139,40 @@ contains idx(i) = lip info = psb_success_ - else - idx(i) = -1 - end if - end do - !$OMP END PARALLEL DO + end do + !$OMP END PARALLEL DO - call idxmap%set_lc(ncol) + call idxmap%set_lc(ncol) - if (.not. isLoopValid) then - goto 9999 - end if + 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 + else + 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 - tlip = lip + 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 == tlip) then - ncol = max(ncol,nxt) - call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& - & pad=-1_psb_lpk_,addsz=laddsz) + 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 @@ -831,50 +1189,58 @@ contains end if idx(i) = lip info = psb_success_ - else - idx(i) = -1 - end if - enddo + 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,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) - if ((ip < 1 ).or.(ip>mglob)) then - idx(i) = -1 - cycle - endif + else if (.not.present(lidx)) then - ! In OMP logic the index research limit is turned off. It is - ! a correct way to fit the subroutine? - call hash_inner_cnv(ip,lip,idxmap%hashvmask,& - & idxmap%hashv,idxmap%glb_lc,ncol) + if (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 - if (lip < 0) then - tlip = lip - nxt = lidx(i) + ncol = idxmap%get_lc() + info = 0 + if (mask(i)) then + ip = idx(i) - if (nxt <= nrow) then - idx(i) = -1 - cycle - endif + if ((ip < 1 ).or.(ip>mglob)) 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) + nxt = ncol + 1 + ! 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 - ! 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 (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 + ! 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 + info = psb_success_ + end if if (info >= 0) then ! 'nxt' is not equal to 'tlip' when the key is already inside @@ -885,13 +1251,12 @@ contains ncol = MAX(ncol,nxt) !$ call OMP_unset_lock(ins_lck) - ! Under checking! 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/)) + &a_err='psb_ensure_size',i_err=(/info/)) isLoopValid = .false. cycle @@ -912,78 +1277,71 @@ contains isLoopValid = .false. cycle end if + else - !$ call OMP_unset_lock(ins_lck) + idx(i) = -1 end if - end if - - idx(i) = lip - info = psb_success_ - end do - !$OMP END PARALLEL DO + end do + !$OMP END PARALLEL DO - call idxmap%set_lc(ncol) + call idxmap%set_lc(ncol) - if (.not. isLoopValid) then - goto 9999 - end if + if (.not. isLoopValid) then + goto 9999 + end if - else - 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) + 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 + 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 - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='SearchInsKeyVal',i_err=(/info/)) - goto 9999 + idx(i) = -1 end if - end if - idx(i) = lip - info = psb_success_ - enddo - end if - end if - - else if (.not.present(lidx)) then - - if (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 + 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,mglob,idxmap,ncol,nrow,ins_lck,laddsz) & + !$OMP private(i,ip,lip,tlip,nxt,info) & + !$OMP reduction(.AND.:isLoopValid) + do i = 1, is - if (mask(i)) then ip = idx(i) if ((ip < 1 ).or.(ip>mglob)) then @@ -1004,7 +1362,7 @@ contains ! is often already existing). !$ call OMP_set_lock(ins_lck) 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 @@ -1024,7 +1382,6 @@ contains ! 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) @@ -1033,9 +1390,9 @@ contains if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_ai_,name,& - &a_err='psb_ensure_size',i_err=(/info/)) + &a_err='psb_ensure_size',i_err=(/info/)) - isLoopValid = .false. + !$ isLoopValid = .false. cycle end if @@ -1045,6 +1402,7 @@ contains end if info = psb_success_ + else !$ call OMP_unset_lock(ins_lck) @@ -1054,23 +1412,18 @@ contains isLoopValid = .false. cycle end if + end do + !$OMP END PARALLEL DO - else - idx(i) = -1 - end if - end do - !$OMP END PARALLEL DO + call idxmap%set_lc(ncol) - call idxmap%set_lc(ncol) - - if (.not. isLoopValid) then - goto 9999 - end if + if (.not. isLoopValid) then + goto 9999 + end if - else - do i = 1, is - ncol = idxmap%get_lc() - if (mask(i)) then + else + do i = 1, is + ncol = idxmap%get_lc() ip = idx(i) if ((ip < 1 ).or.(ip>mglob)) then idx(i) = -1 @@ -1091,8 +1444,9 @@ contains & 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='psb_ensure_size',i_err=(/info/)) + &a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) goto 9999 end if idxmap%loc_to_glob(nxt) = ip @@ -1100,159 +1454,28 @@ contains endif info = psb_success_ else + ch_err='SearchInsKeyVal' call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='SearchInsKeyVal',i_err=(/info/)) + & a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) goto 9999 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 - !$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 - - 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 - ! 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 - info = psb_success_ - end if - - 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 - end do - !$OMP END PARALLEL DO - - call idxmap%set_lc(ncol) - - if (.not. isLoopValid) then - goto 9999 + enddo end if - - else - do i = 1, is - ncol = idxmap%get_lc() - ip = idx(i) - if ((ip < 1 ).or.(ip>mglob)) then - idx(i) = -1 - cycle - endif - nxt = ncol + 1 - call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& - & idxmap%glb_lc,ncol) - if (lip < 0) 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 - end if - if (use_openmp) then - !$ call OMP_destroy_lock(ins_lck) - end if + if (use_openmp) then + !$ call OMP_destroy_lock(ins_lck) + end if - else - ! Wrong state - idx = -1 - info = -1 + else + ! Wrong state + idx = -1 + info = -1 + end if end if - call psb_erractionrestore(err_act) return