diff --git a/README.md b/README.md index d2f19f95e..a9813f5e3 100644 --- a/README.md +++ b/README.md @@ -121,6 +121,9 @@ Salvatore Filippone Contributors (roughly reverse cronological order): +Dimitri Walther +Andea Di Iorio +Stefano Petrilli Soren Rasmussen Zaak Beekman Ambra Abdullahi Hassan diff --git a/base/comm/psb_cgather.f90 b/base/comm/psb_cgather.f90 index 7893d7c3f..bc5302f56 100644 --- a/base/comm/psb_cgather.f90 +++ b/base/comm/psb_cgather.f90 @@ -58,10 +58,11 @@ subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot) ! locals type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx complex(psb_spk_), allocatable :: llocx(:) + integer(psb_mpk_), allocatable :: szs(:) character(len=20) :: name, ch_err name='psb_cgatherv' @@ -125,32 +126,34 @@ subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot) goto 9999 end if - call psb_realloc(m,globx,info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - globx(:) = czero - llocx = locx%get_vect() - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx) = llocx(i) - end do - + llocx = locx%get_vect() ! adjust overlapped elements do i=1, size(desc_a%ovrlap_elem,1) if (me /= desc_a%ovrlap_elem(i,3)) then idx = desc_a%ovrlap_elem(i,1) - call psb_loc_to_glob(idx,desc_a,info) - globx(idx) = czero + llocx(idx) = czero end if end do - - call psb_sum(ctxt,globx(1:m),root=root) + allocate(szs(np)) + loc_rows = desc_a%get_local_rows() + call psb_gather(ctxt,loc_rows,szs,root=root) + if ((me == root).or.(root == -1)) then + if (sum(szs) /= m) then + info=psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + call psb_realloc(m,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + end if + call psb_gatherv(ctxt,llocx(1:loc_rows),globx,szs,root=root) + call psb_erractionrestore(err_act) return diff --git a/base/comm/psb_dgather.f90 b/base/comm/psb_dgather.f90 index c1619b1bc..ed0591e81 100644 --- a/base/comm/psb_dgather.f90 +++ b/base/comm/psb_dgather.f90 @@ -58,10 +58,11 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot) ! locals type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx real(psb_dpk_), allocatable :: llocx(:) + integer(psb_mpk_), allocatable :: szs(:) character(len=20) :: name, ch_err name='psb_dgatherv' @@ -125,32 +126,34 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot) goto 9999 end if - call psb_realloc(m,globx,info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - globx(:) = dzero - llocx = locx%get_vect() - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx) = llocx(i) - end do - + llocx = locx%get_vect() ! adjust overlapped elements do i=1, size(desc_a%ovrlap_elem,1) if (me /= desc_a%ovrlap_elem(i,3)) then idx = desc_a%ovrlap_elem(i,1) - call psb_loc_to_glob(idx,desc_a,info) - globx(idx) = dzero + llocx(idx) = dzero end if end do - - call psb_sum(ctxt,globx(1:m),root=root) + allocate(szs(np)) + loc_rows = desc_a%get_local_rows() + call psb_gather(ctxt,loc_rows,szs,root=root) + if ((me == root).or.(root == -1)) then + if (sum(szs) /= m) then + info=psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + call psb_realloc(m,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + end if + call psb_gatherv(ctxt,llocx(1:loc_rows),globx,szs,root=root) + call psb_erractionrestore(err_act) return diff --git a/base/comm/psb_igather.f90 b/base/comm/psb_igather.f90 index afa794eb9..acfdf52aa 100644 --- a/base/comm/psb_igather.f90 +++ b/base/comm/psb_igather.f90 @@ -58,10 +58,11 @@ subroutine psb_igather_vect(globx, locx, desc_a, info, iroot) ! locals type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx integer(psb_ipk_), allocatable :: llocx(:) + integer(psb_mpk_), allocatable :: szs(:) character(len=20) :: name, ch_err name='psb_igatherv' @@ -125,32 +126,34 @@ subroutine psb_igather_vect(globx, locx, desc_a, info, iroot) goto 9999 end if - call psb_realloc(m,globx,info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - globx(:) = izero - llocx = locx%get_vect() - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx) = llocx(i) - end do - + llocx = locx%get_vect() ! adjust overlapped elements do i=1, size(desc_a%ovrlap_elem,1) if (me /= desc_a%ovrlap_elem(i,3)) then idx = desc_a%ovrlap_elem(i,1) - call psb_loc_to_glob(idx,desc_a,info) - globx(idx) = izero + llocx(idx) = izero end if end do - - call psb_sum(ctxt,globx(1:m),root=root) + allocate(szs(np)) + loc_rows = desc_a%get_local_rows() + call psb_gather(ctxt,loc_rows,szs,root=root) + if ((me == root).or.(root == -1)) then + if (sum(szs) /= m) then + info=psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + call psb_realloc(m,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + end if + call psb_gatherv(ctxt,llocx(1:loc_rows),globx,szs,root=root) + call psb_erractionrestore(err_act) return diff --git a/base/comm/psb_lgather.f90 b/base/comm/psb_lgather.f90 index 00af3cd14..17359bce8 100644 --- a/base/comm/psb_lgather.f90 +++ b/base/comm/psb_lgather.f90 @@ -58,10 +58,11 @@ subroutine psb_lgather_vect(globx, locx, desc_a, info, iroot) ! locals type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx integer(psb_lpk_), allocatable :: llocx(:) + integer(psb_mpk_), allocatable :: szs(:) character(len=20) :: name, ch_err name='psb_lgatherv' @@ -125,32 +126,34 @@ subroutine psb_lgather_vect(globx, locx, desc_a, info, iroot) goto 9999 end if - call psb_realloc(m,globx,info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - globx(:) = lzero - llocx = locx%get_vect() - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx) = llocx(i) - end do - + llocx = locx%get_vect() ! adjust overlapped elements do i=1, size(desc_a%ovrlap_elem,1) if (me /= desc_a%ovrlap_elem(i,3)) then idx = desc_a%ovrlap_elem(i,1) - call psb_loc_to_glob(idx,desc_a,info) - globx(idx) = lzero + llocx(idx) = lzero end if end do - - call psb_sum(ctxt,globx(1:m),root=root) + allocate(szs(np)) + loc_rows = desc_a%get_local_rows() + call psb_gather(ctxt,loc_rows,szs,root=root) + if ((me == root).or.(root == -1)) then + if (sum(szs) /= m) then + info=psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + call psb_realloc(m,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + end if + call psb_gatherv(ctxt,llocx(1:loc_rows),globx,szs,root=root) + call psb_erractionrestore(err_act) return diff --git a/base/comm/psb_sgather.f90 b/base/comm/psb_sgather.f90 index 21ce1408f..59cecc175 100644 --- a/base/comm/psb_sgather.f90 +++ b/base/comm/psb_sgather.f90 @@ -58,10 +58,11 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot) ! locals type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx real(psb_spk_), allocatable :: llocx(:) + integer(psb_mpk_), allocatable :: szs(:) character(len=20) :: name, ch_err name='psb_sgatherv' @@ -125,32 +126,34 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot) goto 9999 end if - call psb_realloc(m,globx,info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - globx(:) = szero - llocx = locx%get_vect() - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx) = llocx(i) - end do - + llocx = locx%get_vect() ! adjust overlapped elements do i=1, size(desc_a%ovrlap_elem,1) if (me /= desc_a%ovrlap_elem(i,3)) then idx = desc_a%ovrlap_elem(i,1) - call psb_loc_to_glob(idx,desc_a,info) - globx(idx) = szero + llocx(idx) = szero end if end do - - call psb_sum(ctxt,globx(1:m),root=root) + allocate(szs(np)) + loc_rows = desc_a%get_local_rows() + call psb_gather(ctxt,loc_rows,szs,root=root) + if ((me == root).or.(root == -1)) then + if (sum(szs) /= m) then + info=psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + call psb_realloc(m,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + end if + call psb_gatherv(ctxt,llocx(1:loc_rows),globx,szs,root=root) + call psb_erractionrestore(err_act) return diff --git a/base/comm/psb_zgather.f90 b/base/comm/psb_zgather.f90 index 53cba2105..5cf445a9b 100644 --- a/base/comm/psb_zgather.f90 +++ b/base/comm/psb_zgather.f90 @@ -58,10 +58,11 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot) ! locals type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx complex(psb_dpk_), allocatable :: llocx(:) + integer(psb_mpk_), allocatable :: szs(:) character(len=20) :: name, ch_err name='psb_zgatherv' @@ -125,32 +126,34 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot) goto 9999 end if - call psb_realloc(m,globx,info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - globx(:) = zzero - llocx = locx%get_vect() - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx) = llocx(i) - end do - + llocx = locx%get_vect() ! adjust overlapped elements do i=1, size(desc_a%ovrlap_elem,1) if (me /= desc_a%ovrlap_elem(i,3)) then idx = desc_a%ovrlap_elem(i,1) - call psb_loc_to_glob(idx,desc_a,info) - globx(idx) = zzero + llocx(idx) = zzero end if end do - - call psb_sum(ctxt,globx(1:m),root=root) + allocate(szs(np)) + loc_rows = desc_a%get_local_rows() + call psb_gather(ctxt,loc_rows,szs,root=root) + if ((me == root).or.(root == -1)) then + if (sum(szs) /= m) then + info=psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + call psb_realloc(m,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + end if + call psb_gatherv(ctxt,llocx(1:loc_rows),globx,szs,root=root) + call psb_erractionrestore(err_act) return diff --git a/base/internals/psi_bld_tmphalo.f90 b/base/internals/psi_bld_tmphalo.f90 index 78ce69ed7..9d3fb7aba 100644 --- a/base/internals/psi_bld_tmphalo.f90 +++ b/base/internals/psi_bld_tmphalo.f90 @@ -104,6 +104,7 @@ subroutine psi_bld_tmphalo(desc,info) call desc%indxmap%l2gip(helem(1:nh),info) if (info == psb_success_) call desc%indxmap%fnd_owner(helem(1:nh),hproc,info) + !write(0,*) 'bld_tmphalo calling set_owner',hproc(:) if (info == psb_success_) call desc%indxmap%set_halo_owner(hproc,info) if (info == psb_success_) call desc%indxmap%xtnd_p_adjcncy(hproc) diff --git a/base/modules/Makefile b/base/modules/Makefile index 399add1f0..9c14dab81 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -39,6 +39,7 @@ SERIAL_MODS=serial/psb_s_serial_mod.o serial/psb_d_serial_mod.o \ auxil/psi_c_serial_mod.o auxil/psi_z_serial_mod.o \ psi_mod.o psi_i_mod.o psi_l_mod.o psi_s_mod.o psi_d_mod.o psi_c_mod.o psi_z_mod.o\ auxil/psb_ip_reord_mod.o\ + auxil/psi_acx_mod.o auxil/psi_alcx_mod.o auxil/psi_lcx_mod.o \ auxil/psb_m_ip_reord_mod.o auxil/psb_e_ip_reord_mod.o \ auxil/psb_s_ip_reord_mod.o auxil/psb_d_ip_reord_mod.o \ auxil/psb_c_ip_reord_mod.o auxil/psb_z_ip_reord_mod.o \ @@ -60,11 +61,16 @@ SERIAL_MODS=serial/psb_s_serial_mod.o serial/psb_d_serial_mod.o \ auxil/psb_d_hsort_x_mod.o \ auxil/psb_c_hsort_x_mod.o \ auxil/psb_z_hsort_x_mod.o \ + auxil/psb_s_rb_idx_tree_mod.o \ + auxil/psb_d_rb_idx_tree_mod.o \ + auxil/psb_c_rb_idx_tree_mod.o \ + auxil/psb_z_rb_idx_tree_mod.o \ + auxil/psb_rb_idx_tree_mod.o \ serial/psb_base_mat_mod.o serial/psb_mat_mod.o\ serial/psb_s_base_mat_mod.o serial/psb_s_csr_mat_mod.o serial/psb_s_csc_mat_mod.o serial/psb_s_mat_mod.o \ serial/psb_d_base_mat_mod.o serial/psb_d_csr_mat_mod.o serial/psb_d_csc_mat_mod.o serial/psb_d_mat_mod.o \ serial/psb_c_base_mat_mod.o serial/psb_c_csr_mat_mod.o serial/psb_c_csc_mat_mod.o serial/psb_c_mat_mod.o \ - serial/psb_z_base_mat_mod.o serial/psb_z_csr_mat_mod.o serial/psb_z_csc_mat_mod.o serial/psb_z_mat_mod.o + serial/psb_z_base_mat_mod.o serial/psb_z_csr_mat_mod.o serial/psb_z_csc_mat_mod.o serial/psb_z_mat_mod.o #\ # serial/psb_ls_csr_mat_mod.o serial/psb_ld_csr_mat_mod.o serial/psb_lc_csr_mat_mod.o serial/psb_lz_csr_mat_mod.o #\ @@ -165,6 +171,7 @@ penv/psi_d_collective_mod.o penv/psi_c_collective_mod.o penv/psi_z_collective_m penv/psi_d_p2p_mod.o penv/psi_c_p2p_mod.o penv/psi_z_p2p_mod.o +auxil/psi_acx_mod.o auxil/psi_alcx_mod.o auxil/psi_lcx_mod.o \ auxil/psb_string_mod.o auxil/psb_m_realloc_mod.o auxil/psb_e_realloc_mod.o auxil/psb_s_realloc_mod.o \ auxil/psb_d_realloc_mod.o auxil/psb_c_realloc_mod.o auxil/psb_z_realloc_mod.o \ desc/psb_desc_const_mod.o psi_penv_mod.o: psb_const_mod.o @@ -174,6 +181,7 @@ desc/psb_indx_map_mod.o desc/psb_hash_mod.o: psb_realloc_mod.o psb_const_mod.o auxil/psb_i_sort_mod.o auxil/psb_s_sort_mod.o auxil/psb_d_sort_mod.o auxil/psb_c_sort_mod.o auxil/psb_z_sort_mod.o \ auxil/psb_ip_reord_mod.o auxil/psi_serial_mod.o auxil/psb_sort_mod.o: $(BASIC_MODS) + auxil/psb_sort_mod.o: auxil/psb_m_hsort_mod.o auxil/psb_m_isort_mod.o \ auxil/psb_m_msort_mod.o auxil/psb_m_qsort_mod.o \ auxil/psb_e_hsort_mod.o auxil/psb_e_isort_mod.o \ @@ -192,7 +200,8 @@ auxil/psb_sort_mod.o: auxil/psb_m_hsort_mod.o auxil/psb_m_isort_mod.o \ auxil/psb_d_hsort_x_mod.o \ auxil/psb_c_hsort_x_mod.o \ auxil/psb_z_hsort_x_mod.o \ - auxil/psb_ip_reord_mod.o auxil/psi_serial_mod.o + auxil/psb_ip_reord_mod.o \ + auxil/psi_serial_mod.o auxil/psb_m_hsort_mod.o auxil/psb_m_isort_mod.o \ auxil/psb_m_msort_mod.o auxil/psb_m_qsort_mod.o \ @@ -225,7 +234,10 @@ auxil/psb_c_hsort_x_mod.o: auxil/psb_c_hsort_mod.o auxil/psb_z_hsort_x_mod.o: auxil/psb_z_hsort_mod.o auxil/psi_serial_mod.o: auxil/psi_m_serial_mod.o auxil/psi_e_serial_mod.o \ - auxil/psi_s_serial_mod.o auxil/psi_d_serial_mod.o auxil/psi_c_serial_mod.o auxil/psi_z_serial_mod.o + auxil/psi_s_serial_mod.o auxil/psi_d_serial_mod.o\ + auxil/psi_c_serial_mod.o auxil/psi_z_serial_mod.o \ + auxil/psi_acx_mod.o auxil/psi_alcx_mod.o auxil/psi_lcx_mod.o + auxil/psi_m_serial_mod.o auxil/psi_e_serial_mod.o auxil/psi_s_serial_mod.o auxil/psi_d_serial_mod.o auxil/psi_c_serial_mod.o auxil/psi_z_serial_mod.o: psb_const_mod.o auxil/psb_ip_reord_mod.o: auxil/psb_m_ip_reord_mod.o auxil/psb_e_ip_reord_mod.o \ @@ -270,6 +282,12 @@ serial/psb_z_vect_mod.o: serial/psb_z_base_vect_mod.o serial/psb_i_vect_mod.o serial/psb_s_serial_mod.o serial/psb_d_serial_mod.o serial/psb_c_serial_mod.o serial/psb_z_serial_mod.o: serial/psb_mat_mod.o auxil/psb_string_mod.o auxil/psb_sort_mod.o auxil/psi_serial_mod.o serial/psb_vect_mod.o: serial/psb_i_vect_mod.o serial/psb_l_vect_mod.o serial/psb_d_vect_mod.o serial/psb_s_vect_mod.o serial/psb_c_vect_mod.o serial/psb_z_vect_mod.o +auxil/psb_s_rb_idx_tree_mod.o: serial/psb_s_csr_mat_mod.o psb_realloc_mod.o +auxil/psb_d_rb_idx_tree_mod.o: serial/psb_d_csr_mat_mod.o psb_realloc_mod.o +auxil/psb_c_rb_idx_tree_mod.o: serial/psb_c_csr_mat_mod.o psb_realloc_mod.o +auxil/psb_z_rb_idx_tree_mod.o: serial/psb_z_csr_mat_mod.o psb_realloc_mod.o +auxil/psb_rb_idx_tree_mod.o: auxil/psb_s_rb_idx_tree_mod.o auxil/psb_d_rb_idx_tree_mod.o auxil/psb_c_rb_idx_tree_mod.o auxil/psb_z_rb_idx_tree_mod.o + error.o psb_realloc_mod.o: psb_error_mod.o psb_error_impl.o: psb_penv_mod.o psb_timers_mod.o: psb_penv_mod.o psb_const_mod.o psb_realloc_mod.o psb_error_mod.o diff --git a/base/modules/auxil/psb_c_hsort_x_mod.f90 b/base/modules/auxil/psb_c_hsort_x_mod.f90 index c0e39411e..8f0437f7c 100644 --- a/base/modules/auxil/psb_c_hsort_x_mod.f90 +++ b/base/modules/auxil/psb_c_hsort_x_mod.f90 @@ -123,7 +123,7 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_ipk_)*psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 @@ -236,9 +236,9 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_ipk_)*psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info) if (info == psb_success_) & - & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=(1_psb_ipk_)*psb_heap_resize) + & call psb_ensure_size(heap%last+1,heap%idxs,info) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 diff --git a/base/modules/auxil/psb_c_qsort_mod.f90 b/base/modules/auxil/psb_c_qsort_mod.f90 index 8b365222c..6c4ceb3f8 100644 --- a/base/modules/auxil/psb_c_qsort_mod.f90 +++ b/base/modules/auxil/psb_c_qsort_mod.f90 @@ -44,7 +44,6 @@ module psb_c_qsort_mod use psb_const_mod - interface psb_qsort subroutine psb_cqsort(x,ix,dir,flag) import diff --git a/base/modules/auxil/psb_c_rb_idx_tree_mod.f90 b/base/modules/auxil/psb_c_rb_idx_tree_mod.f90 new file mode 100644 index 000000000..9b3ada6e4 --- /dev/null +++ b/base/modules/auxil/psb_c_rb_idx_tree_mod.f90 @@ -0,0 +1,128 @@ +! +! 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. +! +! +! +! package: psb_c_rb_idx_tree_mod +! +! Red black tree implementation ordered by index +! +! Each node contains and index and a double precision value +! +! The tree should always be well balanced +! +! inserting a node with an existing index will +! add up the new value to the old one +! Contributed by Dimitri Walther +! +module psb_c_rb_idx_tree_mod + use psb_const_mod + implicit none + + type :: psb_c_rb_idx_node + integer(psb_ipk_) :: idx + complex(psb_spk_) :: val + type(psb_c_rb_idx_node), pointer :: left, right, parent + logical :: is_red + end type psb_c_rb_idx_node + + type :: psb_c_rb_idx_tree + type(psb_c_rb_idx_node), pointer :: root + integer(psb_ipk_) :: nnz + + contains + + procedure :: insert => psb_c_rb_idx_tree_insert + end type psb_c_rb_idx_tree + + interface psb_rb_idx_tree_insert + subroutine psb_c_rb_idx_tree_insert(this, idx, val) + import :: psb_ipk_, psb_spk_, psb_c_rb_idx_tree + implicit none + class(psb_c_rb_idx_tree), intent(inout) :: this + integer(psb_ipk_), intent(in) :: idx + complex(psb_spk_), intent(in) :: val + end subroutine psb_c_rb_idx_tree_insert + end interface psb_rb_idx_tree_insert + + interface psb_rb_idx_tree_scalar_sparse_row_mul + subroutine psb_c_rb_idx_tree_scalar_sparse_row_mul(tree, scalar, mat, row_num) + use psb_c_csr_mat_mod, only : psb_c_csr_sparse_mat + import :: psb_ipk_, psb_spk_, psb_c_rb_idx_tree + implicit none + type(psb_c_rb_idx_tree), intent(inout) :: tree + complex(psb_spk_), intent(in) :: scalar + type(psb_c_csr_sparse_mat), intent(in) :: mat + integer(psb_ipk_), intent(in) :: row_num + end subroutine psb_c_rb_idx_tree_scalar_sparse_row_mul + end interface psb_rb_idx_tree_scalar_sparse_row_mul + + interface psb_rb_idx_tree_merge + subroutine psb_c_rb_idx_tree_merge(trees, mat) + use psb_c_csr_mat_mod, only : psb_c_csr_sparse_mat + import :: psb_c_rb_idx_tree + type(psb_c_rb_idx_tree), allocatable, intent(inout) :: trees(:) + type(psb_c_csr_sparse_mat), intent(inout) :: mat + end subroutine psb_c_rb_idx_tree_merge + end interface psb_rb_idx_tree_merge + + interface psb_rb_idx_tree_fix_insertion + subroutine psb_c_rb_idx_tree_fix_insertion(this, node) + import :: psb_c_rb_idx_tree, psb_c_rb_idx_node + implicit none + class(psb_c_rb_idx_tree), intent(inout) :: this + type(psb_c_rb_idx_node), pointer, intent(inout) :: node + end subroutine psb_c_rb_idx_tree_fix_insertion + end interface psb_rb_idx_tree_fix_insertion + + interface psb_rb_idx_tree_swap_colors + subroutine psb_c_rb_idx_tree_swap_colors(n1, n2) + import :: psb_c_rb_idx_node + implicit none + type(psb_c_rb_idx_node), pointer, intent(inout) :: n1, n2 + end subroutine psb_c_rb_idx_tree_swap_colors + end interface psb_rb_idx_tree_swap_colors + + interface psb_rb_idx_tree_rotate_right + subroutine psb_c_rb_idx_tree_rotate_right(node) + import :: psb_c_rb_idx_node + implicit none + type(psb_c_rb_idx_node), pointer, intent(inout) :: node + end subroutine psb_c_rb_idx_tree_rotate_right + end interface psb_rb_idx_tree_rotate_right + + interface psb_rb_idx_tree_rotate_left + subroutine psb_c_rb_idx_tree_rotate_left(node) + import :: psb_c_rb_idx_node + implicit none + type(psb_c_rb_idx_node), pointer, intent(inout) :: node + end subroutine psb_c_rb_idx_tree_rotate_left + end interface psb_rb_idx_tree_rotate_left +end module psb_c_rb_idx_tree_mod diff --git a/base/modules/auxil/psb_c_realloc_mod.F90 b/base/modules/auxil/psb_c_realloc_mod.F90 index 9e6af5a88..9b22bee78 100644 --- a/base/modules/auxil/psb_c_realloc_mod.F90 +++ b/base/modules/auxil/psb_c_realloc_mod.F90 @@ -768,7 +768,7 @@ Contains integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz,err_act,lb + integer(psb_ipk_) :: isz,err_act,lb, i character(len=30) :: name, char_err logical, parameter :: debug=.false. @@ -790,7 +790,11 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else - vout(:) = vin(:) + !$omp parallel do private(i) + do i=lb,lb+isz-1 + vout(i) = vin(i) + end do + !$omp end parallel do endif endif @@ -836,7 +840,9 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:,:) = vin(:,:) + !$omp end workshare endif endif @@ -991,36 +997,17 @@ Contains goto 9999 end if -!!$ If (len > psb_size(v)) Then -!!$ if (present(newsz)) then -!!$ isz = (max(len+1,newsz)) -!!$ else -!!$ if (present(addsz)) then -!!$ isz = len+max(1,addsz) -!!$ else -!!$ isz = max(len+10, int(1.25*len)) -!!$ endif -!!$ endif -!!$ -!!$ call psb_realloc(isz,v,info,pad=pad) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_realloc') -!!$ goto 9999 -!!$ End If -!!$ end If - If (len > psb_size(v)) Then + isz = psb_size(v) + If (len > isz) Then #if defined(OPENMP) !$OMP CRITICAL - if (len > psb_size(v)) then + if (len > isz) then if (present(newsz)) then - isz = (max(len+1,newsz)) + isz = max(len+1,1,newsz) + else if (present(addsz)) then + isz = max(len,1,isz+addsz) else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif + isz = max(len,1,int(1.25*isz)) endif call psb_realloc(isz,v,info,pad=pad) @@ -1033,17 +1020,18 @@ Contains goto 9999 end if #else - if (present(newsz)) then - isz = (max(len+1,newsz)) - else - if (present(addsz)) then - isz = len+max(1,addsz) + if (len > isz) then + if (present(newsz)) then + isz = max(len+1,1,newsz) + else if (present(addsz)) then + isz = max(len,1,isz+addsz) else - isz = max(len+10, int(1.25*len)) + isz = max(len,1,int(1.25*isz)) endif - endif - call psb_realloc(isz,v,info,pad=pad) + call psb_realloc(isz,v,info,pad=pad) + end if + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') @@ -1085,16 +1073,14 @@ Contains info=psb_err_from_subroutine_ goto 9999 end if - - If (len > psb_size(v)) Then - if (present(newsz)) then - isz = (max(len+1,newsz)) + isz = psb_size(v) + If (len > isz) Then + if (present(newsz)) then + isz = max(len+1,1,newsz) + else if (present(addsz)) then + isz = max(len,1,isz+addsz) else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif + isz = max(len,1,int(1.25*isz)) endif call psb_realloc(isz,v,info,pad=pad) diff --git a/base/modules/auxil/psb_d_hsort_x_mod.f90 b/base/modules/auxil/psb_d_hsort_x_mod.f90 index 7273e972f..ba45d6833 100644 --- a/base/modules/auxil/psb_d_hsort_x_mod.f90 +++ b/base/modules/auxil/psb_d_hsort_x_mod.f90 @@ -123,7 +123,7 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_ipk_)*psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 @@ -236,9 +236,9 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_ipk_)*psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info) if (info == psb_success_) & - & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=(1_psb_ipk_)*psb_heap_resize) + & call psb_ensure_size(heap%last+1,heap%idxs,info) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 diff --git a/base/modules/auxil/psb_d_qsort_mod.f90 b/base/modules/auxil/psb_d_qsort_mod.f90 index 4e1be1d1f..4da0b840a 100644 --- a/base/modules/auxil/psb_d_qsort_mod.f90 +++ b/base/modules/auxil/psb_d_qsort_mod.f90 @@ -43,14 +43,13 @@ module psb_d_qsort_mod use psb_const_mod - - interface psb_bsrch - function psb_dbsrch(key,n,v) result(ipos) + function psb_dbsrch(key,n,v,dir,find) result(ipos) import integer(psb_ipk_) :: ipos, n real(psb_dpk_) :: key real(psb_dpk_) :: v(:) + integer(psb_ipk_), optional :: dir, find end function psb_dbsrch end interface psb_bsrch diff --git a/base/modules/auxil/psb_d_rb_idx_tree_mod.f90 b/base/modules/auxil/psb_d_rb_idx_tree_mod.f90 new file mode 100644 index 000000000..099d1a305 --- /dev/null +++ b/base/modules/auxil/psb_d_rb_idx_tree_mod.f90 @@ -0,0 +1,128 @@ +! +! 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. +! +! +! +! package: psb_d_rb_idx_tree_mod +! +! Red black tree implementation ordered by index +! +! Each node contains and index and a double precision value +! +! The tree should always be well balanced +! +! inserting a node with an existing index will +! add up the new value to the old one +! Contributed by Dimitri Walther +! +module psb_d_rb_idx_tree_mod + use psb_const_mod + implicit none + + type :: psb_d_rb_idx_node + integer(psb_ipk_) :: idx + real(psb_dpk_) :: val + type(psb_d_rb_idx_node), pointer :: left, right, parent + logical :: is_red + end type psb_d_rb_idx_node + + type :: psb_d_rb_idx_tree + type(psb_d_rb_idx_node), pointer :: root + integer(psb_ipk_) :: nnz + + contains + + procedure :: insert => psb_d_rb_idx_tree_insert + end type psb_d_rb_idx_tree + + interface psb_rb_idx_tree_insert + subroutine psb_d_rb_idx_tree_insert(this, idx, val) + import :: psb_ipk_, psb_dpk_, psb_d_rb_idx_tree + implicit none + class(psb_d_rb_idx_tree), intent(inout) :: this + integer(psb_ipk_), intent(in) :: idx + real(psb_dpk_), intent(in) :: val + end subroutine psb_d_rb_idx_tree_insert + end interface psb_rb_idx_tree_insert + + interface psb_rb_idx_tree_scalar_sparse_row_mul + subroutine psb_d_rb_idx_tree_scalar_sparse_row_mul(tree, scalar, mat, row_num) + use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat + import :: psb_ipk_, psb_dpk_, psb_d_rb_idx_tree + implicit none + type(psb_d_rb_idx_tree), intent(inout) :: tree + real(psb_dpk_), intent(in) :: scalar + type(psb_d_csr_sparse_mat), intent(in) :: mat + integer(psb_ipk_), intent(in) :: row_num + end subroutine psb_d_rb_idx_tree_scalar_sparse_row_mul + end interface psb_rb_idx_tree_scalar_sparse_row_mul + + interface psb_rb_idx_tree_merge + subroutine psb_d_rb_idx_tree_merge(trees, mat) + use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat + import :: psb_d_rb_idx_tree + type(psb_d_rb_idx_tree), allocatable, intent(inout) :: trees(:) + type(psb_d_csr_sparse_mat), intent(inout) :: mat + end subroutine psb_d_rb_idx_tree_merge + end interface psb_rb_idx_tree_merge + + interface psb_rb_idx_tree_fix_insertion + subroutine psb_d_rb_idx_tree_fix_insertion(this, node) + import :: psb_d_rb_idx_tree, psb_d_rb_idx_node + implicit none + class(psb_d_rb_idx_tree), intent(inout) :: this + type(psb_d_rb_idx_node), pointer, intent(inout) :: node + end subroutine psb_d_rb_idx_tree_fix_insertion + end interface psb_rb_idx_tree_fix_insertion + + interface psb_rb_idx_tree_swap_colors + subroutine psb_d_rb_idx_tree_swap_colors(n1, n2) + import :: psb_d_rb_idx_node + implicit none + type(psb_d_rb_idx_node), pointer, intent(inout) :: n1, n2 + end subroutine psb_d_rb_idx_tree_swap_colors + end interface psb_rb_idx_tree_swap_colors + + interface psb_rb_idx_tree_rotate_right + subroutine psb_d_rb_idx_tree_rotate_right(node) + import :: psb_d_rb_idx_node + implicit none + type(psb_d_rb_idx_node), pointer, intent(inout) :: node + end subroutine psb_d_rb_idx_tree_rotate_right + end interface psb_rb_idx_tree_rotate_right + + interface psb_rb_idx_tree_rotate_left + subroutine psb_d_rb_idx_tree_rotate_left(node) + import :: psb_d_rb_idx_node + implicit none + type(psb_d_rb_idx_node), pointer, intent(inout) :: node + end subroutine psb_d_rb_idx_tree_rotate_left + end interface psb_rb_idx_tree_rotate_left +end module psb_d_rb_idx_tree_mod diff --git a/base/modules/auxil/psb_d_realloc_mod.F90 b/base/modules/auxil/psb_d_realloc_mod.F90 index 672b4677f..ca85e0ec0 100644 --- a/base/modules/auxil/psb_d_realloc_mod.F90 +++ b/base/modules/auxil/psb_d_realloc_mod.F90 @@ -768,7 +768,7 @@ Contains integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz,err_act,lb + integer(psb_ipk_) :: isz,err_act,lb, i character(len=30) :: name, char_err logical, parameter :: debug=.false. @@ -790,7 +790,11 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else - vout(:) = vin(:) + !$omp parallel do private(i) + do i=lb,lb+isz-1 + vout(i) = vin(i) + end do + !$omp end parallel do endif endif @@ -836,7 +840,9 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:,:) = vin(:,:) + !$omp end workshare endif endif @@ -991,36 +997,17 @@ Contains goto 9999 end if -!!$ If (len > psb_size(v)) Then -!!$ if (present(newsz)) then -!!$ isz = (max(len+1,newsz)) -!!$ else -!!$ if (present(addsz)) then -!!$ isz = len+max(1,addsz) -!!$ else -!!$ isz = max(len+10, int(1.25*len)) -!!$ endif -!!$ endif -!!$ -!!$ call psb_realloc(isz,v,info,pad=pad) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_realloc') -!!$ goto 9999 -!!$ End If -!!$ end If - If (len > psb_size(v)) Then + isz = psb_size(v) + If (len > isz) Then #if defined(OPENMP) !$OMP CRITICAL - if (len > psb_size(v)) then + if (len > isz) then if (present(newsz)) then - isz = (max(len+1,newsz)) + isz = max(len+1,1,newsz) + else if (present(addsz)) then + isz = max(len,1,isz+addsz) else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif + isz = max(len,1,int(1.25*isz)) endif call psb_realloc(isz,v,info,pad=pad) @@ -1033,17 +1020,18 @@ Contains goto 9999 end if #else - if (present(newsz)) then - isz = (max(len+1,newsz)) - else - if (present(addsz)) then - isz = len+max(1,addsz) + if (len > isz) then + if (present(newsz)) then + isz = max(len+1,1,newsz) + else if (present(addsz)) then + isz = max(len,1,isz+addsz) else - isz = max(len+10, int(1.25*len)) + isz = max(len,1,int(1.25*isz)) endif - endif - call psb_realloc(isz,v,info,pad=pad) + call psb_realloc(isz,v,info,pad=pad) + end if + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') @@ -1085,16 +1073,14 @@ Contains info=psb_err_from_subroutine_ goto 9999 end if - - If (len > psb_size(v)) Then - if (present(newsz)) then - isz = (max(len+1,newsz)) + isz = psb_size(v) + If (len > isz) Then + if (present(newsz)) then + isz = max(len+1,1,newsz) + else if (present(addsz)) then + isz = max(len,1,isz+addsz) else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif + isz = max(len,1,int(1.25*isz)) endif call psb_realloc(isz,v,info,pad=pad) diff --git a/base/modules/auxil/psb_e_qsort_mod.f90 b/base/modules/auxil/psb_e_qsort_mod.f90 index 17943bbf8..09f45d459 100644 --- a/base/modules/auxil/psb_e_qsort_mod.f90 +++ b/base/modules/auxil/psb_e_qsort_mod.f90 @@ -43,14 +43,13 @@ module psb_e_qsort_mod use psb_const_mod - - interface psb_bsrch - function psb_ebsrch(key,n,v) result(ipos) + function psb_ebsrch(key,n,v,dir,find) result(ipos) import integer(psb_ipk_) :: ipos, n integer(psb_epk_) :: key integer(psb_epk_) :: v(:) + integer(psb_ipk_), optional :: dir, find end function psb_ebsrch end interface psb_bsrch diff --git a/base/modules/auxil/psb_e_realloc_mod.F90 b/base/modules/auxil/psb_e_realloc_mod.F90 index 0f2431fde..06a6d0348 100644 --- a/base/modules/auxil/psb_e_realloc_mod.F90 +++ b/base/modules/auxil/psb_e_realloc_mod.F90 @@ -768,7 +768,7 @@ Contains integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz,err_act,lb + integer(psb_ipk_) :: isz,err_act,lb, i character(len=30) :: name, char_err logical, parameter :: debug=.false. @@ -790,7 +790,11 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else - vout(:) = vin(:) + !$omp parallel do private(i) + do i=lb,lb+isz-1 + vout(i) = vin(i) + end do + !$omp end parallel do endif endif @@ -836,7 +840,9 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:,:) = vin(:,:) + !$omp end workshare endif endif @@ -991,36 +997,17 @@ Contains goto 9999 end if -!!$ If (len > psb_size(v)) Then -!!$ if (present(newsz)) then -!!$ isz = (max(len+1,newsz)) -!!$ else -!!$ if (present(addsz)) then -!!$ isz = len+max(1,addsz) -!!$ else -!!$ isz = max(len+10, int(1.25*len)) -!!$ endif -!!$ endif -!!$ -!!$ call psb_realloc(isz,v,info,pad=pad) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_realloc') -!!$ goto 9999 -!!$ End If -!!$ end If - If (len > psb_size(v)) Then + isz = psb_size(v) + If (len > isz) Then #if defined(OPENMP) !$OMP CRITICAL - if (len > psb_size(v)) then + if (len > isz) then if (present(newsz)) then - isz = (max(len+1,newsz)) + isz = max(len+1,1,newsz) + else if (present(addsz)) then + isz = max(len,1,isz+addsz) else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif + isz = max(len,1,int(1.25*isz)) endif call psb_realloc(isz,v,info,pad=pad) @@ -1033,17 +1020,18 @@ Contains goto 9999 end if #else - if (present(newsz)) then - isz = (max(len+1,newsz)) - else - if (present(addsz)) then - isz = len+max(1,addsz) + if (len > isz) then + if (present(newsz)) then + isz = max(len+1,1,newsz) + else if (present(addsz)) then + isz = max(len,1,isz+addsz) else - isz = max(len+10, int(1.25*len)) + isz = max(len,1,int(1.25*isz)) endif - endif - call psb_realloc(isz,v,info,pad=pad) + call psb_realloc(isz,v,info,pad=pad) + end if + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') @@ -1085,16 +1073,14 @@ Contains info=psb_err_from_subroutine_ goto 9999 end if - - If (len > psb_size(v)) Then - if (present(newsz)) then - isz = (max(len+1,newsz)) + isz = psb_size(v) + If (len > isz) Then + if (present(newsz)) then + isz = max(len+1,1,newsz) + else if (present(addsz)) then + isz = max(len,1,isz+addsz) else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif + isz = max(len,1,int(1.25*isz)) endif call psb_realloc(isz,v,info,pad=pad) diff --git a/base/modules/auxil/psb_i2_qsort_mod.f90 b/base/modules/auxil/psb_i2_qsort_mod.f90 index 944a436ec..2f192a0a2 100644 --- a/base/modules/auxil/psb_i2_qsort_mod.f90 +++ b/base/modules/auxil/psb_i2_qsort_mod.f90 @@ -43,14 +43,13 @@ module psb_i2_qsort_mod use psb_const_mod - - interface psb_bsrch - function psb_i2bsrch(key,n,v) result(ipos) + function psb_i2bsrch(key,n,v,dir,find) result(ipos) import integer(psb_ipk_) :: ipos, n integer(psb_i2pk_) :: key integer(psb_i2pk_) :: v(:) + integer(psb_ipk_), optional :: dir, find end function psb_i2bsrch end interface psb_bsrch diff --git a/base/modules/auxil/psb_i2_realloc_mod.F90 b/base/modules/auxil/psb_i2_realloc_mod.F90 index 22e85d36d..146bdf7e1 100644 --- a/base/modules/auxil/psb_i2_realloc_mod.F90 +++ b/base/modules/auxil/psb_i2_realloc_mod.F90 @@ -768,7 +768,7 @@ Contains integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz,err_act,lb + integer(psb_ipk_) :: isz,err_act,lb, i character(len=30) :: name, char_err logical, parameter :: debug=.false. @@ -790,7 +790,11 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else - vout(:) = vin(:) + !$omp parallel do private(i) + do i=lb,lb+isz-1 + vout(i) = vin(i) + end do + !$omp end parallel do endif endif @@ -836,7 +840,9 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:,:) = vin(:,:) + !$omp end workshare endif endif @@ -991,36 +997,17 @@ Contains goto 9999 end if -!!$ If (len > psb_size(v)) Then -!!$ if (present(newsz)) then -!!$ isz = (max(len+1,newsz)) -!!$ else -!!$ if (present(addsz)) then -!!$ isz = len+max(1,addsz) -!!$ else -!!$ isz = max(len+10, int(1.25*len)) -!!$ endif -!!$ endif -!!$ -!!$ call psb_realloc(isz,v,info,pad=pad) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_realloc') -!!$ goto 9999 -!!$ End If -!!$ end If - If (len > psb_size(v)) Then + isz = psb_size(v) + If (len > isz) Then #if defined(OPENMP) !$OMP CRITICAL - if (len > psb_size(v)) then + if (len > isz) then if (present(newsz)) then - isz = (max(len+1,newsz)) + isz = max(len+1,1,newsz) + else if (present(addsz)) then + isz = max(len,1,isz+addsz) else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif + isz = max(len,1,int(1.25*isz)) endif call psb_realloc(isz,v,info,pad=pad) @@ -1033,17 +1020,18 @@ Contains goto 9999 end if #else - if (present(newsz)) then - isz = (max(len+1,newsz)) - else - if (present(addsz)) then - isz = len+max(1,addsz) + if (len > isz) then + if (present(newsz)) then + isz = max(len+1,1,newsz) + else if (present(addsz)) then + isz = max(len,1,isz+addsz) else - isz = max(len+10, int(1.25*len)) + isz = max(len,1,int(1.25*isz)) endif - endif - call psb_realloc(isz,v,info,pad=pad) + call psb_realloc(isz,v,info,pad=pad) + end if + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') @@ -1085,16 +1073,14 @@ Contains info=psb_err_from_subroutine_ goto 9999 end if - - If (len > psb_size(v)) Then - if (present(newsz)) then - isz = (max(len+1,newsz)) + isz = psb_size(v) + If (len > isz) Then + if (present(newsz)) then + isz = max(len+1,1,newsz) + else if (present(addsz)) then + isz = max(len,1,isz+addsz) else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif + isz = max(len,1,int(1.25*isz)) endif call psb_realloc(isz,v,info,pad=pad) diff --git a/base/modules/auxil/psb_i_hsort_x_mod.f90 b/base/modules/auxil/psb_i_hsort_x_mod.f90 index 0d1288a62..4bbc3d7f8 100644 --- a/base/modules/auxil/psb_i_hsort_x_mod.f90 +++ b/base/modules/auxil/psb_i_hsort_x_mod.f90 @@ -124,7 +124,7 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_ipk_)*psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 @@ -237,9 +237,9 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_ipk_)*psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info) if (info == psb_success_) & - & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=(1_psb_ipk_)*psb_heap_resize) + & call psb_ensure_size(heap%last+1,heap%idxs,info) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 diff --git a/base/modules/auxil/psb_l_hsort_x_mod.f90 b/base/modules/auxil/psb_l_hsort_x_mod.f90 index 487e8ce90..5134d6bb7 100644 --- a/base/modules/auxil/psb_l_hsort_x_mod.f90 +++ b/base/modules/auxil/psb_l_hsort_x_mod.f90 @@ -124,7 +124,7 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_lpk_)*psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 @@ -237,9 +237,9 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_lpk_)*psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info) if (info == psb_success_) & - & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=(1_psb_lpk_)*psb_heap_resize) + & call psb_ensure_size(heap%last+1,heap%idxs,info) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 diff --git a/base/modules/auxil/psb_m_qsort_mod.f90 b/base/modules/auxil/psb_m_qsort_mod.f90 index cb4c81c1d..bf029065d 100644 --- a/base/modules/auxil/psb_m_qsort_mod.f90 +++ b/base/modules/auxil/psb_m_qsort_mod.f90 @@ -43,14 +43,13 @@ module psb_m_qsort_mod use psb_const_mod - - interface psb_bsrch - function psb_mbsrch(key,n,v) result(ipos) + function psb_mbsrch(key,n,v,dir,find) result(ipos) import integer(psb_ipk_) :: ipos, n integer(psb_mpk_) :: key integer(psb_mpk_) :: v(:) + integer(psb_ipk_), optional :: dir, find end function psb_mbsrch end interface psb_bsrch diff --git a/base/modules/auxil/psb_m_realloc_mod.F90 b/base/modules/auxil/psb_m_realloc_mod.F90 index c81ed83af..4d2f93160 100644 --- a/base/modules/auxil/psb_m_realloc_mod.F90 +++ b/base/modules/auxil/psb_m_realloc_mod.F90 @@ -768,7 +768,7 @@ Contains integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz,err_act,lb + integer(psb_ipk_) :: isz,err_act,lb, i character(len=30) :: name, char_err logical, parameter :: debug=.false. @@ -790,7 +790,11 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else - vout(:) = vin(:) + !$omp parallel do private(i) + do i=lb,lb+isz-1 + vout(i) = vin(i) + end do + !$omp end parallel do endif endif @@ -836,7 +840,9 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:,:) = vin(:,:) + !$omp end workshare endif endif @@ -991,36 +997,17 @@ Contains goto 9999 end if -!!$ If (len > psb_size(v)) Then -!!$ if (present(newsz)) then -!!$ isz = (max(len+1,newsz)) -!!$ else -!!$ if (present(addsz)) then -!!$ isz = len+max(1,addsz) -!!$ else -!!$ isz = max(len+10, int(1.25*len)) -!!$ endif -!!$ endif -!!$ -!!$ call psb_realloc(isz,v,info,pad=pad) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_realloc') -!!$ goto 9999 -!!$ End If -!!$ end If - If (len > psb_size(v)) Then + isz = psb_size(v) + If (len > isz) Then #if defined(OPENMP) !$OMP CRITICAL - if (len > psb_size(v)) then + if (len > isz) then if (present(newsz)) then - isz = (max(len+1,newsz)) + isz = max(len+1,1,newsz) + else if (present(addsz)) then + isz = max(len,1,isz+addsz) else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif + isz = max(len,1,int(1.25*isz)) endif call psb_realloc(isz,v,info,pad=pad) @@ -1033,17 +1020,18 @@ Contains goto 9999 end if #else - if (present(newsz)) then - isz = (max(len+1,newsz)) - else - if (present(addsz)) then - isz = len+max(1,addsz) + if (len > isz) then + if (present(newsz)) then + isz = max(len+1,1,newsz) + else if (present(addsz)) then + isz = max(len,1,isz+addsz) else - isz = max(len+10, int(1.25*len)) + isz = max(len,1,int(1.25*isz)) endif - endif - call psb_realloc(isz,v,info,pad=pad) + call psb_realloc(isz,v,info,pad=pad) + end if + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') @@ -1085,16 +1073,14 @@ Contains info=psb_err_from_subroutine_ goto 9999 end if - - If (len > psb_size(v)) Then - if (present(newsz)) then - isz = (max(len+1,newsz)) + isz = psb_size(v) + If (len > isz) Then + if (present(newsz)) then + isz = max(len+1,1,newsz) + else if (present(addsz)) then + isz = max(len,1,isz+addsz) else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif + isz = max(len,1,int(1.25*isz)) endif call psb_realloc(isz,v,info,pad=pad) diff --git a/base/modules/auxil/psb_rb_idx_tree_mod.f90 b/base/modules/auxil/psb_rb_idx_tree_mod.f90 new file mode 100644 index 000000000..074255eaa --- /dev/null +++ b/base/modules/auxil/psb_rb_idx_tree_mod.f90 @@ -0,0 +1,52 @@ +! +! 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. +! +! +! +! package: psb_rb_idx_tree_mod +! +! Red black tree implementation ordered by index +! +! Each node contains and index and a double precision value +! +! The tree should always be well balanced +! +! inserting a node with an existing index will +! add up the new value to the old one +! Contributed by Dimitri Walther +! +module psb_rb_idx_tree_mod + use psb_const_mod + + use psb_s_rb_idx_tree_mod + use psb_d_rb_idx_tree_mod + use psb_c_rb_idx_tree_mod + use psb_z_rb_idx_tree_mod +end module psb_rb_idx_tree_mod diff --git a/base/modules/auxil/psb_s_hsort_x_mod.f90 b/base/modules/auxil/psb_s_hsort_x_mod.f90 index 34f69ea4c..204dbbf4e 100644 --- a/base/modules/auxil/psb_s_hsort_x_mod.f90 +++ b/base/modules/auxil/psb_s_hsort_x_mod.f90 @@ -123,7 +123,7 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_ipk_)*psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 @@ -236,9 +236,9 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_ipk_)*psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info) if (info == psb_success_) & - & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=(1_psb_ipk_)*psb_heap_resize) + & call psb_ensure_size(heap%last+1,heap%idxs,info) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 diff --git a/base/modules/auxil/psb_s_qsort_mod.f90 b/base/modules/auxil/psb_s_qsort_mod.f90 index d4851fd1b..a5bdb2d99 100644 --- a/base/modules/auxil/psb_s_qsort_mod.f90 +++ b/base/modules/auxil/psb_s_qsort_mod.f90 @@ -43,14 +43,13 @@ module psb_s_qsort_mod use psb_const_mod - - interface psb_bsrch - function psb_sbsrch(key,n,v) result(ipos) + function psb_sbsrch(key,n,v,dir,find) result(ipos) import integer(psb_ipk_) :: ipos, n real(psb_spk_) :: key real(psb_spk_) :: v(:) + integer(psb_ipk_), optional :: dir, find end function psb_sbsrch end interface psb_bsrch diff --git a/base/modules/auxil/psb_s_rb_idx_tree_mod.f90 b/base/modules/auxil/psb_s_rb_idx_tree_mod.f90 new file mode 100644 index 000000000..3ed2d60a4 --- /dev/null +++ b/base/modules/auxil/psb_s_rb_idx_tree_mod.f90 @@ -0,0 +1,128 @@ +! +! 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. +! +! +! +! package: psb_s_rb_idx_tree_mod +! +! Red black tree implementation ordered by index +! +! Each node contains and index and a double precision value +! +! The tree should always be well balanced +! +! inserting a node with an existing index will +! add up the new value to the old one +! Contributed by Dimitri Walther +! +module psb_s_rb_idx_tree_mod + use psb_const_mod + implicit none + + type :: psb_s_rb_idx_node + integer(psb_ipk_) :: idx + real(psb_spk_) :: val + type(psb_s_rb_idx_node), pointer :: left, right, parent + logical :: is_red + end type psb_s_rb_idx_node + + type :: psb_s_rb_idx_tree + type(psb_s_rb_idx_node), pointer :: root + integer(psb_ipk_) :: nnz + + contains + + procedure :: insert => psb_s_rb_idx_tree_insert + end type psb_s_rb_idx_tree + + interface psb_rb_idx_tree_insert + subroutine psb_s_rb_idx_tree_insert(this, idx, val) + import :: psb_ipk_, psb_spk_, psb_s_rb_idx_tree + implicit none + class(psb_s_rb_idx_tree), intent(inout) :: this + integer(psb_ipk_), intent(in) :: idx + real(psb_spk_), intent(in) :: val + end subroutine psb_s_rb_idx_tree_insert + end interface psb_rb_idx_tree_insert + + interface psb_rb_idx_tree_scalar_sparse_row_mul + subroutine psb_s_rb_idx_tree_scalar_sparse_row_mul(tree, scalar, mat, row_num) + use psb_s_csr_mat_mod, only : psb_s_csr_sparse_mat + import :: psb_ipk_, psb_spk_, psb_s_rb_idx_tree + implicit none + type(psb_s_rb_idx_tree), intent(inout) :: tree + real(psb_spk_), intent(in) :: scalar + type(psb_s_csr_sparse_mat), intent(in) :: mat + integer(psb_ipk_), intent(in) :: row_num + end subroutine psb_s_rb_idx_tree_scalar_sparse_row_mul + end interface psb_rb_idx_tree_scalar_sparse_row_mul + + interface psb_rb_idx_tree_merge + subroutine psb_s_rb_idx_tree_merge(trees, mat) + use psb_s_csr_mat_mod, only : psb_s_csr_sparse_mat + import :: psb_s_rb_idx_tree + type(psb_s_rb_idx_tree), allocatable, intent(inout) :: trees(:) + type(psb_s_csr_sparse_mat), intent(inout) :: mat + end subroutine psb_s_rb_idx_tree_merge + end interface psb_rb_idx_tree_merge + + interface psb_rb_idx_tree_fix_insertion + subroutine psb_s_rb_idx_tree_fix_insertion(this, node) + import :: psb_s_rb_idx_tree, psb_s_rb_idx_node + implicit none + class(psb_s_rb_idx_tree), intent(inout) :: this + type(psb_s_rb_idx_node), pointer, intent(inout) :: node + end subroutine psb_s_rb_idx_tree_fix_insertion + end interface psb_rb_idx_tree_fix_insertion + + interface psb_rb_idx_tree_swap_colors + subroutine psb_s_rb_idx_tree_swap_colors(n1, n2) + import :: psb_s_rb_idx_node + implicit none + type(psb_s_rb_idx_node), pointer, intent(inout) :: n1, n2 + end subroutine psb_s_rb_idx_tree_swap_colors + end interface psb_rb_idx_tree_swap_colors + + interface psb_rb_idx_tree_rotate_right + subroutine psb_s_rb_idx_tree_rotate_right(node) + import :: psb_s_rb_idx_node + implicit none + type(psb_s_rb_idx_node), pointer, intent(inout) :: node + end subroutine psb_s_rb_idx_tree_rotate_right + end interface psb_rb_idx_tree_rotate_right + + interface psb_rb_idx_tree_rotate_left + subroutine psb_s_rb_idx_tree_rotate_left(node) + import :: psb_s_rb_idx_node + implicit none + type(psb_s_rb_idx_node), pointer, intent(inout) :: node + end subroutine psb_s_rb_idx_tree_rotate_left + end interface psb_rb_idx_tree_rotate_left +end module psb_s_rb_idx_tree_mod diff --git a/base/modules/auxil/psb_s_realloc_mod.F90 b/base/modules/auxil/psb_s_realloc_mod.F90 index 0b2873e30..f064e6068 100644 --- a/base/modules/auxil/psb_s_realloc_mod.F90 +++ b/base/modules/auxil/psb_s_realloc_mod.F90 @@ -768,7 +768,7 @@ Contains integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz,err_act,lb + integer(psb_ipk_) :: isz,err_act,lb, i character(len=30) :: name, char_err logical, parameter :: debug=.false. @@ -790,7 +790,11 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else - vout(:) = vin(:) + !$omp parallel do private(i) + do i=lb,lb+isz-1 + vout(i) = vin(i) + end do + !$omp end parallel do endif endif @@ -836,7 +840,9 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:,:) = vin(:,:) + !$omp end workshare endif endif @@ -991,36 +997,17 @@ Contains goto 9999 end if -!!$ If (len > psb_size(v)) Then -!!$ if (present(newsz)) then -!!$ isz = (max(len+1,newsz)) -!!$ else -!!$ if (present(addsz)) then -!!$ isz = len+max(1,addsz) -!!$ else -!!$ isz = max(len+10, int(1.25*len)) -!!$ endif -!!$ endif -!!$ -!!$ call psb_realloc(isz,v,info,pad=pad) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_realloc') -!!$ goto 9999 -!!$ End If -!!$ end If - If (len > psb_size(v)) Then + isz = psb_size(v) + If (len > isz) Then #if defined(OPENMP) !$OMP CRITICAL - if (len > psb_size(v)) then + if (len > isz) then if (present(newsz)) then - isz = (max(len+1,newsz)) + isz = max(len+1,1,newsz) + else if (present(addsz)) then + isz = max(len,1,isz+addsz) else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif + isz = max(len,1,int(1.25*isz)) endif call psb_realloc(isz,v,info,pad=pad) @@ -1033,17 +1020,18 @@ Contains goto 9999 end if #else - if (present(newsz)) then - isz = (max(len+1,newsz)) - else - if (present(addsz)) then - isz = len+max(1,addsz) + if (len > isz) then + if (present(newsz)) then + isz = max(len+1,1,newsz) + else if (present(addsz)) then + isz = max(len,1,isz+addsz) else - isz = max(len+10, int(1.25*len)) + isz = max(len,1,int(1.25*isz)) endif - endif - call psb_realloc(isz,v,info,pad=pad) + call psb_realloc(isz,v,info,pad=pad) + end if + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') @@ -1085,16 +1073,14 @@ Contains info=psb_err_from_subroutine_ goto 9999 end if - - If (len > psb_size(v)) Then - if (present(newsz)) then - isz = (max(len+1,newsz)) + isz = psb_size(v) + If (len > isz) Then + if (present(newsz)) then + isz = max(len+1,1,newsz) + else if (present(addsz)) then + isz = max(len,1,isz+addsz) else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif + isz = max(len,1,int(1.25*isz)) endif call psb_realloc(isz,v,info,pad=pad) diff --git a/base/modules/auxil/psb_sort_mod.f90 b/base/modules/auxil/psb_sort_mod.f90 index 0bd7bdfc4..e980dc2b0 100644 --- a/base/modules/auxil/psb_sort_mod.f90 +++ b/base/modules/auxil/psb_sort_mod.f90 @@ -45,7 +45,8 @@ module psb_sort_mod use psb_const_mod use psb_ip_reord_mod - + use psi_serial_mod + use psb_m_hsort_mod use psb_m_isort_mod use psb_m_msort_mod diff --git a/base/modules/auxil/psb_z_hsort_x_mod.f90 b/base/modules/auxil/psb_z_hsort_x_mod.f90 index 39f52e4f9..4b7302aa0 100644 --- a/base/modules/auxil/psb_z_hsort_x_mod.f90 +++ b/base/modules/auxil/psb_z_hsort_x_mod.f90 @@ -123,7 +123,7 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_ipk_)*psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 @@ -236,9 +236,9 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_ipk_)*psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info) if (info == psb_success_) & - & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=(1_psb_ipk_)*psb_heap_resize) + & call psb_ensure_size(heap%last+1,heap%idxs,info) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 diff --git a/base/modules/auxil/psb_z_qsort_mod.f90 b/base/modules/auxil/psb_z_qsort_mod.f90 index 14ee0c57d..2fc6baab2 100644 --- a/base/modules/auxil/psb_z_qsort_mod.f90 +++ b/base/modules/auxil/psb_z_qsort_mod.f90 @@ -44,7 +44,6 @@ module psb_z_qsort_mod use psb_const_mod - interface psb_qsort subroutine psb_zqsort(x,ix,dir,flag) import diff --git a/base/modules/auxil/psb_z_rb_idx_tree_mod.f90 b/base/modules/auxil/psb_z_rb_idx_tree_mod.f90 new file mode 100644 index 000000000..7b15f0800 --- /dev/null +++ b/base/modules/auxil/psb_z_rb_idx_tree_mod.f90 @@ -0,0 +1,128 @@ +! +! 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. +! +! +! +! package: psb_z_rb_idx_tree_mod +! +! Red black tree implementation ordered by index +! +! Each node contains and index and a double precision value +! +! The tree should always be well balanced +! +! inserting a node with an existing index will +! add up the new value to the old one +! Contributed by Dimitri Walther +! +module psb_z_rb_idx_tree_mod + use psb_const_mod + implicit none + + type :: psb_z_rb_idx_node + integer(psb_ipk_) :: idx + complex(psb_dpk_) :: val + type(psb_z_rb_idx_node), pointer :: left, right, parent + logical :: is_red + end type psb_z_rb_idx_node + + type :: psb_z_rb_idx_tree + type(psb_z_rb_idx_node), pointer :: root + integer(psb_ipk_) :: nnz + + contains + + procedure :: insert => psb_z_rb_idx_tree_insert + end type psb_z_rb_idx_tree + + interface psb_rb_idx_tree_insert + subroutine psb_z_rb_idx_tree_insert(this, idx, val) + import :: psb_ipk_, psb_dpk_, psb_z_rb_idx_tree + implicit none + class(psb_z_rb_idx_tree), intent(inout) :: this + integer(psb_ipk_), intent(in) :: idx + complex(psb_dpk_), intent(in) :: val + end subroutine psb_z_rb_idx_tree_insert + end interface psb_rb_idx_tree_insert + + interface psb_rb_idx_tree_scalar_sparse_row_mul + subroutine psb_z_rb_idx_tree_scalar_sparse_row_mul(tree, scalar, mat, row_num) + use psb_z_csr_mat_mod, only : psb_z_csr_sparse_mat + import :: psb_ipk_, psb_dpk_, psb_z_rb_idx_tree + implicit none + type(psb_z_rb_idx_tree), intent(inout) :: tree + complex(psb_dpk_), intent(in) :: scalar + type(psb_z_csr_sparse_mat), intent(in) :: mat + integer(psb_ipk_), intent(in) :: row_num + end subroutine psb_z_rb_idx_tree_scalar_sparse_row_mul + end interface psb_rb_idx_tree_scalar_sparse_row_mul + + interface psb_rb_idx_tree_merge + subroutine psb_z_rb_idx_tree_merge(trees, mat) + use psb_z_csr_mat_mod, only : psb_z_csr_sparse_mat + import :: psb_z_rb_idx_tree + type(psb_z_rb_idx_tree), allocatable, intent(inout) :: trees(:) + type(psb_z_csr_sparse_mat), intent(inout) :: mat + end subroutine psb_z_rb_idx_tree_merge + end interface psb_rb_idx_tree_merge + + interface psb_rb_idx_tree_fix_insertion + subroutine psb_z_rb_idx_tree_fix_insertion(this, node) + import :: psb_z_rb_idx_tree, psb_z_rb_idx_node + implicit none + class(psb_z_rb_idx_tree), intent(inout) :: this + type(psb_z_rb_idx_node), pointer, intent(inout) :: node + end subroutine psb_z_rb_idx_tree_fix_insertion + end interface psb_rb_idx_tree_fix_insertion + + interface psb_rb_idx_tree_swap_colors + subroutine psb_z_rb_idx_tree_swap_colors(n1, n2) + import :: psb_z_rb_idx_node + implicit none + type(psb_z_rb_idx_node), pointer, intent(inout) :: n1, n2 + end subroutine psb_z_rb_idx_tree_swap_colors + end interface psb_rb_idx_tree_swap_colors + + interface psb_rb_idx_tree_rotate_right + subroutine psb_z_rb_idx_tree_rotate_right(node) + import :: psb_z_rb_idx_node + implicit none + type(psb_z_rb_idx_node), pointer, intent(inout) :: node + end subroutine psb_z_rb_idx_tree_rotate_right + end interface psb_rb_idx_tree_rotate_right + + interface psb_rb_idx_tree_rotate_left + subroutine psb_z_rb_idx_tree_rotate_left(node) + import :: psb_z_rb_idx_node + implicit none + type(psb_z_rb_idx_node), pointer, intent(inout) :: node + end subroutine psb_z_rb_idx_tree_rotate_left + end interface psb_rb_idx_tree_rotate_left +end module psb_z_rb_idx_tree_mod diff --git a/base/modules/auxil/psb_z_realloc_mod.F90 b/base/modules/auxil/psb_z_realloc_mod.F90 index e6eeac2f7..e9eb26d36 100644 --- a/base/modules/auxil/psb_z_realloc_mod.F90 +++ b/base/modules/auxil/psb_z_realloc_mod.F90 @@ -768,7 +768,7 @@ Contains integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz,err_act,lb + integer(psb_ipk_) :: isz,err_act,lb, i character(len=30) :: name, char_err logical, parameter :: debug=.false. @@ -790,7 +790,11 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else - vout(:) = vin(:) + !$omp parallel do private(i) + do i=lb,lb+isz-1 + vout(i) = vin(i) + end do + !$omp end parallel do endif endif @@ -836,7 +840,9 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:,:) = vin(:,:) + !$omp end workshare endif endif @@ -991,36 +997,17 @@ Contains goto 9999 end if -!!$ If (len > psb_size(v)) Then -!!$ if (present(newsz)) then -!!$ isz = (max(len+1,newsz)) -!!$ else -!!$ if (present(addsz)) then -!!$ isz = len+max(1,addsz) -!!$ else -!!$ isz = max(len+10, int(1.25*len)) -!!$ endif -!!$ endif -!!$ -!!$ call psb_realloc(isz,v,info,pad=pad) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_realloc') -!!$ goto 9999 -!!$ End If -!!$ end If - If (len > psb_size(v)) Then + isz = psb_size(v) + If (len > isz) Then #if defined(OPENMP) !$OMP CRITICAL - if (len > psb_size(v)) then + if (len > isz) then if (present(newsz)) then - isz = (max(len+1,newsz)) + isz = max(len+1,1,newsz) + else if (present(addsz)) then + isz = max(len,1,isz+addsz) else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif + isz = max(len,1,int(1.25*isz)) endif call psb_realloc(isz,v,info,pad=pad) @@ -1033,17 +1020,18 @@ Contains goto 9999 end if #else - if (present(newsz)) then - isz = (max(len+1,newsz)) - else - if (present(addsz)) then - isz = len+max(1,addsz) + if (len > isz) then + if (present(newsz)) then + isz = max(len+1,1,newsz) + else if (present(addsz)) then + isz = max(len,1,isz+addsz) else - isz = max(len+10, int(1.25*len)) + isz = max(len,1,int(1.25*isz)) endif - endif - call psb_realloc(isz,v,info,pad=pad) + call psb_realloc(isz,v,info,pad=pad) + end if + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') @@ -1085,16 +1073,14 @@ Contains info=psb_err_from_subroutine_ goto 9999 end if - - If (len > psb_size(v)) Then - if (present(newsz)) then - isz = (max(len+1,newsz)) + isz = psb_size(v) + If (len > isz) Then + if (present(newsz)) then + isz = max(len+1,1,newsz) + else if (present(addsz)) then + isz = max(len,1,isz+addsz) else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif + isz = max(len,1,int(1.25*isz)) endif call psb_realloc(isz,v,info,pad=pad) diff --git a/base/serial/sort/psi_acx_mod.f90 b/base/modules/auxil/psi_acx_mod.f90 similarity index 100% rename from base/serial/sort/psi_acx_mod.f90 rename to base/modules/auxil/psi_acx_mod.f90 diff --git a/base/serial/sort/psi_alcx_mod.f90 b/base/modules/auxil/psi_alcx_mod.f90 similarity index 100% rename from base/serial/sort/psi_alcx_mod.f90 rename to base/modules/auxil/psi_alcx_mod.f90 diff --git a/base/modules/auxil/psi_c_serial_mod.f90 b/base/modules/auxil/psi_c_serial_mod.f90 index 191e7ef36..0fdff04ba 100644 --- a/base/modules/auxil/psi_c_serial_mod.f90 +++ b/base/modules/auxil/psi_c_serial_mod.f90 @@ -156,4 +156,15 @@ module psi_c_serial_mod end subroutine psi_csctv end interface psi_sct + interface psi_exscan + subroutine psi_c_exscanv(n,x,info,shift) + import :: psb_ipk_, psb_spk_ + implicit none + integer(psb_ipk_), intent(in) :: n + complex(psb_spk_), intent (inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_), intent(in), optional :: shift + end subroutine psi_c_exscanv + end interface psi_exscan + end module psi_c_serial_mod diff --git a/base/modules/auxil/psi_d_serial_mod.f90 b/base/modules/auxil/psi_d_serial_mod.f90 index f1dbc16c4..0ce14dbb9 100644 --- a/base/modules/auxil/psi_d_serial_mod.f90 +++ b/base/modules/auxil/psi_d_serial_mod.f90 @@ -156,4 +156,15 @@ module psi_d_serial_mod end subroutine psi_dsctv end interface psi_sct + interface psi_exscan + subroutine psi_d_exscanv(n,x,info,shift) + import :: psb_ipk_, psb_dpk_ + implicit none + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_), intent (inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), intent(in), optional :: shift + end subroutine psi_d_exscanv + end interface psi_exscan + end module psi_d_serial_mod diff --git a/base/modules/auxil/psi_e_serial_mod.f90 b/base/modules/auxil/psi_e_serial_mod.f90 index 909b025c2..f0372e016 100644 --- a/base/modules/auxil/psi_e_serial_mod.f90 +++ b/base/modules/auxil/psi_e_serial_mod.f90 @@ -156,4 +156,15 @@ module psi_e_serial_mod end subroutine psi_esctv end interface psi_sct + interface psi_exscan + subroutine psi_e_exscanv(n,x,info,shift) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_), intent (inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_), intent(in), optional :: shift + end subroutine psi_e_exscanv + end interface psi_exscan + end module psi_e_serial_mod diff --git a/base/modules/auxil/psi_i2_serial_mod.f90 b/base/modules/auxil/psi_i2_serial_mod.f90 index 38ef9c385..70dd95e1b 100644 --- a/base/modules/auxil/psi_i2_serial_mod.f90 +++ b/base/modules/auxil/psi_i2_serial_mod.f90 @@ -156,4 +156,15 @@ module psi_i2_serial_mod end subroutine psi_i2sctv end interface psi_sct + interface psi_exscan + subroutine psi_i2_exscanv(n,x,info,shift) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_), intent(in) :: n + integer(psb_i2pk_), intent (inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_), intent(in), optional :: shift + end subroutine psi_i2_exscanv + end interface psi_exscan + end module psi_i2_serial_mod diff --git a/base/serial/sort/psi_lcx_mod.f90 b/base/modules/auxil/psi_lcx_mod.f90 similarity index 100% rename from base/serial/sort/psi_lcx_mod.f90 rename to base/modules/auxil/psi_lcx_mod.f90 diff --git a/base/modules/auxil/psi_m_serial_mod.f90 b/base/modules/auxil/psi_m_serial_mod.f90 index a80d0ffe6..cfd1348ef 100644 --- a/base/modules/auxil/psi_m_serial_mod.f90 +++ b/base/modules/auxil/psi_m_serial_mod.f90 @@ -156,4 +156,15 @@ module psi_m_serial_mod end subroutine psi_msctv end interface psi_sct + interface psi_exscan + subroutine psi_m_exscanv(n,x,info,shift) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent (inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_), intent(in), optional :: shift + end subroutine psi_m_exscanv + end interface psi_exscan + end module psi_m_serial_mod diff --git a/base/modules/auxil/psi_s_serial_mod.f90 b/base/modules/auxil/psi_s_serial_mod.f90 index 3c0a3bdcd..25c4a7ef3 100644 --- a/base/modules/auxil/psi_s_serial_mod.f90 +++ b/base/modules/auxil/psi_s_serial_mod.f90 @@ -156,4 +156,15 @@ module psi_s_serial_mod end subroutine psi_ssctv end interface psi_sct + interface psi_exscan + subroutine psi_s_exscanv(n,x,info,shift) + import :: psb_ipk_, psb_spk_ + implicit none + integer(psb_ipk_), intent(in) :: n + real(psb_spk_), intent (inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + real(psb_spk_), intent(in), optional :: shift + end subroutine psi_s_exscanv + end interface psi_exscan + end module psi_s_serial_mod diff --git a/base/modules/auxil/psi_z_serial_mod.f90 b/base/modules/auxil/psi_z_serial_mod.f90 index 7bc9728e3..b40cf05ad 100644 --- a/base/modules/auxil/psi_z_serial_mod.f90 +++ b/base/modules/auxil/psi_z_serial_mod.f90 @@ -156,4 +156,15 @@ module psi_z_serial_mod end subroutine psi_zsctv end interface psi_sct + interface psi_exscan + subroutine psi_z_exscanv(n,x,info,shift) + import :: psb_ipk_, psb_dpk_ + implicit none + integer(psb_ipk_), intent(in) :: n + complex(psb_dpk_), intent (inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_), intent(in), optional :: shift + end subroutine psi_z_exscanv + end interface psi_exscan + end module psi_z_serial_mod diff --git a/base/modules/desc/psb_gen_block_map_mod.F90 b/base/modules/desc/psb_gen_block_map_mod.F90 index dfb47b61a..f0c433e02 100644 --- a/base/modules/desc/psb_gen_block_map_mod.F90 +++ b/base/modules/desc/psb_gen_block_map_mod.F90 @@ -488,6 +488,7 @@ contains integer(psb_ipk_) :: iam, np logical :: owned_ + !write(0,*) 'block_g2lv2' info = 0 ctxt = idxmap%get_ctxt() call psb_info(ctxt,iam,np) diff --git a/base/modules/desc/psb_glist_map_mod.f90 b/base/modules/desc/psb_glist_map_mod.F90 similarity index 100% rename from base/modules/desc/psb_glist_map_mod.f90 rename to base/modules/desc/psb_glist_map_mod.F90 diff --git a/base/modules/desc/psb_hash_map_mod.f90 b/base/modules/desc/psb_hash_map_mod.F90 similarity index 78% rename from base/modules/desc/psb_hash_map_mod.f90 rename to base/modules/desc/psb_hash_map_mod.F90 index 06e68451a..058dbb8d5 100644 --- a/base/modules/desc/psb_hash_map_mod.f90 +++ b/base/modules/desc/psb_hash_map_mod.F90 @@ -207,7 +207,6 @@ contains integer(psb_ipk_) :: i logical :: owned_ info = 0 - if (present(mask)) then if (size(mask) < size(idx)) then info = -1 @@ -249,7 +248,6 @@ contains end do end if - end subroutine hash_l2gv1 subroutine hash_l2gv2(idxin,idxout,idxmap,info,mask,owned) @@ -334,7 +332,6 @@ contains info = 0 ctxt = idxmap%get_ctxt() call psb_info(ctxt,iam,np) - if (present(mask)) then if (size(mask) < size(idx)) then info = -1 @@ -378,6 +375,7 @@ contains if (lip < 0) then call psb_hash_searchkey(ip,tlip,idxmap%hash,info) lip = tlip + info = 0 end if if (owned_) then if (lip<=nrow) then @@ -417,6 +415,7 @@ contains if (lip < 0) then call psb_hash_searchkey(ip,tlip,idxmap%hash,info) lip = tlip + info = 0 end if if (owned_) then if (lip<=nrow) then @@ -437,7 +436,6 @@ contains end if end if - end subroutine hash_g2lv1 subroutine hash_g2lv2(idxin,idxout,idxmap,info,mask,owned) @@ -460,7 +458,6 @@ contains is = size(idxin) im = min(is,size(idxout)) - info = 0 ctxt = idxmap%get_ctxt() call psb_info(ctxt,iam,np) @@ -508,6 +505,7 @@ contains if (lip < 0) then call psb_hash_searchkey(ip,tlip,idxmap%hash,info) lip = tlip + info = 0 end if if (owned_) then if (lip<=nrow) then @@ -520,7 +518,6 @@ contains endif end if enddo - else write(0,*) 'Hash status: invalid ',idxmap%get_state() idxout(1:is) = -1 @@ -547,6 +544,7 @@ contains if (lip < 0) then call psb_hash_searchkey(ip,tlip,idxmap%hash,info) lip = tlip + info = 0 end if if (owned_) then if (lip<=nrow) then @@ -567,7 +565,6 @@ contains end if end if - end subroutine hash_g2lv2 @@ -636,7 +633,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 @@ -652,15 +651,14 @@ contains type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: me, np character(len=20) :: name,ch_err - logical :: use_openmp = .false. - + logical, allocatable :: mask_(:) +!!$ logical :: use_openmp = .true. +#ifdef OPENMP + integer(kind = OMP_lock_kind) :: ins_lck +#endif logical, volatile :: isLoopValid - !$ integer(kind = OMP_lock_kind) :: ins_lck - - !$ use_openmp = .true. - info = psb_success_ - name = 'hash_g2l_ins' + name = 'hash_g2lv1_ins' call psb_erractionsave(err_act) ctxt = idxmap%get_ctxt() @@ -684,340 +682,321 @@ contains 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() + !write(0,*) me,name,' before loop ',psb_errstatus_fatal() +#ifdef OPENMP + !call OMP_init_lock(ins_lck) + + if (idxmap%is_bld()) then + + isLoopValid = .true. + ncol = idxmap%get_lc() + if (present(mask)) then + mask_ = mask + else + allocate(mask_(size(idx))) + mask_ = .true. 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) + !$omp critical(hash_g2l_ins) + + ! $ OMP PARALLEL DO default(none) schedule(DYNAMIC) & + ! $ OMP shared(name,me,is,idx,ins_lck,mask,mglob,idxmap,ncol,nrow,laddsz,lidx) & + ! $ OMP private(i,ip,lip,tlip,nxt,info) & + ! $ OMP reduction(.AND.:isLoopValid) + do i = 1, is + info = 0 + if (.not. isLoopValid) cycle + if (mask(i)) then + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle + endif + !call OMP_set_lock(ins_lck) + ncol = idxmap%get_lc() + !call OMP_unset_lock(ins_lck) - 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 + !call OMP_set_lock(ins_lck) - ! 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. + ! 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). + ncol = idxmap%get_lc() + nxt = lidx(i) 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) + if (lip > 0) then + idx(i) = lip + else if (lip < 0) then ! 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) + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + lip = tlip - 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) + 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 - call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& - & pad=-1_psb_lpk_,addsz=laddsz) + ncol = MAX(ncol,nxt) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_ai_,name,& - &a_err='psb_ensure_size',i_err=(/info/)) + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& + & pad=-1_psb_lpk_,addsz=laddsz) - isLoopValid = .false. - cycle - end if + if (info /= psb_success_) then + !write(0,*) 'Error spot 1' + call psb_errpush(psb_err_from_subroutine_ai_,name,& + &a_err='psb_ensure_size',i_err=(/info/)) - idxmap%loc_to_glob(nxt) = ip + isLoopValid = .false. + idx(i) = -1 else - !$ call OMP_unset_lock(ins_lck) + idx(i) = lip + idxmap%loc_to_glob(nxt) = ip + call idxmap%set_lc(ncol) 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) + idx(i) = -1 end if + !call OMP_unset_lock(ins_lck) end if - - idx(i) = lip - info = psb_success_ else - idx(i) = -1 + idx(i) = lip end if - end do - !$OMP END PARALLEL DO - - call idxmap%set_lc(ncol) - - if (.not. isLoopValid) then - goto 9999 + else + idx(i) = -1 end if - else - do i = 1, is + end do + ! $ OMP END PARALLEL DO + !$omp end critical(hash_g2l_ins) + + if (.not. isLoopValid) then + goto 9999 + end if + else + !$omp critical(hash_g2l_ins) + + ! $ OMP PARALLEL DO default(none) schedule(DYNAMIC) & + ! $ OMP shared(name,me,is,idx,ins_lck,mglob,idxmap,ncol,nrow,laddsz,lidx) & + ! $ OMP private(i,ip,lip,tlip,nxt,info) & + ! $ OMP reduction(.AND.:isLoopValid) + do i = 1, is + info = 0 + if (.not. isLoopValid) cycle + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle + endif + !call OMP_set_lock(ins_lck) + ncol = idxmap%get_lc() + !call OMP_unset_lock(ins_lck) + + ! 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 + !call OMP_set_lock(ins_lck) + ! 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). 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 + nxt = lidx(i) + call hash_inner_cnv(ip,lip,idxmap%hashvmask,& + & idxmap%hashv,idxmap%glb_lc,ncol) + + if (lip > 0) then + idx(i) = lip + else if (lip < 0) then + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + lip = tlip + + 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 psb_ensure_size(ncol,idxmap%loc_to_glob,info,& + & pad=-1_psb_lpk_,addsz=laddsz) + + if (info /= psb_success_) then + !write(0,*) 'Error spot 2' + call psb_errpush(psb_err_from_subroutine_ai_,name,& + &a_err='psb_ensure_size',i_err=(/info/)) + + isLoopValid = .false. + idx(i) = -1 + else + idx(i) = lip + 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 + else + idx(i) = -1 end if - idx(i) = lip - info = psb_success_ - else - idx(i) = -1 + !call OMP_unset_lock(ins_lck) end if - enddo + else + idx(i) = lip + end if + + end do + ! $ OMP END PARALLEL DO + !$omp end critical(hash_g2l_ins) + + if (.not. isLoopValid) then + goto 9999 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 + end if + else if (.not.present(lidx)) then + if(present(mask)) then + ! $ OMP PARALLEL DO default(none) schedule(DYNAMIC) & + ! $ OMP shared(name,me,is,idx,ins_lck,mask,mglob,idxmap,ncol,nrow,laddsz) & + ! $ OMP private(i,ip,lip,tlip,nxt,info) & + ! $ OMP reduction(.AND.:isLoopValid) + + !$omp critical(hash_g2l_ins) + do i = 1, is + info = 0 + if (.not. isLoopValid) cycle + if (mask(i)) then ip = idx(i) - if ((ip < 1 ).or.(ip>mglob)) then idx(i) = -1 cycle endif + !call OMP_set_lock(ins_lck) + ncol = idxmap%get_lc() + !call OMP_unset_lock(ins_lck) - ! In OMP logic the index research limit is turned off. It is - ! a correct way to fit the subroutine? + ! 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. + !write(0,*) me,name,' b hic 1 ',psb_errstatus_fatal() call hash_inner_cnv(ip,lip,idxmap%hashvmask,& & idxmap%hashv,idxmap%glb_lc,ncol) - + !write(0,*) me,name,' a hic 1 ',psb_errstatus_fatal() if (lip < 0) then - tlip = lip - nxt = lidx(i) - - if (nxt <= nrow) then - idx(i) = -1 - cycle - endif - + !call OMP_set_lock(ins_lck) ! 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) + ! is often already existing, so this lock is relatively rare). + ncol = idxmap%get_lc() + nxt = ncol + 1 + !write(0,*) me,name,' b hic 2 ',psb_errstatus_fatal() 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! + & idxmap%hashv,idxmap%glb_lc,ncol) + !write(0,*) me,name,' a hic 2 ',psb_errstatus_fatal() + if (lip > 0) then + idx(i) = lip + else if (lip < 0) then + ! Index not found + !write(0,*) me,name,' b hsik ',psb_errstatus_fatal() call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) - !$ call OMP_unset_lock(ins_lck) + if (psb_errstatus_fatal()) write(0,*) me,name,' a hsik ',info,omp_get_thread_num() + !write(0,*) me,name,' a hsik ',psb_errstatus_fatal() + lip = tlip if (info >= 0) then + !write(0,*) 'Error before spot 3', info ! '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) - - ! Under checking! call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& & pad=-1_psb_lpk_,addsz=laddsz) - + if (psb_errstatus_fatal()) write(0,*) me,name,' a esz ',info,omp_get_thread_num() if (info /= psb_success_) then + !write(0,*) 'Error spot 3', info 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 + idx(i) = -1 + else + idx(i) = lip + idxmap%loc_to_glob(nxt) = ip + call idxmap%set_lc(ncol) 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 + idx(i) = -1 end if - else - !$ call OMP_unset_lock(ins_lck) + !call OMP_unset_lock(ins_lck) end if + else + idx(i) = lip end if - - idx(i) = lip - info = psb_success_ - end do - !$OMP END PARALLEL DO - - call idxmap%set_lc(ncol) - - if (.not. isLoopValid) then - goto 9999 + else + idx(i) = -1 end if - else - do i = 1, is + end do + ! $ OMP END PARALLEL DO + !$omp end critical(hash_g2l_ins) + + if (.not. isLoopValid) then + goto 9999 + end if + else + ! $ OMP PARALLEL DO default(none) schedule(DYNAMIC) & + ! $ OMP shared(name,me,is,idx,ins_lck,mglob,idxmap,ncol,nrow,laddsz) & + ! $ OMP private(i,ip,lip,tlip,nxt,info) & + ! $ OMP reduction(.AND.:isLoopValid) + !$omp critical(hash_g2l_ins) + do i = 1, is + info = 0 + if (.not. isLoopValid) cycle + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle + endif + !call OMP_set_lock(ins_lck) + ncol = idxmap%get_lc() + !call OMP_unset_lock(ins_lck) + + ! 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 + !call OMP_set_lock(ins_lck) + ! 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). 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 + nxt = ncol + 1 + call hash_inner_cnv(ip,lip,idxmap%hashvmask,& + & idxmap%hashv,idxmap%glb_lc,ncol) + + if (lip > 0) then + idx(i) = lip + else if (lip < 0) then + ! Index not found 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 - 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 - - 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 - - ! 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 @@ -1026,74 +1005,84 @@ contains 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 + !write(0,*) 'Error spot 4' 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 + idx(i) = -1 + else + idx(i) = lip + idxmap%loc_to_glob(nxt) = ip + call idxmap%set_lc(ncol) 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 + idx(i) = -1 end if - - else - idx(i) = -1 + !call OMP_unset_lock(ins_lck) end if - end do - !$OMP END PARALLEL DO - call idxmap%set_lc(ncol) - - if (.not. isLoopValid) then - goto 9999 + else + idx(i) = lip 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 + end do + ! $ OMP END PARALLEL DO + !$omp end critical(hash_g2l_ins) + + if (.not. isLoopValid) then + goto 9999 + end if + + end if + end if + else + ! Wrong state + idx = -1 + info = -1 + end if + !call OMP_destroy_lock(ins_lck) +#else +!!$ else if (.not.use_openmp) then + isLoopValid = .true. + 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 - 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 - + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) if (info >=0) then - if (nxt == lip) then - ncol = nxt + 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 - info=1 + !write(0,*) 'Error spot' call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='psb_ensure_size',i_err=(/info/)) - goto 9999 + &a_err='psb_ensure_size',i_err=(/info/)) + isLoopValid = .false. end if idxmap%loc_to_glob(nxt) = ip call idxmap%set_lc(ncol) @@ -1102,111 +1091,76 @@ contains else call psb_errpush(psb_err_from_subroutine_ai_,name,& & a_err='SearchInsKeyVal',i_err=(/info/)) - goto 9999 + isLoopValid = .false. 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 + idx(i) = lip + info = psb_success_ + else + idx(i) = -1 + end if + enddo - ip = idx(i) + else if (.not.present(mask)) then - if ((ip < 1 ).or.(ip>mglob)) 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 - ! 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) - + 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 + !write(0,*) 'Error spot' call psb_errpush(psb_err_from_subroutine_ai_,name,& - &a_err='psb_ensure_size',i_err=(/info/)) - - !$ isLoopValid = .false. - cycle + &a_err='psb_ensure_size',i_err=(/info/)) + isLoopValid = .false. end if - - idxmap%loc_to_glob(nxt) = ip - else - !$ call OMP_unset_lock(ins_lck) - end if - + idxmap%loc_to_glob(nxt) = ip + call idxmap%set_lc(ncol) + endif 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 + end if + idx(i) = lip + info = psb_success_ + enddo - call idxmap%set_lc(ncol) + end if - if (.not. isLoopValid) then - goto 9999 - end if + else if (.not.present(lidx)) then - else - do i = 1, is - ncol = idxmap%get_lc() - ip = idx(i) + if (present(mask)) then + do i = 1, is + if (mask(i)) then + ip = idx(i) if ((ip < 1 ).or.(ip>mglob)) then idx(i) = -1 cycle endif - nxt = ncol + 1 + ncol = idxmap%get_lc() + nxt = ncol + 1 call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& & idxmap%glb_lc,ncol) if (lip < 0) then @@ -1221,38 +1175,81 @@ contains & pad=-1_psb_lpk_,addsz=laddsz) if (info /= psb_success_) then info=1 - ch_err='psb_ensure_size' + write(0,*) 'Error spot 5' call psb_errpush(psb_err_from_subroutine_ai_,name,& - &a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) - goto 9999 + & a_err='psb_ensure_size',i_err=(/info/)) + isLoopValid = .false. 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 + & a_err='SearchInsKeyVal',i_err=(/info/)) + isLoopValid = .false. end if idx(i) = lip info = psb_success_ - enddo - end if - end if - end if + else + idx(i) = -1 + end if + enddo + else if (.not.present(mask)) then - if (use_openmp) then - !$ call OMP_destroy_lock(ins_lck) - end if + 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 + write(0,*) 'Error spot 6' + 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/)) + isLoopValid = .false. + + 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/)) + isLoopValid = .false. + end if + idx(i) = lip + info = psb_success_ + enddo + end if + end if else ! Wrong state idx = -1 info = -1 end if - + if (.not. isLoopValid) goto 9999 +#endif + !write(0,*) me,name,' after loop ',psb_errstatus_fatal() call psb_erractionrestore(err_act) return @@ -1266,6 +1263,7 @@ contains subroutine hash_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx) use psb_realloc_mod + use psb_error_mod implicit none class(psb_hash_map), intent(inout) :: idxmap integer(psb_lpk_), intent(in) :: idxin(:) @@ -1278,7 +1276,9 @@ contains is = size(idxin) im = min(is,size(idxout)) + !write(0,*) 'g2lv2_ins before realloc ',psb_errstatus_fatal() call psb_realloc(im,tidx,info) + !write(0,*) 'g2lv2_ins after realloc ',psb_errstatus_fatal() tidx(1:im) = idxin(1:im) call idxmap%g2lip_ins(tidx(1:im),info,mask=mask,lidx=lidx) idxout(1:im) = tidx(1:im) diff --git a/base/modules/desc/psb_hash_mod.F90 b/base/modules/desc/psb_hash_mod.F90 index 42911e3ff..eb5556a2a 100644 --- a/base/modules/desc/psb_hash_mod.F90 +++ b/base/modules/desc/psb_hash_mod.F90 @@ -388,7 +388,7 @@ contains info = HashOK hsize = hash%hsize hmask = hash%hmask - + val = -1 hk = iand(psb_hashval(key),hmask) if (hk == 0) then hd = 1 @@ -407,35 +407,49 @@ contains if (hash%table(hk,1) == key) then val = hash%table(hk,2) info = HashDuplicate + !write(0,*) 'In searchinskey 1 : ', 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 + !$omp critical(hashsearchins) + if (hash%table(hk,1) == key) then + val = hash%table(hk,2) + info = HashDuplicate + else + 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 - call psb_hash_searchinskey(key,val,nextval,hash,info) - return + hash%nk = hash%nk + 1 + hash%table(hk,1) = key + hash%table(hk,2) = nextval + val = nextval + !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 + !$omp end critical(hashsearchins) + if (info /= HashOk) then + write(0,*) 'In searchinskey 2: ', info + return + end if + if (val > 0) return hk = hk - hd if (hk < 0) hk = hk + hsize end do + !write(0,*) 'In searchinskey 3: ', info end subroutine psb_hash_lsearchinskey recursive subroutine psb_hash_isearchinskey(key,val,nextval,hash,info) @@ -444,11 +458,11 @@ contains integer(psb_ipk_), intent(out) :: val, info integer(psb_ipk_) :: hsize,hmask, hk, hd - + logical :: redo info = HashOK hsize = hash%hsize hmask = hash%hmask - + hk = iand(psb_hashval(key),hmask) if (hk == 0) then hd = 1 @@ -460,7 +474,7 @@ contains info = HashOutOfMemory return end if - + val = -1 hash%nsrch = hash%nsrch + 1 do hash%nacc = hash%nacc + 1 @@ -469,6 +483,8 @@ contains info = HashDuplicate return end if + redo = .false. + !$OMP CRITICAL if (hash%table(hk,1) == HashFreeEntry) then if (hash%nk == hash%hsize -1) then ! @@ -480,19 +496,24 @@ contains call psb_hash_realloc(hash,info) if (info /= HashOk) then info = HashOutOfMemory - return + !return else - call psb_hash_searchinskey(key,val,nextval,hash,info) - return + redo = .true. +!!$ 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 + !return end if end if + !$OMP END CRITICAL + if (redo) call psb_hash_searchinskey(key,val,nextval,hash,info) + if (info /= HashOk) return + if (val > 0) return hk = hk - hd if (hk < 0) hk = hk + hsize end do diff --git a/base/modules/desc/psb_list_map_mod.f90 b/base/modules/desc/psb_list_map_mod.F90 similarity index 80% rename from base/modules/desc/psb_list_map_mod.f90 rename to base/modules/desc/psb_list_map_mod.F90 index 3e3c8e253..6b61cf52e 100644 --- a/base/modules/desc/psb_list_map_mod.f90 +++ b/base/modules/desc/psb_list_map_mod.F90 @@ -349,7 +349,6 @@ contains logical :: owned_ info = 0 - if (present(mask)) then if (size(mask) < size(idxin)) then info = -1 @@ -501,19 +500,37 @@ contains if (present(lidx)) then if (present(mask)) then do i=1, is + if (info /= 0) cycle 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 +#if defined(OPENMP) + !$OMP CRITICAL(LISTINS) + 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 + else + idxmap%local_cols = max(ix,idxmap%local_cols) + idxmap%loc_to_glob(ix) = idx(i) + idxmap%glob_to_loc(idx(i)) = ix + end if + end if + !$OMP END CRITICAL(LISTINS) +#else ix = lidx(i) call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) - if ((ix <= idxmap%local_rows).or.(info /= 0)) then + if ((ix <= idxmap%local_rows).or.(info /= 0)) then info = -4 - return + else + idxmap%local_cols = max(ix,idxmap%local_cols) + idxmap%loc_to_glob(ix) = idx(i) + idxmap%glob_to_loc(idx(i)) = ix end if - idxmap%local_cols = max(ix,idxmap%local_cols) - idxmap%loc_to_glob(ix) = idx(i) - idxmap%glob_to_loc(idx(i)) = ix +#endif end if idx(i) = ix else @@ -525,18 +542,37 @@ contains else if (.not.present(mask)) then do i=1, is + if (info /= 0) cycle if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then ix = idxmap%glob_to_loc(idx(i)) if (ix < 0) then +#if defined(OPENMP) + !$OMP CRITICAL(LISTINS) + 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 + else + idxmap%local_cols = max(ix,idxmap%local_cols) + idxmap%loc_to_glob(ix) = idx(i) + idxmap%glob_to_loc(idx(i)) = ix + end if + end if + !$OMP END CRITICAL(LISTINS) +#else ix = lidx(i) call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) - if ((ix <= idxmap%local_rows).or.(info /= 0)) then + if ((ix <= idxmap%local_rows).or.(info /= 0)) then info = -4 - return + else + idxmap%local_cols = max(ix,idxmap%local_cols) + idxmap%loc_to_glob(ix) = idx(i) + idxmap%glob_to_loc(idx(i)) = ix end if - idxmap%local_cols = max(ix,idxmap%local_cols) - idxmap%loc_to_glob(ix) = idx(i) - idxmap%glob_to_loc(idx(i)) = ix +#endif end if idx(i) = ix else @@ -549,19 +585,37 @@ contains if (present(mask)) then do i=1, is + if (info /= 0) cycle 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 +#if defined(OPENMP) + !$OMP CRITICAL(LISTINS) + 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 + else + idxmap%local_cols = ix + idxmap%loc_to_glob(ix) = idx(i) + idxmap%glob_to_loc(idx(i)) = ix + end if + end if + !$OMP END CRITICAL(LISTINS) +#else ix = idxmap%local_cols + 1 call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) - if (info /= 0) then + if (info /= 0) then info = -4 - return + else + idxmap%local_cols = ix + idxmap%loc_to_glob(ix) = idx(i) + idxmap%glob_to_loc(idx(i)) = ix end if - idxmap%local_cols = ix - idxmap%loc_to_glob(ix) = idx(i) - idxmap%glob_to_loc(idx(i)) = ix +#endif end if idx(i) = ix else @@ -573,18 +627,36 @@ contains else if (.not.present(mask)) then do i=1, is + if (info /= 0) cycle if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then ix = idxmap%glob_to_loc(idx(i)) if (ix < 0) then +#if defined(OPENMP) + !$OMP CRITICAL(LISTINS) + 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 + else + idxmap%local_cols = ix + idxmap%loc_to_glob(ix) = idx(i) + idxmap%glob_to_loc(idx(i)) = ix + end if + end if + !$OMP END CRITICAL(LISTINS) +#else ix = idxmap%local_cols + 1 call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) if (info /= 0) then info = -4 - return + else + idxmap%local_cols = ix + idxmap%loc_to_glob(ix) = idx(i) + idxmap%glob_to_loc(idx(i)) = ix end if - idxmap%local_cols = ix - idxmap%loc_to_glob(ix) = idx(i) - idxmap%glob_to_loc(idx(i)) = ix +#endif end if idx(i) = ix else @@ -641,19 +713,37 @@ contains if (present(lidx)) then if (present(mask)) then do i=1, is + if (info /= 0) cycle if (mask(i)) then if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then ix = idxmap%glob_to_loc(idxin(i)) - if (ix < 0) then + if (ix < 0) then +#if defined(OPENMP) + !$OMP CRITICAL(LISTINS) + ix = idxmap%glob_to_loc(idxin(i)) + if (ix < 0) then + ix = lidx(i) + call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) + if (info /= 0) then + info = -4 + else + idxmap%local_cols = max(ix,idxmap%local_cols) + idxmap%loc_to_glob(ix) = idxin(i) + idxmap%glob_to_loc(idxin(i)) = ix + end if + end if + !$OMP END CRITICAL(LISTINS) +#else 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 + else + idxmap%local_cols = max(ix,idxmap%local_cols) + idxmap%loc_to_glob(ix) = idxin(i) + idxmap%glob_to_loc(idxin(i)) = ix end if - idxmap%local_cols = max(ix,idxmap%local_cols) - idxmap%loc_to_glob(ix) = idxin(i) - idxmap%glob_to_loc(idxin(i)) = ix +#endif end if idxout(i) = ix else @@ -665,18 +755,36 @@ contains else if (.not.present(mask)) then do i=1, is + if (info /= 0) cycle if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then ix = idxmap%glob_to_loc(idxin(i)) if (ix < 0) then +#if defined(OPENMP) + !$OMP CRITICAL(LISTINS) + ix = idxmap%glob_to_loc(idxin(i)) + if (ix < 0) then + ix = lidx(i) + call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) + if (info /= 0) then + info = -4 + else + idxmap%local_cols = max(ix,idxmap%local_cols) + idxmap%loc_to_glob(ix) = idxin(i) + idxmap%glob_to_loc(idxin(i)) = ix + end if + end if + !$OMP END CRITICAL(LISTINS) +#else 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 + else + idxmap%local_cols = max(ix,idxmap%local_cols) + idxmap%loc_to_glob(ix) = idxin(i) + idxmap%glob_to_loc(idxin(i)) = ix end if - idxmap%local_cols = max(ix,idxmap%local_cols) - idxmap%loc_to_glob(ix) = idxin(i) - idxmap%glob_to_loc(idxin(i)) = ix +#endif end if idxout(i) = ix else @@ -689,19 +797,37 @@ contains if (present(mask)) then do i=1, is + if (info /= 0) cycle if (mask(i)) then if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then ix = idxmap%glob_to_loc(idxin(i)) - if (ix < 0) then + if (ix < 0) then +#if defined(OPENMP) + !$OMP CRITICAL(LISTINS) + ix = idxmap%glob_to_loc(idxin(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 + else + idxmap%local_cols = ix + idxmap%loc_to_glob(ix) = idxin(i) + idxmap%glob_to_loc(idxin(i)) = ix + end if + end if + !$OMP END CRITICAL(LISTINS) +#else ix = idxmap%local_cols + 1 call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) if (info /= 0) then info = -4 - return + else + idxmap%local_cols = ix + idxmap%loc_to_glob(ix) = idxin(i) + idxmap%glob_to_loc(idxin(i)) = ix end if - idxmap%local_cols = ix - idxmap%loc_to_glob(ix) = idxin(i) - idxmap%glob_to_loc(idxin(i)) = ix +#endif end if idxout(i) = ix else @@ -713,18 +839,36 @@ contains else if (.not.present(mask)) then do i=1, is + if (info /= 0) cycle if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then ix = idxmap%glob_to_loc(idxin(i)) if (ix < 0) then +#if defined(OPENMP) + !$OMP CRITICAL(LISTINS) + ix = idxmap%glob_to_loc(idxin(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 + else + idxmap%local_cols = ix + idxmap%loc_to_glob(ix) = idxin(i) + idxmap%glob_to_loc(idxin(i)) = ix + end if + end if + !$OMP END CRITICAL(LISTINS) +#else 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) = idxin(i) - idxmap%glob_to_loc(idxin(i)) = ix + else + idxmap%local_cols = ix + idxmap%loc_to_glob(ix) = idxin(i) + idxmap%glob_to_loc(idxin(i)) = ix + end if +#endif end if idxout(i) = ix else diff --git a/base/modules/desc/psb_repl_map_mod.f90 b/base/modules/desc/psb_repl_map_mod.F90 similarity index 100% rename from base/modules/desc/psb_repl_map_mod.f90 rename to base/modules/desc/psb_repl_map_mod.F90 diff --git a/base/modules/penv/psi_c_collective_mod.F90 b/base/modules/penv/psi_c_collective_mod.F90 index 6da00176a..8da302d00 100644 --- a/base/modules/penv/psi_c_collective_mod.F90 +++ b/base/modules/penv/psi_c_collective_mod.F90 @@ -34,6 +34,14 @@ module psi_c_collective_mod use psb_desc_const_mod + interface psb_gather + module procedure psb_cgather_s, psb_cgather_v + end interface psb_gather + + interface psb_gatherv + module procedure psb_cgatherv_v + end interface + interface psb_sum module procedure psb_csums, psb_csumv, psb_csumm end interface @@ -76,6 +84,250 @@ contains + ! + ! gather + ! + subroutine psb_cgather_s(ctxt,dat,resv,root,mode,request) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + complex(psb_spk_), intent(inout) :: dat, resv(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_ipk_), intent(in), optional :: mode + integer(psb_mpk_), intent(inout), optional :: request + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: status(mpi_status_size) + logical :: collective_start, collective_end, collective_sync + +#if defined(SERIAL_MPI) + resv(0) = dat +#else + call psb_info(ctxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + icomm = psb_get_mpi_comm(ctxt) + if (present(mode)) then + collective_sync = .false. + collective_start = iand(mode,psb_collective_start_) /= 0 + collective_end = iand(mode,psb_collective_end_) /= 0 + if (.not.present(request)) then + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + else + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + if (collective_sync) then + if (root_ == -1) then + call mpi_allgather(dat,1,psb_mpi_c_spk_,& + & resv,1,psb_mpi_c_spk_,icomm,info) + else + call mpi_gather(dat,1,psb_mpi_c_spk_,& + & resv,1,psb_mpi_c_spk_,root_,icomm,info) + endif + else + if (collective_start) then + if (root_ == -1) then + call mpi_iallgather(dat,1,psb_mpi_c_spk_,& + & resv,1,psb_mpi_c_spk_,icomm,request,info) + else + call mpi_igather(dat,1,psb_mpi_c_spk_,& + & resv,1,psb_mpi_c_spk_,root_,icomm,request,info) + endif + else if (collective_end) then + call mpi_wait(request,status,info) + end if + end if +#endif + end subroutine psb_cgather_s + + subroutine psb_cgather_v(ctxt,dat,resv,root,mode,request) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + complex(psb_spk_), intent(inout) :: dat(:), resv(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_ipk_), intent(in), optional :: mode + integer(psb_mpk_), intent(inout), optional :: request + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: status(mpi_status_size) + logical :: collective_start, collective_end, collective_sync + +#if defined(SERIAL_MPI) + resv(0) = dat +#else + call psb_info(ctxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + icomm = psb_get_mpi_comm(ctxt) + if (present(mode)) then + collective_sync = .false. + collective_start = iand(mode,psb_collective_start_) /= 0 + collective_end = iand(mode,psb_collective_end_) /= 0 + if (.not.present(request)) then + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + else + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + if (collective_sync) then + if (root_ == -1) then + call mpi_allgather(dat,size(dat),psb_mpi_c_spk_,& + & resv,size(dat),psb_mpi_c_spk_,icomm,info) + else + call mpi_gather(dat,size(dat),psb_mpi_c_spk_,& + & resv,size(dat),psb_mpi_c_spk_,root_,icomm,info) + endif + else + if (collective_start) then + if (root_ == -1) then + call mpi_iallgather(dat,size(dat),psb_mpi_c_spk_,& + & resv,size(dat),psb_mpi_c_spk_,icomm,request,info) + else + call mpi_igather(dat,size(dat),psb_mpi_c_spk_,& + & resv,size(dat),psb_mpi_c_spk_,root_,icomm,request,info) + endif + else if (collective_end) then + call mpi_wait(request,status,info) + end if + end if +#endif + end subroutine psb_cgather_v + + subroutine psb_cgatherv_v(ctxt,dat,resv,szs,root,mode,request) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + complex(psb_spk_), intent(inout) :: dat(:), resv(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_), intent(in), optional :: szs(:) + integer(psb_ipk_), intent(in), optional :: mode + integer(psb_mpk_), intent(inout), optional :: request + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info,i + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: status(mpi_status_size) + integer(psb_mpk_), allocatable :: displs(:) + logical :: collective_start, collective_end, collective_sync + +#if defined(SERIAL_MPI) + resv(0) = dat +#else + call psb_info(ctxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + icomm = psb_get_mpi_comm(ctxt) + if (present(mode)) then + collective_sync = .false. + collective_start = iand(mode,psb_collective_start_) /= 0 + collective_end = iand(mode,psb_collective_end_) /= 0 + if (.not.present(request)) then + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + else + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + if (collective_sync) then + if (root_ == -1) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + call mpi_allgatherv(dat,size(dat),psb_mpi_c_spk_,& + & resv,szs,displs,psb_mpi_c_spk_,icomm,info) + else + if (iam == root_) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + else + allocate(displs(0)) + end if + call mpi_gatherv(dat,size(dat),psb_mpi_c_spk_,& + & resv,szs,displs,psb_mpi_c_spk_,root_,icomm,info) + endif + else + if (collective_start) then + if (root_ == -1) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + call mpi_iallgatherv(dat,size(dat),psb_mpi_c_spk_,& + & resv,szs,displs,psb_mpi_c_spk_,icomm,request,info) + else + if (iam == root_) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + else + allocate(displs(0)) + end if + call mpi_igatherv(dat,size(dat),psb_mpi_c_spk_,& + & resv,szs,displs,psb_mpi_c_spk_,root_,icomm,request,info) + endif + + else if (collective_end) then + call mpi_wait(request,status,info) + end if + end if +#endif + end subroutine psb_cgatherv_v + + + ! ! SUM ! @@ -124,20 +376,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_c_spk_,mpi_sum,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_c_spk_,mpi_sum,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_c_spk_,mpi_sum,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_c_spk_,mpi_sum,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_c_spk_,mpi_sum,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_c_spk_,mpi_sum,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_c_spk_,mpi_sum,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_c_spk_,mpi_sum,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -190,20 +452,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_spk_,mpi_sum,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_c_spk_,mpi_sum,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_c_spk_,mpi_sum,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_c_spk_,mpi_sum,root_,icomm,info) + end if end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_spk_,mpi_sum,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_spk_,mpi_sum,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_c_spk_,mpi_sum,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -258,20 +530,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_spk_,mpi_sum,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_c_spk_,mpi_sum,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_c_spk_,mpi_sum,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_c_spk_,mpi_sum,root_,icomm,info) + end if end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_spk_,mpi_sum,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_c_spk_,mpi_sum,root_, icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_c_spk_,mpi_sum,root_, icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_c_spk_,mpi_sum,root_, icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -328,20 +610,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_c_spk_,mpi_camx_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_c_spk_,mpi_camx_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_c_spk_,mpi_camx_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_c_spk_,mpi_camx_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_c_spk_,mpi_camx_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_c_spk_,mpi_camx_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_c_spk_,mpi_camx_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_c_spk_,mpi_camx_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -395,20 +687,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& psb_mpi_c_spk_,mpi_camx_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_spk_,mpi_camx_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_c_spk_,mpi_camx_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_spk_,mpi_camx_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_c_spk_,mpi_camx_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_c_spk_,mpi_camx_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_c_spk_,mpi_camx_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -463,20 +765,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_spk_,mpi_camx_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_c_spk_,mpi_camx_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_c_spk_,mpi_camx_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_c_spk_,mpi_camx_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_spk_,mpi_camx_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_c_spk_,mpi_camx_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& & psb_mpi_c_spk_,mpi_camx_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -532,20 +844,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_c_spk_,mpi_camn_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_c_spk_,mpi_camn_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_c_spk_,mpi_camn_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_c_spk_,mpi_camn_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_c_spk_,mpi_camn_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_c_spk_,mpi_camn_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_c_spk_,mpi_camn_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_c_spk_,mpi_camn_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -599,20 +921,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_spk_,mpi_camn_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_spk_,mpi_camn_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_c_spk_,mpi_camn_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_spk_,mpi_camn_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_c_spk_,mpi_camn_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_c_spk_,mpi_camn_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_c_spk_,mpi_camn_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -667,20 +999,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_spk_,mpi_camn_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_c_spk_,mpi_camn_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_c_spk_,mpi_camn_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_c_spk_,mpi_camn_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_spk_,mpi_camn_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_c_spk_,mpi_camn_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_c_spk_,mpi_camn_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_c_spk_,mpi_camn_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -901,12 +1243,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_scan(MPI_IN_PLACE,dat,1,& + call mpi_scan(dat_,dat,1,& & psb_mpi_c_spk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iscan(MPI_IN_PLACE,dat,1,& + call mpi_iscan(dat_,dat,1,& & psb_mpi_c_spk_,mpi_sum,icomm,request,minfo) else if (collective_end) then call mpi_wait(request,status,minfo) @@ -952,12 +1295,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_exscan(MPI_IN_PLACE,dat,1,& + call mpi_exscan(dat_,dat,1,& & psb_mpi_c_spk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iexscan(MPI_IN_PLACE,dat,1,& + call mpi_iexscan(dat_,dat,1,& & psb_mpi_c_spk_,mpi_sum,icomm,request,minfo) else if (collective_end) then call mpi_wait(request,status,minfo) @@ -980,12 +1324,13 @@ contains complex(psb_spk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: mode integer(psb_mpk_), intent(inout), optional :: request + integer(psb_ipk_) :: iam, np, info integer(psb_mpk_) :: minfo integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync - + complex(psb_spk_), allocatable :: dat_(:) #if !defined(SERIAL_MPI) call psb_info(ctxt,iam,np) icomm = psb_get_mpi_comm(ctxt) @@ -1003,12 +1348,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_scan(MPI_IN_PLACE,dat,size(dat),& + call mpi_scan(dat_,dat,size(dat),& & psb_mpi_c_spk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iscan(MPI_IN_PLACE,dat,size(dat),& + call mpi_iscan(dat_,dat,size(dat),& & psb_mpi_c_spk_,mpi_sum,icomm,request,info) else if (collective_end) then call mpi_wait(request,status,info) @@ -1029,12 +1375,13 @@ contains complex(psb_spk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: mode integer(psb_mpk_), intent(inout), optional :: request - complex(psb_spk_), allocatable :: dat_(:) + integer(psb_ipk_) :: iam, np, info integer(psb_mpk_) :: minfo integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + complex(psb_spk_), allocatable :: dat_(:) #if !defined(SERIAL_MPI) call psb_info(ctxt,iam,np) @@ -1053,12 +1400,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_exscan(MPI_IN_PLACE,dat,size(dat),& + call mpi_exscan(dat_,dat,size(dat),& & psb_mpi_c_spk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iexscan(MPI_IN_PLACE,dat,size(dat),& + call mpi_iexscan(dat_,dat,size(dat),& & psb_mpi_c_spk_,mpi_sum,icomm,request,info) else if (collective_end) then call mpi_wait(request,status,info) @@ -1271,6 +1619,5 @@ contains Enddo end subroutine psb_c_e_simple_triad_a2av - end module psi_c_collective_mod diff --git a/base/modules/penv/psi_d_collective_mod.F90 b/base/modules/penv/psi_d_collective_mod.F90 index 1f91c69ec..9639d650e 100644 --- a/base/modules/penv/psi_d_collective_mod.F90 +++ b/base/modules/penv/psi_d_collective_mod.F90 @@ -45,6 +45,14 @@ module psi_d_collective_mod module procedure psb_d_nrm2s, psb_d_nrm2v end interface psb_nrm2 + interface psb_gather + module procedure psb_dgather_s, psb_dgather_v + end interface psb_gather + + interface psb_gatherv + module procedure psb_dgatherv_v + end interface + interface psb_sum module procedure psb_dsums, psb_dsumv, psb_dsumm end interface @@ -110,6 +118,7 @@ contains integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + real(psb_dpk_) :: dat_ #if !defined(SERIAL_MPI) call psb_info(ctxt,iam,np) @@ -134,20 +143,29 @@ contains collective_start = .false. collective_end = .false. end if - if (collective_sync) then + if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,psb_mpi_r_dpk_,mpi_max,icomm,info) + call mpi_allreduce(mpi_in_place,dat,1,psb_mpi_r_dpk_,mpi_max,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,psb_mpi_r_dpk_,mpi_max,root_,icomm,info) + if (iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,psb_mpi_r_dpk_,mpi_max,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,psb_mpi_r_dpk_,mpi_max,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_r_dpk_,mpi_max,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_r_dpk_,mpi_max,root_,icomm,request,info) + if (iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_r_dpk_,mpi_max,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_r_dpk_,mpi_max,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -174,6 +192,7 @@ contains integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + real(psb_dpk_) :: dat_(1) ! This is a dummy #if !defined(SERIAL_MPI) @@ -200,21 +219,31 @@ contains collective_end = .false. end if if (collective_sync) then - if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + if (root_ == -1) then + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_max,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_dpk_,mpi_max,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_max,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_max,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_max,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_dpk_,mpi_max,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_max,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_max,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -242,6 +271,7 @@ contains integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + real(psb_dpk_) :: dat_(1,1) ! this is a dummy #if !defined(SERIAL_MPI) @@ -268,28 +298,37 @@ contains collective_start = .false. collective_end = .false. end if - if (collective_sync) then + if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_max,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_dpk_,mpi_max,root_,icomm,info) - endif + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_max,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_max,root_,icomm,info) + endif + end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_max,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_dpk_,mpi_max,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_max,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_max,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) end if end if - #endif end subroutine psb_dmaxm @@ -340,18 +379,27 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,psb_mpi_r_dpk_,mpi_min,icomm,info) + call mpi_allreduce(mpi_in_place,dat,1,psb_mpi_r_dpk_,mpi_min,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,psb_mpi_r_dpk_,mpi_min,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,psb_mpi_r_dpk_,mpi_min,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,psb_mpi_r_dpk_,mpi_min,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_r_dpk_,mpi_min,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_r_dpk_,mpi_min,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_r_dpk_,mpi_min,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_r_dpk_,mpi_min,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -405,20 +453,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_min,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_dpk_,mpi_min,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_min,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_min,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_min,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_dpk_,mpi_min,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_min,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_min,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -473,20 +531,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_min,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_dpk_,mpi_min,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_min,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_min,root_,icomm,info) + end if end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_min,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_dpk_,mpi_min,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_min,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_min,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -545,20 +613,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_r_dpk_,mpi_dnrm2_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_r_dpk_,mpi_dnrm2_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_r_dpk_,mpi_dnrm2_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_r_dpk_,mpi_dnrm2_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_r_dpk_,mpi_dnrm2_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_r_dpk_,mpi_dnrm2_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_r_dpk_,mpi_dnrm2_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_r_dpk_,mpi_dnrm2_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -612,20 +690,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_dpk_,& + call mpi_allreduce(mpi_in_place,dat,size(dat),psb_mpi_r_dpk_,& & mpi_dnrm2_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_dpk_,& - & mpi_dnrm2_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),psb_mpi_r_dpk_,& + & mpi_dnrm2_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),psb_mpi_r_dpk_,& + & mpi_dnrm2_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_dnrm2_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_dpk_,mpi_dnrm2_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_dnrm2_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_dnrm2_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -636,6 +724,250 @@ contains end subroutine psb_d_nrm2v + ! + ! gather + ! + subroutine psb_dgather_s(ctxt,dat,resv,root,mode,request) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + real(psb_dpk_), intent(inout) :: dat, resv(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_ipk_), intent(in), optional :: mode + integer(psb_mpk_), intent(inout), optional :: request + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: status(mpi_status_size) + logical :: collective_start, collective_end, collective_sync + +#if defined(SERIAL_MPI) + resv(0) = dat +#else + call psb_info(ctxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + icomm = psb_get_mpi_comm(ctxt) + if (present(mode)) then + collective_sync = .false. + collective_start = iand(mode,psb_collective_start_) /= 0 + collective_end = iand(mode,psb_collective_end_) /= 0 + if (.not.present(request)) then + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + else + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + if (collective_sync) then + if (root_ == -1) then + call mpi_allgather(dat,1,psb_mpi_r_dpk_,& + & resv,1,psb_mpi_r_dpk_,icomm,info) + else + call mpi_gather(dat,1,psb_mpi_r_dpk_,& + & resv,1,psb_mpi_r_dpk_,root_,icomm,info) + endif + else + if (collective_start) then + if (root_ == -1) then + call mpi_iallgather(dat,1,psb_mpi_r_dpk_,& + & resv,1,psb_mpi_r_dpk_,icomm,request,info) + else + call mpi_igather(dat,1,psb_mpi_r_dpk_,& + & resv,1,psb_mpi_r_dpk_,root_,icomm,request,info) + endif + else if (collective_end) then + call mpi_wait(request,status,info) + end if + end if +#endif + end subroutine psb_dgather_s + + subroutine psb_dgather_v(ctxt,dat,resv,root,mode,request) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + real(psb_dpk_), intent(inout) :: dat(:), resv(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_ipk_), intent(in), optional :: mode + integer(psb_mpk_), intent(inout), optional :: request + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: status(mpi_status_size) + logical :: collective_start, collective_end, collective_sync + +#if defined(SERIAL_MPI) + resv(0) = dat +#else + call psb_info(ctxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + icomm = psb_get_mpi_comm(ctxt) + if (present(mode)) then + collective_sync = .false. + collective_start = iand(mode,psb_collective_start_) /= 0 + collective_end = iand(mode,psb_collective_end_) /= 0 + if (.not.present(request)) then + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + else + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + if (collective_sync) then + if (root_ == -1) then + call mpi_allgather(dat,size(dat),psb_mpi_r_dpk_,& + & resv,size(dat),psb_mpi_r_dpk_,icomm,info) + else + call mpi_gather(dat,size(dat),psb_mpi_r_dpk_,& + & resv,size(dat),psb_mpi_r_dpk_,root_,icomm,info) + endif + else + if (collective_start) then + if (root_ == -1) then + call mpi_iallgather(dat,size(dat),psb_mpi_r_dpk_,& + & resv,size(dat),psb_mpi_r_dpk_,icomm,request,info) + else + call mpi_igather(dat,size(dat),psb_mpi_r_dpk_,& + & resv,size(dat),psb_mpi_r_dpk_,root_,icomm,request,info) + endif + else if (collective_end) then + call mpi_wait(request,status,info) + end if + end if +#endif + end subroutine psb_dgather_v + + subroutine psb_dgatherv_v(ctxt,dat,resv,szs,root,mode,request) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + real(psb_dpk_), intent(inout) :: dat(:), resv(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_), intent(in), optional :: szs(:) + integer(psb_ipk_), intent(in), optional :: mode + integer(psb_mpk_), intent(inout), optional :: request + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info,i + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: status(mpi_status_size) + integer(psb_mpk_), allocatable :: displs(:) + logical :: collective_start, collective_end, collective_sync + +#if defined(SERIAL_MPI) + resv(0) = dat +#else + call psb_info(ctxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + icomm = psb_get_mpi_comm(ctxt) + if (present(mode)) then + collective_sync = .false. + collective_start = iand(mode,psb_collective_start_) /= 0 + collective_end = iand(mode,psb_collective_end_) /= 0 + if (.not.present(request)) then + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + else + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + if (collective_sync) then + if (root_ == -1) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + call mpi_allgatherv(dat,size(dat),psb_mpi_r_dpk_,& + & resv,szs,displs,psb_mpi_r_dpk_,icomm,info) + else + if (iam == root_) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + else + allocate(displs(0)) + end if + call mpi_gatherv(dat,size(dat),psb_mpi_r_dpk_,& + & resv,szs,displs,psb_mpi_r_dpk_,root_,icomm,info) + endif + else + if (collective_start) then + if (root_ == -1) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + call mpi_iallgatherv(dat,size(dat),psb_mpi_r_dpk_,& + & resv,szs,displs,psb_mpi_r_dpk_,icomm,request,info) + else + if (iam == root_) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + else + allocate(displs(0)) + end if + call mpi_igatherv(dat,size(dat),psb_mpi_r_dpk_,& + & resv,szs,displs,psb_mpi_r_dpk_,root_,icomm,request,info) + endif + + else if (collective_end) then + call mpi_wait(request,status,info) + end if + end if +#endif + end subroutine psb_dgatherv_v + + + ! ! SUM ! @@ -684,20 +1016,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_r_dpk_,mpi_sum,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_r_dpk_,mpi_sum,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_r_dpk_,mpi_sum,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_r_dpk_,mpi_sum,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_r_dpk_,mpi_sum,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_r_dpk_,mpi_sum,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_r_dpk_,mpi_sum,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_r_dpk_,mpi_sum,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -750,20 +1092,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_sum,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_dpk_,mpi_sum,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_sum,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_sum,root_,icomm,info) + end if end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_sum,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_sum,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_sum,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -818,20 +1170,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_sum,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_dpk_,mpi_sum,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_sum,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_sum,root_,icomm,info) + end if end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_sum,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_dpk_,mpi_sum,root_, icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_sum,root_, icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_sum,root_, icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -888,20 +1250,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_r_dpk_,mpi_damx_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_r_dpk_,mpi_damx_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -955,20 +1327,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& psb_mpi_r_dpk_,mpi_damx_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_damx_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -1023,20 +1405,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_damx_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_damx_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& & psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -1092,20 +1484,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_r_dpk_,mpi_damn_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_r_dpk_,mpi_damn_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -1159,20 +1561,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_damn_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_damn_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -1227,20 +1639,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_damn_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_dpk_,mpi_damn_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -1461,12 +1883,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_scan(MPI_IN_PLACE,dat,1,& + call mpi_scan(dat_,dat,1,& & psb_mpi_r_dpk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iscan(MPI_IN_PLACE,dat,1,& + call mpi_iscan(dat_,dat,1,& & psb_mpi_r_dpk_,mpi_sum,icomm,request,minfo) else if (collective_end) then call mpi_wait(request,status,minfo) @@ -1512,12 +1935,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_exscan(MPI_IN_PLACE,dat,1,& + call mpi_exscan(dat_,dat,1,& & psb_mpi_r_dpk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iexscan(MPI_IN_PLACE,dat,1,& + call mpi_iexscan(dat_,dat,1,& & psb_mpi_r_dpk_,mpi_sum,icomm,request,minfo) else if (collective_end) then call mpi_wait(request,status,minfo) @@ -1540,12 +1964,13 @@ contains real(psb_dpk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: mode integer(psb_mpk_), intent(inout), optional :: request + integer(psb_ipk_) :: iam, np, info integer(psb_mpk_) :: minfo integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync - + real(psb_dpk_), allocatable :: dat_(:) #if !defined(SERIAL_MPI) call psb_info(ctxt,iam,np) icomm = psb_get_mpi_comm(ctxt) @@ -1563,12 +1988,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_scan(MPI_IN_PLACE,dat,size(dat),& + call mpi_scan(dat_,dat,size(dat),& & psb_mpi_r_dpk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iscan(MPI_IN_PLACE,dat,size(dat),& + call mpi_iscan(dat_,dat,size(dat),& & psb_mpi_r_dpk_,mpi_sum,icomm,request,info) else if (collective_end) then call mpi_wait(request,status,info) @@ -1589,12 +2015,13 @@ contains real(psb_dpk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: mode integer(psb_mpk_), intent(inout), optional :: request - real(psb_dpk_), allocatable :: dat_(:) + integer(psb_ipk_) :: iam, np, info integer(psb_mpk_) :: minfo integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + real(psb_dpk_), allocatable :: dat_(:) #if !defined(SERIAL_MPI) call psb_info(ctxt,iam,np) @@ -1613,12 +2040,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_exscan(MPI_IN_PLACE,dat,size(dat),& + call mpi_exscan(dat_,dat,size(dat),& & psb_mpi_r_dpk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iexscan(MPI_IN_PLACE,dat,size(dat),& + call mpi_iexscan(dat_,dat,size(dat),& & psb_mpi_r_dpk_,mpi_sum,icomm,request,info) else if (collective_end) then call mpi_wait(request,status,info) @@ -1831,6 +2259,5 @@ contains Enddo end subroutine psb_d_e_simple_triad_a2av - end module psi_d_collective_mod diff --git a/base/modules/penv/psi_e_collective_mod.F90 b/base/modules/penv/psi_e_collective_mod.F90 index 7f57f2a65..b9ab089b2 100644 --- a/base/modules/penv/psi_e_collective_mod.F90 +++ b/base/modules/penv/psi_e_collective_mod.F90 @@ -42,6 +42,14 @@ module psi_e_collective_mod end interface psb_min + interface psb_gather + module procedure psb_egather_s, psb_egather_v + end interface psb_gather + + interface psb_gatherv + module procedure psb_egatherv_v + end interface + interface psb_sum module procedure psb_esums, psb_esumv, psb_esumm end interface @@ -107,6 +115,7 @@ contains integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + integer(psb_epk_) :: dat_ #if !defined(SERIAL_MPI) call psb_info(ctxt,iam,np) @@ -131,20 +140,29 @@ contains collective_start = .false. collective_end = .false. end if - if (collective_sync) then + if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,psb_mpi_epk_,mpi_max,icomm,info) + call mpi_allreduce(mpi_in_place,dat,1,psb_mpi_epk_,mpi_max,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,psb_mpi_epk_,mpi_max,root_,icomm,info) + if (iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,psb_mpi_epk_,mpi_max,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,psb_mpi_epk_,mpi_max,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_epk_,mpi_max,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_epk_,mpi_max,root_,icomm,request,info) + if (iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_epk_,mpi_max,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_epk_,mpi_max,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -171,6 +189,7 @@ contains integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + integer(psb_epk_) :: dat_(1) ! This is a dummy #if !defined(SERIAL_MPI) @@ -197,21 +216,31 @@ contains collective_end = .false. end if if (collective_sync) then - if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + if (root_ == -1) then + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_max,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_epk_,mpi_max,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_epk_,mpi_max,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_epk_,mpi_max,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_max,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_epk_,mpi_max,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_epk_,mpi_max,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_epk_,mpi_max,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -239,6 +268,7 @@ contains integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + integer(psb_epk_) :: dat_(1,1) ! this is a dummy #if !defined(SERIAL_MPI) @@ -265,28 +295,37 @@ contains collective_start = .false. collective_end = .false. end if - if (collective_sync) then + if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_max,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_epk_,mpi_max,root_,icomm,info) - endif + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_epk_,mpi_max,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_epk_,mpi_max,root_,icomm,info) + endif + end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_max,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_epk_,mpi_max,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_epk_,mpi_max,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_epk_,mpi_max,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) end if end if - #endif end subroutine psb_emaxm @@ -337,18 +376,27 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,psb_mpi_epk_,mpi_min,icomm,info) + call mpi_allreduce(mpi_in_place,dat,1,psb_mpi_epk_,mpi_min,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,psb_mpi_epk_,mpi_min,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,psb_mpi_epk_,mpi_min,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,psb_mpi_epk_,mpi_min,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_epk_,mpi_min,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_epk_,mpi_min,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_epk_,mpi_min,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_epk_,mpi_min,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -402,20 +450,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_min,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_epk_,mpi_min,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_epk_,mpi_min,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_epk_,mpi_min,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_min,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_epk_,mpi_min,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_epk_,mpi_min,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_epk_,mpi_min,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -470,20 +528,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_min,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_epk_,mpi_min,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_epk_,mpi_min,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_epk_,mpi_min,root_,icomm,info) + end if end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_min,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_epk_,mpi_min,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_epk_,mpi_min,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_epk_,mpi_min,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -494,6 +562,250 @@ contains + ! + ! gather + ! + subroutine psb_egather_s(ctxt,dat,resv,root,mode,request) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_epk_), intent(inout) :: dat, resv(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_ipk_), intent(in), optional :: mode + integer(psb_mpk_), intent(inout), optional :: request + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: status(mpi_status_size) + logical :: collective_start, collective_end, collective_sync + +#if defined(SERIAL_MPI) + resv(0) = dat +#else + call psb_info(ctxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + icomm = psb_get_mpi_comm(ctxt) + if (present(mode)) then + collective_sync = .false. + collective_start = iand(mode,psb_collective_start_) /= 0 + collective_end = iand(mode,psb_collective_end_) /= 0 + if (.not.present(request)) then + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + else + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + if (collective_sync) then + if (root_ == -1) then + call mpi_allgather(dat,1,psb_mpi_epk_,& + & resv,1,psb_mpi_epk_,icomm,info) + else + call mpi_gather(dat,1,psb_mpi_epk_,& + & resv,1,psb_mpi_epk_,root_,icomm,info) + endif + else + if (collective_start) then + if (root_ == -1) then + call mpi_iallgather(dat,1,psb_mpi_epk_,& + & resv,1,psb_mpi_epk_,icomm,request,info) + else + call mpi_igather(dat,1,psb_mpi_epk_,& + & resv,1,psb_mpi_epk_,root_,icomm,request,info) + endif + else if (collective_end) then + call mpi_wait(request,status,info) + end if + end if +#endif + end subroutine psb_egather_s + + subroutine psb_egather_v(ctxt,dat,resv,root,mode,request) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_epk_), intent(inout) :: dat(:), resv(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_ipk_), intent(in), optional :: mode + integer(psb_mpk_), intent(inout), optional :: request + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: status(mpi_status_size) + logical :: collective_start, collective_end, collective_sync + +#if defined(SERIAL_MPI) + resv(0) = dat +#else + call psb_info(ctxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + icomm = psb_get_mpi_comm(ctxt) + if (present(mode)) then + collective_sync = .false. + collective_start = iand(mode,psb_collective_start_) /= 0 + collective_end = iand(mode,psb_collective_end_) /= 0 + if (.not.present(request)) then + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + else + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + if (collective_sync) then + if (root_ == -1) then + call mpi_allgather(dat,size(dat),psb_mpi_epk_,& + & resv,size(dat),psb_mpi_epk_,icomm,info) + else + call mpi_gather(dat,size(dat),psb_mpi_epk_,& + & resv,size(dat),psb_mpi_epk_,root_,icomm,info) + endif + else + if (collective_start) then + if (root_ == -1) then + call mpi_iallgather(dat,size(dat),psb_mpi_epk_,& + & resv,size(dat),psb_mpi_epk_,icomm,request,info) + else + call mpi_igather(dat,size(dat),psb_mpi_epk_,& + & resv,size(dat),psb_mpi_epk_,root_,icomm,request,info) + endif + else if (collective_end) then + call mpi_wait(request,status,info) + end if + end if +#endif + end subroutine psb_egather_v + + subroutine psb_egatherv_v(ctxt,dat,resv,szs,root,mode,request) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_epk_), intent(inout) :: dat(:), resv(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_), intent(in), optional :: szs(:) + integer(psb_ipk_), intent(in), optional :: mode + integer(psb_mpk_), intent(inout), optional :: request + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info,i + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: status(mpi_status_size) + integer(psb_mpk_), allocatable :: displs(:) + logical :: collective_start, collective_end, collective_sync + +#if defined(SERIAL_MPI) + resv(0) = dat +#else + call psb_info(ctxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + icomm = psb_get_mpi_comm(ctxt) + if (present(mode)) then + collective_sync = .false. + collective_start = iand(mode,psb_collective_start_) /= 0 + collective_end = iand(mode,psb_collective_end_) /= 0 + if (.not.present(request)) then + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + else + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + if (collective_sync) then + if (root_ == -1) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + call mpi_allgatherv(dat,size(dat),psb_mpi_epk_,& + & resv,szs,displs,psb_mpi_epk_,icomm,info) + else + if (iam == root_) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + else + allocate(displs(0)) + end if + call mpi_gatherv(dat,size(dat),psb_mpi_epk_,& + & resv,szs,displs,psb_mpi_epk_,root_,icomm,info) + endif + else + if (collective_start) then + if (root_ == -1) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + call mpi_iallgatherv(dat,size(dat),psb_mpi_epk_,& + & resv,szs,displs,psb_mpi_epk_,icomm,request,info) + else + if (iam == root_) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + else + allocate(displs(0)) + end if + call mpi_igatherv(dat,size(dat),psb_mpi_epk_,& + & resv,szs,displs,psb_mpi_epk_,root_,icomm,request,info) + endif + + else if (collective_end) then + call mpi_wait(request,status,info) + end if + end if +#endif + end subroutine psb_egatherv_v + + + ! ! SUM ! @@ -542,20 +854,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_epk_,mpi_sum,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_epk_,mpi_sum,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_epk_,mpi_sum,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_epk_,mpi_sum,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_epk_,mpi_sum,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_epk_,mpi_sum,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_epk_,mpi_sum,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_epk_,mpi_sum,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -608,20 +930,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_sum,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_epk_,mpi_sum,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_epk_,mpi_sum,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_epk_,mpi_sum,root_,icomm,info) + end if end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_sum,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_sum,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_epk_,mpi_sum,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -676,20 +1008,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_sum,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_epk_,mpi_sum,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_epk_,mpi_sum,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_epk_,mpi_sum,root_,icomm,info) + end if end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_sum,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_epk_,mpi_sum,root_, icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_epk_,mpi_sum,root_, icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_epk_,mpi_sum,root_, icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -746,20 +1088,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_epk_,mpi_eamx_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_epk_,mpi_eamx_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_epk_,mpi_eamx_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_epk_,mpi_eamx_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_epk_,mpi_eamx_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_epk_,mpi_eamx_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_epk_,mpi_eamx_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_epk_,mpi_eamx_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -813,20 +1165,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& psb_mpi_epk_,mpi_eamx_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_eamx_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_epk_,mpi_eamx_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_eamx_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_epk_,mpi_eamx_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_epk_,mpi_eamx_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_epk_,mpi_eamx_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -881,20 +1243,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_eamx_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_epk_,mpi_eamx_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_epk_,mpi_eamx_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_epk_,mpi_eamx_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_eamx_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_epk_,mpi_eamx_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& & psb_mpi_epk_,mpi_eamx_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -950,20 +1322,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_epk_,mpi_eamn_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_epk_,mpi_eamn_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_epk_,mpi_eamn_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_epk_,mpi_eamn_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_epk_,mpi_eamn_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_epk_,mpi_eamn_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_epk_,mpi_eamn_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_epk_,mpi_eamn_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -1017,20 +1399,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_eamn_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_eamn_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_epk_,mpi_eamn_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_eamn_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_epk_,mpi_eamn_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_epk_,mpi_eamn_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_epk_,mpi_eamn_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -1085,20 +1477,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_eamn_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_epk_,mpi_eamn_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_epk_,mpi_eamn_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_epk_,mpi_eamn_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_epk_,mpi_eamn_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_epk_,mpi_eamn_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_epk_,mpi_eamn_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_epk_,mpi_eamn_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -1319,12 +1721,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_scan(MPI_IN_PLACE,dat,1,& + call mpi_scan(dat_,dat,1,& & psb_mpi_epk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iscan(MPI_IN_PLACE,dat,1,& + call mpi_iscan(dat_,dat,1,& & psb_mpi_epk_,mpi_sum,icomm,request,minfo) else if (collective_end) then call mpi_wait(request,status,minfo) @@ -1370,12 +1773,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_exscan(MPI_IN_PLACE,dat,1,& + call mpi_exscan(dat_,dat,1,& & psb_mpi_epk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iexscan(MPI_IN_PLACE,dat,1,& + call mpi_iexscan(dat_,dat,1,& & psb_mpi_epk_,mpi_sum,icomm,request,minfo) else if (collective_end) then call mpi_wait(request,status,minfo) @@ -1398,12 +1802,13 @@ contains integer(psb_epk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: mode integer(psb_mpk_), intent(inout), optional :: request + integer(psb_ipk_) :: iam, np, info integer(psb_mpk_) :: minfo integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync - + integer(psb_epk_), allocatable :: dat_(:) #if !defined(SERIAL_MPI) call psb_info(ctxt,iam,np) icomm = psb_get_mpi_comm(ctxt) @@ -1421,12 +1826,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_scan(MPI_IN_PLACE,dat,size(dat),& + call mpi_scan(dat_,dat,size(dat),& & psb_mpi_epk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iscan(MPI_IN_PLACE,dat,size(dat),& + call mpi_iscan(dat_,dat,size(dat),& & psb_mpi_epk_,mpi_sum,icomm,request,info) else if (collective_end) then call mpi_wait(request,status,info) @@ -1447,12 +1853,13 @@ contains integer(psb_epk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: mode integer(psb_mpk_), intent(inout), optional :: request - integer(psb_epk_), allocatable :: dat_(:) + integer(psb_ipk_) :: iam, np, info integer(psb_mpk_) :: minfo integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + integer(psb_epk_), allocatable :: dat_(:) #if !defined(SERIAL_MPI) call psb_info(ctxt,iam,np) @@ -1471,12 +1878,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_exscan(MPI_IN_PLACE,dat,size(dat),& + call mpi_exscan(dat_,dat,size(dat),& & psb_mpi_epk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iexscan(MPI_IN_PLACE,dat,size(dat),& + call mpi_iexscan(dat_,dat,size(dat),& & psb_mpi_epk_,mpi_sum,icomm,request,info) else if (collective_end) then call mpi_wait(request,status,info) @@ -1689,6 +2097,5 @@ contains Enddo end subroutine psb_e_e_simple_triad_a2av - end module psi_e_collective_mod diff --git a/base/modules/penv/psi_i2_collective_mod.F90 b/base/modules/penv/psi_i2_collective_mod.F90 index bfe3bf354..339e42812 100644 --- a/base/modules/penv/psi_i2_collective_mod.F90 +++ b/base/modules/penv/psi_i2_collective_mod.F90 @@ -42,6 +42,14 @@ module psi_i2_collective_mod end interface psb_min + interface psb_gather + module procedure psb_i2gather_s, psb_i2gather_v + end interface psb_gather + + interface psb_gatherv + module procedure psb_i2gatherv_v + end interface + interface psb_sum module procedure psb_i2sums, psb_i2sumv, psb_i2summ end interface @@ -107,6 +115,7 @@ contains integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + integer(psb_i2pk_) :: dat_ #if !defined(SERIAL_MPI) call psb_info(ctxt,iam,np) @@ -131,20 +140,29 @@ contains collective_start = .false. collective_end = .false. end if - if (collective_sync) then + if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,psb_mpi_i2pk_,mpi_max,icomm,info) + call mpi_allreduce(mpi_in_place,dat,1,psb_mpi_i2pk_,mpi_max,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,psb_mpi_i2pk_,mpi_max,root_,icomm,info) + if (iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,psb_mpi_i2pk_,mpi_max,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,psb_mpi_i2pk_,mpi_max,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_i2pk_,mpi_max,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_i2pk_,mpi_max,root_,icomm,request,info) + if (iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_i2pk_,mpi_max,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_i2pk_,mpi_max,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -171,6 +189,7 @@ contains integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + integer(psb_i2pk_) :: dat_(1) ! This is a dummy #if !defined(SERIAL_MPI) @@ -197,21 +216,31 @@ contains collective_end = .false. end if if (collective_sync) then - if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + if (root_ == -1) then + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_max,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_i2pk_,mpi_max,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_i2pk_,mpi_max,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_i2pk_,mpi_max,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_max,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_i2pk_,mpi_max,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_i2pk_,mpi_max,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_i2pk_,mpi_max,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -239,6 +268,7 @@ contains integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + integer(psb_i2pk_) :: dat_(1,1) ! this is a dummy #if !defined(SERIAL_MPI) @@ -265,28 +295,37 @@ contains collective_start = .false. collective_end = .false. end if - if (collective_sync) then + if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_max,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_i2pk_,mpi_max,root_,icomm,info) - endif + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_i2pk_,mpi_max,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_i2pk_,mpi_max,root_,icomm,info) + endif + end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_max,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_i2pk_,mpi_max,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_i2pk_,mpi_max,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_i2pk_,mpi_max,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) end if end if - #endif end subroutine psb_i2maxm @@ -337,18 +376,27 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,psb_mpi_i2pk_,mpi_min,icomm,info) + call mpi_allreduce(mpi_in_place,dat,1,psb_mpi_i2pk_,mpi_min,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,psb_mpi_i2pk_,mpi_min,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,psb_mpi_i2pk_,mpi_min,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,psb_mpi_i2pk_,mpi_min,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_i2pk_,mpi_min,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_i2pk_,mpi_min,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_i2pk_,mpi_min,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_i2pk_,mpi_min,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -402,20 +450,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_min,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_i2pk_,mpi_min,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_i2pk_,mpi_min,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_i2pk_,mpi_min,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_min,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_i2pk_,mpi_min,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_i2pk_,mpi_min,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_i2pk_,mpi_min,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -470,20 +528,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_min,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_i2pk_,mpi_min,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_i2pk_,mpi_min,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_i2pk_,mpi_min,root_,icomm,info) + end if end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_min,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_i2pk_,mpi_min,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_i2pk_,mpi_min,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_i2pk_,mpi_min,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -494,6 +562,250 @@ contains + ! + ! gather + ! + subroutine psb_i2gather_s(ctxt,dat,resv,root,mode,request) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_i2pk_), intent(inout) :: dat, resv(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_ipk_), intent(in), optional :: mode + integer(psb_mpk_), intent(inout), optional :: request + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: status(mpi_status_size) + logical :: collective_start, collective_end, collective_sync + +#if defined(SERIAL_MPI) + resv(0) = dat +#else + call psb_info(ctxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + icomm = psb_get_mpi_comm(ctxt) + if (present(mode)) then + collective_sync = .false. + collective_start = iand(mode,psb_collective_start_) /= 0 + collective_end = iand(mode,psb_collective_end_) /= 0 + if (.not.present(request)) then + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + else + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + if (collective_sync) then + if (root_ == -1) then + call mpi_allgather(dat,1,psb_mpi_i2pk_,& + & resv,1,psb_mpi_i2pk_,icomm,info) + else + call mpi_gather(dat,1,psb_mpi_i2pk_,& + & resv,1,psb_mpi_i2pk_,root_,icomm,info) + endif + else + if (collective_start) then + if (root_ == -1) then + call mpi_iallgather(dat,1,psb_mpi_i2pk_,& + & resv,1,psb_mpi_i2pk_,icomm,request,info) + else + call mpi_igather(dat,1,psb_mpi_i2pk_,& + & resv,1,psb_mpi_i2pk_,root_,icomm,request,info) + endif + else if (collective_end) then + call mpi_wait(request,status,info) + end if + end if +#endif + end subroutine psb_i2gather_s + + subroutine psb_i2gather_v(ctxt,dat,resv,root,mode,request) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_i2pk_), intent(inout) :: dat(:), resv(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_ipk_), intent(in), optional :: mode + integer(psb_mpk_), intent(inout), optional :: request + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: status(mpi_status_size) + logical :: collective_start, collective_end, collective_sync + +#if defined(SERIAL_MPI) + resv(0) = dat +#else + call psb_info(ctxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + icomm = psb_get_mpi_comm(ctxt) + if (present(mode)) then + collective_sync = .false. + collective_start = iand(mode,psb_collective_start_) /= 0 + collective_end = iand(mode,psb_collective_end_) /= 0 + if (.not.present(request)) then + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + else + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + if (collective_sync) then + if (root_ == -1) then + call mpi_allgather(dat,size(dat),psb_mpi_i2pk_,& + & resv,size(dat),psb_mpi_i2pk_,icomm,info) + else + call mpi_gather(dat,size(dat),psb_mpi_i2pk_,& + & resv,size(dat),psb_mpi_i2pk_,root_,icomm,info) + endif + else + if (collective_start) then + if (root_ == -1) then + call mpi_iallgather(dat,size(dat),psb_mpi_i2pk_,& + & resv,size(dat),psb_mpi_i2pk_,icomm,request,info) + else + call mpi_igather(dat,size(dat),psb_mpi_i2pk_,& + & resv,size(dat),psb_mpi_i2pk_,root_,icomm,request,info) + endif + else if (collective_end) then + call mpi_wait(request,status,info) + end if + end if +#endif + end subroutine psb_i2gather_v + + subroutine psb_i2gatherv_v(ctxt,dat,resv,szs,root,mode,request) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_i2pk_), intent(inout) :: dat(:), resv(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_), intent(in), optional :: szs(:) + integer(psb_ipk_), intent(in), optional :: mode + integer(psb_mpk_), intent(inout), optional :: request + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info,i + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: status(mpi_status_size) + integer(psb_mpk_), allocatable :: displs(:) + logical :: collective_start, collective_end, collective_sync + +#if defined(SERIAL_MPI) + resv(0) = dat +#else + call psb_info(ctxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + icomm = psb_get_mpi_comm(ctxt) + if (present(mode)) then + collective_sync = .false. + collective_start = iand(mode,psb_collective_start_) /= 0 + collective_end = iand(mode,psb_collective_end_) /= 0 + if (.not.present(request)) then + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + else + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + if (collective_sync) then + if (root_ == -1) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + call mpi_allgatherv(dat,size(dat),psb_mpi_i2pk_,& + & resv,szs,displs,psb_mpi_i2pk_,icomm,info) + else + if (iam == root_) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + else + allocate(displs(0)) + end if + call mpi_gatherv(dat,size(dat),psb_mpi_i2pk_,& + & resv,szs,displs,psb_mpi_i2pk_,root_,icomm,info) + endif + else + if (collective_start) then + if (root_ == -1) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + call mpi_iallgatherv(dat,size(dat),psb_mpi_i2pk_,& + & resv,szs,displs,psb_mpi_i2pk_,icomm,request,info) + else + if (iam == root_) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + else + allocate(displs(0)) + end if + call mpi_igatherv(dat,size(dat),psb_mpi_i2pk_,& + & resv,szs,displs,psb_mpi_i2pk_,root_,icomm,request,info) + endif + + else if (collective_end) then + call mpi_wait(request,status,info) + end if + end if +#endif + end subroutine psb_i2gatherv_v + + + ! ! SUM ! @@ -542,20 +854,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_i2pk_,mpi_sum,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_i2pk_,mpi_sum,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_i2pk_,mpi_sum,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_i2pk_,mpi_sum,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_i2pk_,mpi_sum,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_i2pk_,mpi_sum,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_i2pk_,mpi_sum,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_i2pk_,mpi_sum,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -608,20 +930,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_sum,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_i2pk_,mpi_sum,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_i2pk_,mpi_sum,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_i2pk_,mpi_sum,root_,icomm,info) + end if end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_sum,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_sum,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_i2pk_,mpi_sum,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -676,20 +1008,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_sum,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_i2pk_,mpi_sum,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_i2pk_,mpi_sum,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_i2pk_,mpi_sum,root_,icomm,info) + end if end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_sum,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_i2pk_,mpi_sum,root_, icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_i2pk_,mpi_sum,root_, icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_i2pk_,mpi_sum,root_, icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -746,20 +1088,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_i2pk_,mpi_i2amx_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_i2pk_,mpi_i2amx_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -813,20 +1165,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& psb_mpi_i2pk_,mpi_i2amx_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_i2amx_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -881,20 +1243,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_i2amx_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_i2amx_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& & psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -950,20 +1322,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_i2pk_,mpi_i2amn_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_i2pk_,mpi_i2amn_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -1017,20 +1399,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_i2amn_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_i2amn_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -1085,20 +1477,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_i2amn_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_i2pk_,mpi_i2amn_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -1319,12 +1721,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_scan(MPI_IN_PLACE,dat,1,& + call mpi_scan(dat_,dat,1,& & psb_mpi_i2pk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iscan(MPI_IN_PLACE,dat,1,& + call mpi_iscan(dat_,dat,1,& & psb_mpi_i2pk_,mpi_sum,icomm,request,minfo) else if (collective_end) then call mpi_wait(request,status,minfo) @@ -1370,12 +1773,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_exscan(MPI_IN_PLACE,dat,1,& + call mpi_exscan(dat_,dat,1,& & psb_mpi_i2pk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iexscan(MPI_IN_PLACE,dat,1,& + call mpi_iexscan(dat_,dat,1,& & psb_mpi_i2pk_,mpi_sum,icomm,request,minfo) else if (collective_end) then call mpi_wait(request,status,minfo) @@ -1398,12 +1802,13 @@ contains integer(psb_i2pk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: mode integer(psb_mpk_), intent(inout), optional :: request + integer(psb_ipk_) :: iam, np, info integer(psb_mpk_) :: minfo integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync - + integer(psb_i2pk_), allocatable :: dat_(:) #if !defined(SERIAL_MPI) call psb_info(ctxt,iam,np) icomm = psb_get_mpi_comm(ctxt) @@ -1421,12 +1826,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_scan(MPI_IN_PLACE,dat,size(dat),& + call mpi_scan(dat_,dat,size(dat),& & psb_mpi_i2pk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iscan(MPI_IN_PLACE,dat,size(dat),& + call mpi_iscan(dat_,dat,size(dat),& & psb_mpi_i2pk_,mpi_sum,icomm,request,info) else if (collective_end) then call mpi_wait(request,status,info) @@ -1447,12 +1853,13 @@ contains integer(psb_i2pk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: mode integer(psb_mpk_), intent(inout), optional :: request - integer(psb_i2pk_), allocatable :: dat_(:) + integer(psb_ipk_) :: iam, np, info integer(psb_mpk_) :: minfo integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + integer(psb_i2pk_), allocatable :: dat_(:) #if !defined(SERIAL_MPI) call psb_info(ctxt,iam,np) @@ -1471,12 +1878,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_exscan(MPI_IN_PLACE,dat,size(dat),& + call mpi_exscan(dat_,dat,size(dat),& & psb_mpi_i2pk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iexscan(MPI_IN_PLACE,dat,size(dat),& + call mpi_iexscan(dat_,dat,size(dat),& & psb_mpi_i2pk_,mpi_sum,icomm,request,info) else if (collective_end) then call mpi_wait(request,status,info) @@ -1689,6 +2097,5 @@ contains Enddo end subroutine psb_i2_e_simple_triad_a2av - end module psi_i2_collective_mod diff --git a/base/modules/penv/psi_m_collective_mod.F90 b/base/modules/penv/psi_m_collective_mod.F90 index 09995175b..8f45d398f 100644 --- a/base/modules/penv/psi_m_collective_mod.F90 +++ b/base/modules/penv/psi_m_collective_mod.F90 @@ -42,6 +42,14 @@ module psi_m_collective_mod end interface psb_min + interface psb_gather + module procedure psb_mgather_s, psb_mgather_v + end interface psb_gather + + interface psb_gatherv + module procedure psb_mgatherv_v + end interface + interface psb_sum module procedure psb_msums, psb_msumv, psb_msumm end interface @@ -107,6 +115,7 @@ contains integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + integer(psb_mpk_) :: dat_ #if !defined(SERIAL_MPI) call psb_info(ctxt,iam,np) @@ -131,20 +140,29 @@ contains collective_start = .false. collective_end = .false. end if - if (collective_sync) then + if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,psb_mpi_mpk_,mpi_max,icomm,info) + call mpi_allreduce(mpi_in_place,dat,1,psb_mpi_mpk_,mpi_max,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,psb_mpi_mpk_,mpi_max,root_,icomm,info) + if (iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,psb_mpi_mpk_,mpi_max,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,psb_mpi_mpk_,mpi_max,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_mpk_,mpi_max,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_mpk_,mpi_max,root_,icomm,request,info) + if (iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_mpk_,mpi_max,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_mpk_,mpi_max,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -171,6 +189,7 @@ contains integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + integer(psb_mpk_) :: dat_(1) ! This is a dummy #if !defined(SERIAL_MPI) @@ -197,21 +216,31 @@ contains collective_end = .false. end if if (collective_sync) then - if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + if (root_ == -1) then + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_max,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_mpk_,mpi_max,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_mpk_,mpi_max,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_mpk_,mpi_max,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_max,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_mpk_,mpi_max,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_mpk_,mpi_max,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_mpk_,mpi_max,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -239,6 +268,7 @@ contains integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + integer(psb_mpk_) :: dat_(1,1) ! this is a dummy #if !defined(SERIAL_MPI) @@ -265,28 +295,37 @@ contains collective_start = .false. collective_end = .false. end if - if (collective_sync) then + if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_max,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_mpk_,mpi_max,root_,icomm,info) - endif + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_mpk_,mpi_max,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_mpk_,mpi_max,root_,icomm,info) + endif + end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_max,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_mpk_,mpi_max,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_mpk_,mpi_max,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_mpk_,mpi_max,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) end if end if - #endif end subroutine psb_mmaxm @@ -337,18 +376,27 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,psb_mpi_mpk_,mpi_min,icomm,info) + call mpi_allreduce(mpi_in_place,dat,1,psb_mpi_mpk_,mpi_min,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,psb_mpi_mpk_,mpi_min,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,psb_mpi_mpk_,mpi_min,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,psb_mpi_mpk_,mpi_min,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_mpk_,mpi_min,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_mpk_,mpi_min,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_mpk_,mpi_min,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_mpk_,mpi_min,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -402,20 +450,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_min,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_mpk_,mpi_min,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_mpk_,mpi_min,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_mpk_,mpi_min,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_min,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_mpk_,mpi_min,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_mpk_,mpi_min,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_mpk_,mpi_min,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -470,20 +528,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_min,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_mpk_,mpi_min,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_mpk_,mpi_min,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_mpk_,mpi_min,root_,icomm,info) + end if end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_min,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_mpk_,mpi_min,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_mpk_,mpi_min,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_mpk_,mpi_min,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -494,6 +562,250 @@ contains + ! + ! gather + ! + subroutine psb_mgather_s(ctxt,dat,resv,root,mode,request) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(inout) :: dat, resv(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_ipk_), intent(in), optional :: mode + integer(psb_mpk_), intent(inout), optional :: request + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: status(mpi_status_size) + logical :: collective_start, collective_end, collective_sync + +#if defined(SERIAL_MPI) + resv(0) = dat +#else + call psb_info(ctxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + icomm = psb_get_mpi_comm(ctxt) + if (present(mode)) then + collective_sync = .false. + collective_start = iand(mode,psb_collective_start_) /= 0 + collective_end = iand(mode,psb_collective_end_) /= 0 + if (.not.present(request)) then + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + else + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + if (collective_sync) then + if (root_ == -1) then + call mpi_allgather(dat,1,psb_mpi_mpk_,& + & resv,1,psb_mpi_mpk_,icomm,info) + else + call mpi_gather(dat,1,psb_mpi_mpk_,& + & resv,1,psb_mpi_mpk_,root_,icomm,info) + endif + else + if (collective_start) then + if (root_ == -1) then + call mpi_iallgather(dat,1,psb_mpi_mpk_,& + & resv,1,psb_mpi_mpk_,icomm,request,info) + else + call mpi_igather(dat,1,psb_mpi_mpk_,& + & resv,1,psb_mpi_mpk_,root_,icomm,request,info) + endif + else if (collective_end) then + call mpi_wait(request,status,info) + end if + end if +#endif + end subroutine psb_mgather_s + + subroutine psb_mgather_v(ctxt,dat,resv,root,mode,request) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(inout) :: dat(:), resv(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_ipk_), intent(in), optional :: mode + integer(psb_mpk_), intent(inout), optional :: request + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: status(mpi_status_size) + logical :: collective_start, collective_end, collective_sync + +#if defined(SERIAL_MPI) + resv(0) = dat +#else + call psb_info(ctxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + icomm = psb_get_mpi_comm(ctxt) + if (present(mode)) then + collective_sync = .false. + collective_start = iand(mode,psb_collective_start_) /= 0 + collective_end = iand(mode,psb_collective_end_) /= 0 + if (.not.present(request)) then + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + else + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + if (collective_sync) then + if (root_ == -1) then + call mpi_allgather(dat,size(dat),psb_mpi_mpk_,& + & resv,size(dat),psb_mpi_mpk_,icomm,info) + else + call mpi_gather(dat,size(dat),psb_mpi_mpk_,& + & resv,size(dat),psb_mpi_mpk_,root_,icomm,info) + endif + else + if (collective_start) then + if (root_ == -1) then + call mpi_iallgather(dat,size(dat),psb_mpi_mpk_,& + & resv,size(dat),psb_mpi_mpk_,icomm,request,info) + else + call mpi_igather(dat,size(dat),psb_mpi_mpk_,& + & resv,size(dat),psb_mpi_mpk_,root_,icomm,request,info) + endif + else if (collective_end) then + call mpi_wait(request,status,info) + end if + end if +#endif + end subroutine psb_mgather_v + + subroutine psb_mgatherv_v(ctxt,dat,resv,szs,root,mode,request) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(inout) :: dat(:), resv(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_), intent(in), optional :: szs(:) + integer(psb_ipk_), intent(in), optional :: mode + integer(psb_mpk_), intent(inout), optional :: request + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info,i + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: status(mpi_status_size) + integer(psb_mpk_), allocatable :: displs(:) + logical :: collective_start, collective_end, collective_sync + +#if defined(SERIAL_MPI) + resv(0) = dat +#else + call psb_info(ctxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + icomm = psb_get_mpi_comm(ctxt) + if (present(mode)) then + collective_sync = .false. + collective_start = iand(mode,psb_collective_start_) /= 0 + collective_end = iand(mode,psb_collective_end_) /= 0 + if (.not.present(request)) then + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + else + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + if (collective_sync) then + if (root_ == -1) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + call mpi_allgatherv(dat,size(dat),psb_mpi_mpk_,& + & resv,szs,displs,psb_mpi_mpk_,icomm,info) + else + if (iam == root_) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + else + allocate(displs(0)) + end if + call mpi_gatherv(dat,size(dat),psb_mpi_mpk_,& + & resv,szs,displs,psb_mpi_mpk_,root_,icomm,info) + endif + else + if (collective_start) then + if (root_ == -1) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + call mpi_iallgatherv(dat,size(dat),psb_mpi_mpk_,& + & resv,szs,displs,psb_mpi_mpk_,icomm,request,info) + else + if (iam == root_) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + else + allocate(displs(0)) + end if + call mpi_igatherv(dat,size(dat),psb_mpi_mpk_,& + & resv,szs,displs,psb_mpi_mpk_,root_,icomm,request,info) + endif + + else if (collective_end) then + call mpi_wait(request,status,info) + end if + end if +#endif + end subroutine psb_mgatherv_v + + + ! ! SUM ! @@ -542,20 +854,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_mpk_,mpi_sum,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_mpk_,mpi_sum,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_mpk_,mpi_sum,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_mpk_,mpi_sum,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_mpk_,mpi_sum,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_mpk_,mpi_sum,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_mpk_,mpi_sum,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_mpk_,mpi_sum,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -608,20 +930,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_sum,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_mpk_,mpi_sum,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_mpk_,mpi_sum,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_mpk_,mpi_sum,root_,icomm,info) + end if end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_sum,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_sum,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_mpk_,mpi_sum,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -676,20 +1008,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_sum,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_mpk_,mpi_sum,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_mpk_,mpi_sum,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_mpk_,mpi_sum,root_,icomm,info) + end if end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_sum,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_mpk_,mpi_sum,root_, icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_mpk_,mpi_sum,root_, icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_mpk_,mpi_sum,root_, icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -746,20 +1088,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_mpk_,mpi_mamx_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_mpk_,mpi_mamx_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_mpk_,mpi_mamx_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_mpk_,mpi_mamx_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_mpk_,mpi_mamx_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_mpk_,mpi_mamx_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_mpk_,mpi_mamx_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_mpk_,mpi_mamx_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -813,20 +1165,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& psb_mpi_mpk_,mpi_mamx_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_mamx_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_mpk_,mpi_mamx_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_mamx_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_mpk_,mpi_mamx_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_mpk_,mpi_mamx_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_mpk_,mpi_mamx_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -881,20 +1243,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_mamx_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_mpk_,mpi_mamx_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_mpk_,mpi_mamx_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_mpk_,mpi_mamx_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_mamx_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_mpk_,mpi_mamx_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& & psb_mpi_mpk_,mpi_mamx_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -950,20 +1322,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_mpk_,mpi_mamn_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_mpk_,mpi_mamn_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_mpk_,mpi_mamn_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_mpk_,mpi_mamn_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_mpk_,mpi_mamn_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_mpk_,mpi_mamn_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_mpk_,mpi_mamn_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_mpk_,mpi_mamn_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -1017,20 +1399,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_mamn_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_mamn_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_mpk_,mpi_mamn_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_mamn_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_mpk_,mpi_mamn_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_mpk_,mpi_mamn_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_mpk_,mpi_mamn_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -1085,20 +1477,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_mamn_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_mpk_,mpi_mamn_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_mpk_,mpi_mamn_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_mpk_,mpi_mamn_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_mpk_,mpi_mamn_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_mpk_,mpi_mamn_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_mpk_,mpi_mamn_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_mpk_,mpi_mamn_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -1319,12 +1721,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_scan(MPI_IN_PLACE,dat,1,& + call mpi_scan(dat_,dat,1,& & psb_mpi_mpk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iscan(MPI_IN_PLACE,dat,1,& + call mpi_iscan(dat_,dat,1,& & psb_mpi_mpk_,mpi_sum,icomm,request,minfo) else if (collective_end) then call mpi_wait(request,status,minfo) @@ -1370,12 +1773,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_exscan(MPI_IN_PLACE,dat,1,& + call mpi_exscan(dat_,dat,1,& & psb_mpi_mpk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iexscan(MPI_IN_PLACE,dat,1,& + call mpi_iexscan(dat_,dat,1,& & psb_mpi_mpk_,mpi_sum,icomm,request,minfo) else if (collective_end) then call mpi_wait(request,status,minfo) @@ -1398,12 +1802,13 @@ contains integer(psb_mpk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: mode integer(psb_mpk_), intent(inout), optional :: request + integer(psb_ipk_) :: iam, np, info integer(psb_mpk_) :: minfo integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync - + integer(psb_mpk_), allocatable :: dat_(:) #if !defined(SERIAL_MPI) call psb_info(ctxt,iam,np) icomm = psb_get_mpi_comm(ctxt) @@ -1421,12 +1826,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_scan(MPI_IN_PLACE,dat,size(dat),& + call mpi_scan(dat_,dat,size(dat),& & psb_mpi_mpk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iscan(MPI_IN_PLACE,dat,size(dat),& + call mpi_iscan(dat_,dat,size(dat),& & psb_mpi_mpk_,mpi_sum,icomm,request,info) else if (collective_end) then call mpi_wait(request,status,info) @@ -1447,12 +1853,13 @@ contains integer(psb_mpk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: mode integer(psb_mpk_), intent(inout), optional :: request - integer(psb_mpk_), allocatable :: dat_(:) + integer(psb_ipk_) :: iam, np, info integer(psb_mpk_) :: minfo integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + integer(psb_mpk_), allocatable :: dat_(:) #if !defined(SERIAL_MPI) call psb_info(ctxt,iam,np) @@ -1471,12 +1878,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_exscan(MPI_IN_PLACE,dat,size(dat),& + call mpi_exscan(dat_,dat,size(dat),& & psb_mpi_mpk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iexscan(MPI_IN_PLACE,dat,size(dat),& + call mpi_iexscan(dat_,dat,size(dat),& & psb_mpi_mpk_,mpi_sum,icomm,request,info) else if (collective_end) then call mpi_wait(request,status,info) @@ -1689,6 +2097,5 @@ contains Enddo end subroutine psb_m_e_simple_triad_a2av - end module psi_m_collective_mod diff --git a/base/modules/penv/psi_s_collective_mod.F90 b/base/modules/penv/psi_s_collective_mod.F90 index d8e6ba82f..6ffaae057 100644 --- a/base/modules/penv/psi_s_collective_mod.F90 +++ b/base/modules/penv/psi_s_collective_mod.F90 @@ -45,6 +45,14 @@ module psi_s_collective_mod module procedure psb_s_nrm2s, psb_s_nrm2v end interface psb_nrm2 + interface psb_gather + module procedure psb_sgather_s, psb_sgather_v + end interface psb_gather + + interface psb_gatherv + module procedure psb_sgatherv_v + end interface + interface psb_sum module procedure psb_ssums, psb_ssumv, psb_ssumm end interface @@ -110,6 +118,7 @@ contains integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + real(psb_spk_) :: dat_ #if !defined(SERIAL_MPI) call psb_info(ctxt,iam,np) @@ -134,20 +143,29 @@ contains collective_start = .false. collective_end = .false. end if - if (collective_sync) then + if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,psb_mpi_r_spk_,mpi_max,icomm,info) + call mpi_allreduce(mpi_in_place,dat,1,psb_mpi_r_spk_,mpi_max,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,psb_mpi_r_spk_,mpi_max,root_,icomm,info) + if (iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,psb_mpi_r_spk_,mpi_max,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,psb_mpi_r_spk_,mpi_max,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_r_spk_,mpi_max,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_r_spk_,mpi_max,root_,icomm,request,info) + if (iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_r_spk_,mpi_max,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_r_spk_,mpi_max,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -174,6 +192,7 @@ contains integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + real(psb_spk_) :: dat_(1) ! This is a dummy #if !defined(SERIAL_MPI) @@ -200,21 +219,31 @@ contains collective_end = .false. end if if (collective_sync) then - if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + if (root_ == -1) then + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_max,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_spk_,mpi_max,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_spk_,mpi_max,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_r_spk_,mpi_max,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_max,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_spk_,mpi_max,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_spk_,mpi_max,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_r_spk_,mpi_max,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -242,6 +271,7 @@ contains integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + real(psb_spk_) :: dat_(1,1) ! this is a dummy #if !defined(SERIAL_MPI) @@ -268,28 +298,37 @@ contains collective_start = .false. collective_end = .false. end if - if (collective_sync) then + if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_max,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_spk_,mpi_max,root_,icomm,info) - endif + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_spk_,mpi_max,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_r_spk_,mpi_max,root_,icomm,info) + endif + end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_max,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_spk_,mpi_max,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_spk_,mpi_max,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_r_spk_,mpi_max,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) end if end if - #endif end subroutine psb_smaxm @@ -340,18 +379,27 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,psb_mpi_r_spk_,mpi_min,icomm,info) + call mpi_allreduce(mpi_in_place,dat,1,psb_mpi_r_spk_,mpi_min,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,psb_mpi_r_spk_,mpi_min,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,psb_mpi_r_spk_,mpi_min,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,psb_mpi_r_spk_,mpi_min,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_r_spk_,mpi_min,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_r_spk_,mpi_min,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_r_spk_,mpi_min,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_r_spk_,mpi_min,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -405,20 +453,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_min,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_spk_,mpi_min,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_spk_,mpi_min,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_r_spk_,mpi_min,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_min,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_spk_,mpi_min,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_spk_,mpi_min,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_r_spk_,mpi_min,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -473,20 +531,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_min,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_spk_,mpi_min,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_spk_,mpi_min,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_r_spk_,mpi_min,root_,icomm,info) + end if end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_min,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_spk_,mpi_min,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_spk_,mpi_min,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_r_spk_,mpi_min,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -545,20 +613,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_r_spk_,mpi_snrm2_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_r_spk_,mpi_snrm2_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_r_spk_,mpi_snrm2_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_r_spk_,mpi_snrm2_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_r_spk_,mpi_snrm2_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_r_spk_,mpi_snrm2_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_r_spk_,mpi_snrm2_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_r_spk_,mpi_snrm2_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -612,20 +690,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_spk_,& + call mpi_allreduce(mpi_in_place,dat,size(dat),psb_mpi_r_spk_,& & mpi_snrm2_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),psb_mpi_r_spk_,& - & mpi_snrm2_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),psb_mpi_r_spk_,& + & mpi_snrm2_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),psb_mpi_r_spk_,& + & mpi_snrm2_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_snrm2_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_spk_,mpi_snrm2_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_spk_,mpi_snrm2_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_r_spk_,mpi_snrm2_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -636,6 +724,250 @@ contains end subroutine psb_s_nrm2v + ! + ! gather + ! + subroutine psb_sgather_s(ctxt,dat,resv,root,mode,request) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + real(psb_spk_), intent(inout) :: dat, resv(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_ipk_), intent(in), optional :: mode + integer(psb_mpk_), intent(inout), optional :: request + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: status(mpi_status_size) + logical :: collective_start, collective_end, collective_sync + +#if defined(SERIAL_MPI) + resv(0) = dat +#else + call psb_info(ctxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + icomm = psb_get_mpi_comm(ctxt) + if (present(mode)) then + collective_sync = .false. + collective_start = iand(mode,psb_collective_start_) /= 0 + collective_end = iand(mode,psb_collective_end_) /= 0 + if (.not.present(request)) then + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + else + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + if (collective_sync) then + if (root_ == -1) then + call mpi_allgather(dat,1,psb_mpi_r_spk_,& + & resv,1,psb_mpi_r_spk_,icomm,info) + else + call mpi_gather(dat,1,psb_mpi_r_spk_,& + & resv,1,psb_mpi_r_spk_,root_,icomm,info) + endif + else + if (collective_start) then + if (root_ == -1) then + call mpi_iallgather(dat,1,psb_mpi_r_spk_,& + & resv,1,psb_mpi_r_spk_,icomm,request,info) + else + call mpi_igather(dat,1,psb_mpi_r_spk_,& + & resv,1,psb_mpi_r_spk_,root_,icomm,request,info) + endif + else if (collective_end) then + call mpi_wait(request,status,info) + end if + end if +#endif + end subroutine psb_sgather_s + + subroutine psb_sgather_v(ctxt,dat,resv,root,mode,request) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + real(psb_spk_), intent(inout) :: dat(:), resv(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_ipk_), intent(in), optional :: mode + integer(psb_mpk_), intent(inout), optional :: request + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: status(mpi_status_size) + logical :: collective_start, collective_end, collective_sync + +#if defined(SERIAL_MPI) + resv(0) = dat +#else + call psb_info(ctxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + icomm = psb_get_mpi_comm(ctxt) + if (present(mode)) then + collective_sync = .false. + collective_start = iand(mode,psb_collective_start_) /= 0 + collective_end = iand(mode,psb_collective_end_) /= 0 + if (.not.present(request)) then + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + else + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + if (collective_sync) then + if (root_ == -1) then + call mpi_allgather(dat,size(dat),psb_mpi_r_spk_,& + & resv,size(dat),psb_mpi_r_spk_,icomm,info) + else + call mpi_gather(dat,size(dat),psb_mpi_r_spk_,& + & resv,size(dat),psb_mpi_r_spk_,root_,icomm,info) + endif + else + if (collective_start) then + if (root_ == -1) then + call mpi_iallgather(dat,size(dat),psb_mpi_r_spk_,& + & resv,size(dat),psb_mpi_r_spk_,icomm,request,info) + else + call mpi_igather(dat,size(dat),psb_mpi_r_spk_,& + & resv,size(dat),psb_mpi_r_spk_,root_,icomm,request,info) + endif + else if (collective_end) then + call mpi_wait(request,status,info) + end if + end if +#endif + end subroutine psb_sgather_v + + subroutine psb_sgatherv_v(ctxt,dat,resv,szs,root,mode,request) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + real(psb_spk_), intent(inout) :: dat(:), resv(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_), intent(in), optional :: szs(:) + integer(psb_ipk_), intent(in), optional :: mode + integer(psb_mpk_), intent(inout), optional :: request + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info,i + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: status(mpi_status_size) + integer(psb_mpk_), allocatable :: displs(:) + logical :: collective_start, collective_end, collective_sync + +#if defined(SERIAL_MPI) + resv(0) = dat +#else + call psb_info(ctxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + icomm = psb_get_mpi_comm(ctxt) + if (present(mode)) then + collective_sync = .false. + collective_start = iand(mode,psb_collective_start_) /= 0 + collective_end = iand(mode,psb_collective_end_) /= 0 + if (.not.present(request)) then + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + else + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + if (collective_sync) then + if (root_ == -1) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + call mpi_allgatherv(dat,size(dat),psb_mpi_r_spk_,& + & resv,szs,displs,psb_mpi_r_spk_,icomm,info) + else + if (iam == root_) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + else + allocate(displs(0)) + end if + call mpi_gatherv(dat,size(dat),psb_mpi_r_spk_,& + & resv,szs,displs,psb_mpi_r_spk_,root_,icomm,info) + endif + else + if (collective_start) then + if (root_ == -1) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + call mpi_iallgatherv(dat,size(dat),psb_mpi_r_spk_,& + & resv,szs,displs,psb_mpi_r_spk_,icomm,request,info) + else + if (iam == root_) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + else + allocate(displs(0)) + end if + call mpi_igatherv(dat,size(dat),psb_mpi_r_spk_,& + & resv,szs,displs,psb_mpi_r_spk_,root_,icomm,request,info) + endif + + else if (collective_end) then + call mpi_wait(request,status,info) + end if + end if +#endif + end subroutine psb_sgatherv_v + + + ! ! SUM ! @@ -684,20 +1016,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_r_spk_,mpi_sum,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_r_spk_,mpi_sum,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_r_spk_,mpi_sum,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_r_spk_,mpi_sum,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_r_spk_,mpi_sum,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_r_spk_,mpi_sum,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_r_spk_,mpi_sum,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_r_spk_,mpi_sum,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -750,20 +1092,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_sum,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_spk_,mpi_sum,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_spk_,mpi_sum,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_r_spk_,mpi_sum,root_,icomm,info) + end if end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_sum,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_sum,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_r_spk_,mpi_sum,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -818,20 +1170,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_sum,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_spk_,mpi_sum,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_spk_,mpi_sum,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_r_spk_,mpi_sum,root_,icomm,info) + end if end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_sum,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_spk_,mpi_sum,root_, icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_spk_,mpi_sum,root_, icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_r_spk_,mpi_sum,root_, icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -888,20 +1250,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_r_spk_,mpi_samx_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_r_spk_,mpi_samx_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_r_spk_,mpi_samx_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_r_spk_,mpi_samx_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_r_spk_,mpi_samx_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_r_spk_,mpi_samx_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_r_spk_,mpi_samx_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_r_spk_,mpi_samx_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -955,20 +1327,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& psb_mpi_r_spk_,mpi_samx_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_samx_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_r_spk_,mpi_samx_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_samx_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_spk_,mpi_samx_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_spk_,mpi_samx_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_r_spk_,mpi_samx_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -1023,20 +1405,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_samx_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_spk_,mpi_samx_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_spk_,mpi_samx_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_r_spk_,mpi_samx_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_samx_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_spk_,mpi_samx_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& & psb_mpi_r_spk_,mpi_samx_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -1092,20 +1484,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_r_spk_,mpi_samn_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_r_spk_,mpi_samn_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_r_spk_,mpi_samn_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_r_spk_,mpi_samn_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_r_spk_,mpi_samn_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_r_spk_,mpi_samn_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_r_spk_,mpi_samn_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_r_spk_,mpi_samn_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -1159,20 +1561,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_samn_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_samn_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_r_spk_,mpi_samn_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_samn_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_spk_,mpi_samn_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_spk_,mpi_samn_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_r_spk_,mpi_samn_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -1227,20 +1639,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_samn_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_spk_,mpi_samn_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_spk_,mpi_samn_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_r_spk_,mpi_samn_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_r_spk_,mpi_samn_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_r_spk_,mpi_samn_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_r_spk_,mpi_samn_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_r_spk_,mpi_samn_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -1461,12 +1883,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_scan(MPI_IN_PLACE,dat,1,& + call mpi_scan(dat_,dat,1,& & psb_mpi_r_spk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iscan(MPI_IN_PLACE,dat,1,& + call mpi_iscan(dat_,dat,1,& & psb_mpi_r_spk_,mpi_sum,icomm,request,minfo) else if (collective_end) then call mpi_wait(request,status,minfo) @@ -1512,12 +1935,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_exscan(MPI_IN_PLACE,dat,1,& + call mpi_exscan(dat_,dat,1,& & psb_mpi_r_spk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iexscan(MPI_IN_PLACE,dat,1,& + call mpi_iexscan(dat_,dat,1,& & psb_mpi_r_spk_,mpi_sum,icomm,request,minfo) else if (collective_end) then call mpi_wait(request,status,minfo) @@ -1540,12 +1964,13 @@ contains real(psb_spk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: mode integer(psb_mpk_), intent(inout), optional :: request + integer(psb_ipk_) :: iam, np, info integer(psb_mpk_) :: minfo integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync - + real(psb_spk_), allocatable :: dat_(:) #if !defined(SERIAL_MPI) call psb_info(ctxt,iam,np) icomm = psb_get_mpi_comm(ctxt) @@ -1563,12 +1988,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_scan(MPI_IN_PLACE,dat,size(dat),& + call mpi_scan(dat_,dat,size(dat),& & psb_mpi_r_spk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iscan(MPI_IN_PLACE,dat,size(dat),& + call mpi_iscan(dat_,dat,size(dat),& & psb_mpi_r_spk_,mpi_sum,icomm,request,info) else if (collective_end) then call mpi_wait(request,status,info) @@ -1589,12 +2015,13 @@ contains real(psb_spk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: mode integer(psb_mpk_), intent(inout), optional :: request - real(psb_spk_), allocatable :: dat_(:) + integer(psb_ipk_) :: iam, np, info integer(psb_mpk_) :: minfo integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + real(psb_spk_), allocatable :: dat_(:) #if !defined(SERIAL_MPI) call psb_info(ctxt,iam,np) @@ -1613,12 +2040,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_exscan(MPI_IN_PLACE,dat,size(dat),& + call mpi_exscan(dat_,dat,size(dat),& & psb_mpi_r_spk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iexscan(MPI_IN_PLACE,dat,size(dat),& + call mpi_iexscan(dat_,dat,size(dat),& & psb_mpi_r_spk_,mpi_sum,icomm,request,info) else if (collective_end) then call mpi_wait(request,status,info) @@ -1831,6 +2259,5 @@ contains Enddo end subroutine psb_s_e_simple_triad_a2av - end module psi_s_collective_mod diff --git a/base/modules/penv/psi_z_collective_mod.F90 b/base/modules/penv/psi_z_collective_mod.F90 index 6f43742fa..8b3ec277f 100644 --- a/base/modules/penv/psi_z_collective_mod.F90 +++ b/base/modules/penv/psi_z_collective_mod.F90 @@ -34,6 +34,14 @@ module psi_z_collective_mod use psb_desc_const_mod + interface psb_gather + module procedure psb_zgather_s, psb_zgather_v + end interface psb_gather + + interface psb_gatherv + module procedure psb_zgatherv_v + end interface + interface psb_sum module procedure psb_zsums, psb_zsumv, psb_zsumm end interface @@ -76,6 +84,250 @@ contains + ! + ! gather + ! + subroutine psb_zgather_s(ctxt,dat,resv,root,mode,request) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + complex(psb_dpk_), intent(inout) :: dat, resv(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_ipk_), intent(in), optional :: mode + integer(psb_mpk_), intent(inout), optional :: request + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: status(mpi_status_size) + logical :: collective_start, collective_end, collective_sync + +#if defined(SERIAL_MPI) + resv(0) = dat +#else + call psb_info(ctxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + icomm = psb_get_mpi_comm(ctxt) + if (present(mode)) then + collective_sync = .false. + collective_start = iand(mode,psb_collective_start_) /= 0 + collective_end = iand(mode,psb_collective_end_) /= 0 + if (.not.present(request)) then + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + else + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + if (collective_sync) then + if (root_ == -1) then + call mpi_allgather(dat,1,psb_mpi_c_dpk_,& + & resv,1,psb_mpi_c_dpk_,icomm,info) + else + call mpi_gather(dat,1,psb_mpi_c_dpk_,& + & resv,1,psb_mpi_c_dpk_,root_,icomm,info) + endif + else + if (collective_start) then + if (root_ == -1) then + call mpi_iallgather(dat,1,psb_mpi_c_dpk_,& + & resv,1,psb_mpi_c_dpk_,icomm,request,info) + else + call mpi_igather(dat,1,psb_mpi_c_dpk_,& + & resv,1,psb_mpi_c_dpk_,root_,icomm,request,info) + endif + else if (collective_end) then + call mpi_wait(request,status,info) + end if + end if +#endif + end subroutine psb_zgather_s + + subroutine psb_zgather_v(ctxt,dat,resv,root,mode,request) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + complex(psb_dpk_), intent(inout) :: dat(:), resv(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_ipk_), intent(in), optional :: mode + integer(psb_mpk_), intent(inout), optional :: request + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: status(mpi_status_size) + logical :: collective_start, collective_end, collective_sync + +#if defined(SERIAL_MPI) + resv(0) = dat +#else + call psb_info(ctxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + icomm = psb_get_mpi_comm(ctxt) + if (present(mode)) then + collective_sync = .false. + collective_start = iand(mode,psb_collective_start_) /= 0 + collective_end = iand(mode,psb_collective_end_) /= 0 + if (.not.present(request)) then + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + else + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + if (collective_sync) then + if (root_ == -1) then + call mpi_allgather(dat,size(dat),psb_mpi_c_dpk_,& + & resv,size(dat),psb_mpi_c_dpk_,icomm,info) + else + call mpi_gather(dat,size(dat),psb_mpi_c_dpk_,& + & resv,size(dat),psb_mpi_c_dpk_,root_,icomm,info) + endif + else + if (collective_start) then + if (root_ == -1) then + call mpi_iallgather(dat,size(dat),psb_mpi_c_dpk_,& + & resv,size(dat),psb_mpi_c_dpk_,icomm,request,info) + else + call mpi_igather(dat,size(dat),psb_mpi_c_dpk_,& + & resv,size(dat),psb_mpi_c_dpk_,root_,icomm,request,info) + endif + else if (collective_end) then + call mpi_wait(request,status,info) + end if + end if +#endif + end subroutine psb_zgather_v + + subroutine psb_zgatherv_v(ctxt,dat,resv,szs,root,mode,request) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + complex(psb_dpk_), intent(inout) :: dat(:), resv(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_), intent(in), optional :: szs(:) + integer(psb_ipk_), intent(in), optional :: mode + integer(psb_mpk_), intent(inout), optional :: request + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info,i + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: status(mpi_status_size) + integer(psb_mpk_), allocatable :: displs(:) + logical :: collective_start, collective_end, collective_sync + +#if defined(SERIAL_MPI) + resv(0) = dat +#else + call psb_info(ctxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + icomm = psb_get_mpi_comm(ctxt) + if (present(mode)) then + collective_sync = .false. + collective_start = iand(mode,psb_collective_start_) /= 0 + collective_end = iand(mode,psb_collective_end_) /= 0 + if (.not.present(request)) then + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + else + collective_sync = .true. + collective_start = .false. + collective_end = .false. + end if + if (collective_sync) then + if (root_ == -1) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + call mpi_allgatherv(dat,size(dat),psb_mpi_c_dpk_,& + & resv,szs,displs,psb_mpi_c_dpk_,icomm,info) + else + if (iam == root_) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + else + allocate(displs(0)) + end if + call mpi_gatherv(dat,size(dat),psb_mpi_c_dpk_,& + & resv,szs,displs,psb_mpi_c_dpk_,root_,icomm,info) + endif + else + if (collective_start) then + if (root_ == -1) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + call mpi_iallgatherv(dat,size(dat),psb_mpi_c_dpk_,& + & resv,szs,displs,psb_mpi_c_dpk_,icomm,request,info) + else + if (iam == root_) then + if (size(szs) < np) write(0,*) 'Error: bad input sizes' + allocate(displs(np)) + displs(1) = 0 + do i=2, np + displs(i) = displs(i-1) + szs(i-1) + end do + else + allocate(displs(0)) + end if + call mpi_igatherv(dat,size(dat),psb_mpi_c_dpk_,& + & resv,szs,displs,psb_mpi_c_dpk_,root_,icomm,request,info) + endif + + else if (collective_end) then + call mpi_wait(request,status,info) + end if + end if +#endif + end subroutine psb_zgatherv_v + + + ! ! SUM ! @@ -124,20 +376,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_c_dpk_,mpi_sum,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_c_dpk_,mpi_sum,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_c_dpk_,mpi_sum,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_c_dpk_,mpi_sum,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_c_dpk_,mpi_sum,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_c_dpk_,mpi_sum,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_c_dpk_,mpi_sum,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_c_dpk_,mpi_sum,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -190,20 +452,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_dpk_,mpi_sum,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_c_dpk_,mpi_sum,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_c_dpk_,mpi_sum,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_c_dpk_,mpi_sum,root_,icomm,info) + end if end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_dpk_,mpi_sum,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_dpk_,mpi_sum,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_c_dpk_,mpi_sum,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -258,20 +530,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_dpk_,mpi_sum,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_c_dpk_,mpi_sum,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_c_dpk_,mpi_sum,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_c_dpk_,mpi_sum,root_,icomm,info) + end if end if else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_dpk_,mpi_sum,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_c_dpk_,mpi_sum,root_, icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_c_dpk_,mpi_sum,root_, icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_c_dpk_,mpi_sum,root_, icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -328,20 +610,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_c_dpk_,mpi_zamx_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_c_dpk_,mpi_zamx_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -395,20 +687,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& psb_mpi_c_dpk_,mpi_zamx_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_dpk_,mpi_zamx_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -463,20 +765,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_dpk_,mpi_zamx_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_dpk_,mpi_zamx_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& & psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -532,20 +844,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,1,& + call mpi_allreduce(mpi_in_place,dat,1,& & psb_mpi_c_dpk_,mpi_zamn_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,1,& + & psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,1,& + & psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,1,& + call mpi_iallreduce(mpi_in_place,dat,1,& & psb_mpi_c_dpk_,mpi_zamn_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,1,& - & psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,1,& + & psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,1,& + & psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -599,20 +921,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_dpk_,mpi_zamn_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_dpk_,mpi_zamn_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -667,20 +999,30 @@ contains end if if (collective_sync) then if (root_ == -1) then - call mpi_allreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_allreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_dpk_,mpi_zamn_op,icomm,info) else - call mpi_reduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,info) + if(iam==root_) then + call mpi_reduce(mpi_in_place,dat,size(dat),& + & psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,info) + else + call mpi_reduce(dat,dat,size(dat),& + & psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,info) + end if endif else if (collective_start) then if (root_ == -1) then - call mpi_iallreduce(MPI_IN_PLACE,dat,size(dat),& + call mpi_iallreduce(mpi_in_place,dat,size(dat),& & psb_mpi_c_dpk_,mpi_zamn_op,icomm,request,info) else - call mpi_ireduce(MPI_IN_PLACE,dat,size(dat),& - & psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,request,info) + if(iam==root_) then + call mpi_ireduce(mpi_in_place,dat,size(dat),& + & psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,request,info) + else + call mpi_ireduce(dat,dat,size(dat),& + & psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,request,info) + end if end if else if (collective_end) then call mpi_wait(request,status,info) @@ -901,12 +1243,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_scan(MPI_IN_PLACE,dat,1,& + call mpi_scan(dat_,dat,1,& & psb_mpi_c_dpk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iscan(MPI_IN_PLACE,dat,1,& + call mpi_iscan(dat_,dat,1,& & psb_mpi_c_dpk_,mpi_sum,icomm,request,minfo) else if (collective_end) then call mpi_wait(request,status,minfo) @@ -952,12 +1295,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_exscan(MPI_IN_PLACE,dat,1,& + call mpi_exscan(dat_,dat,1,& & psb_mpi_c_dpk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iexscan(MPI_IN_PLACE,dat,1,& + call mpi_iexscan(dat_,dat,1,& & psb_mpi_c_dpk_,mpi_sum,icomm,request,minfo) else if (collective_end) then call mpi_wait(request,status,minfo) @@ -980,12 +1324,13 @@ contains complex(psb_dpk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: mode integer(psb_mpk_), intent(inout), optional :: request + integer(psb_ipk_) :: iam, np, info integer(psb_mpk_) :: minfo integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync - + complex(psb_dpk_), allocatable :: dat_(:) #if !defined(SERIAL_MPI) call psb_info(ctxt,iam,np) icomm = psb_get_mpi_comm(ctxt) @@ -1003,12 +1348,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_scan(MPI_IN_PLACE,dat,size(dat),& + call mpi_scan(dat_,dat,size(dat),& & psb_mpi_c_dpk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iscan(MPI_IN_PLACE,dat,size(dat),& + call mpi_iscan(dat_,dat,size(dat),& & psb_mpi_c_dpk_,mpi_sum,icomm,request,info) else if (collective_end) then call mpi_wait(request,status,info) @@ -1029,12 +1375,13 @@ contains complex(psb_dpk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: mode integer(psb_mpk_), intent(inout), optional :: request - complex(psb_dpk_), allocatable :: dat_(:) + integer(psb_ipk_) :: iam, np, info integer(psb_mpk_) :: minfo integer(psb_mpk_) :: icomm integer(psb_mpk_) :: status(mpi_status_size) logical :: collective_start, collective_end, collective_sync + complex(psb_dpk_), allocatable :: dat_(:) #if !defined(SERIAL_MPI) call psb_info(ctxt,iam,np) @@ -1053,12 +1400,13 @@ contains collective_start = .false. collective_end = .false. end if + dat_ = dat if (collective_sync) then - call mpi_exscan(MPI_IN_PLACE,dat,size(dat),& + call mpi_exscan(dat_,dat,size(dat),& & psb_mpi_c_dpk_,mpi_sum,icomm,minfo) else if (collective_start) then - call mpi_iexscan(MPI_IN_PLACE,dat,size(dat),& + call mpi_iexscan(dat_,dat,size(dat),& & psb_mpi_c_dpk_,mpi_sum,icomm,request,info) else if (collective_end) then call mpi_wait(request,status,info) @@ -1271,6 +1619,5 @@ contains Enddo end subroutine psb_z_e_simple_triad_a2av - end module psi_z_collective_mod diff --git a/base/modules/psb_const_mod.F90 b/base/modules/psb_const_mod.F90 index cc29f0499..561344741 100644 --- a/base/modules/psb_const_mod.F90 +++ b/base/modules/psb_const_mod.F90 @@ -185,13 +185,17 @@ module psb_const_mod ! The up/down constant are defined in pairs having ! opposite values. We make use of this fact in the heapsort routine. ! - integer(psb_ipk_), parameter :: psb_sort_up_ = 1, psb_sort_down_ = -1 - integer(psb_ipk_), parameter :: psb_lsort_up_ = 2, psb_lsort_down_ = -2 - integer(psb_ipk_), parameter :: psb_asort_up_ = 3, psb_asort_down_ = -3 - integer(psb_ipk_), parameter :: psb_alsort_up_ = 4, psb_alsort_down_ = -4 - integer(psb_ipk_), parameter :: psb_sort_ovw_idx_ = 0, psb_sort_keep_idx_ = 1 - integer(psb_ipk_), parameter :: psb_heap_resize = 200 + integer(psb_ipk_), parameter :: psb_sort_up_ = 1, psb_sort_down_ = -1 + integer(psb_ipk_), parameter :: psb_lsort_up_ = 2, psb_lsort_down_ = -2 + integer(psb_ipk_), parameter :: psb_asort_up_ = 3, psb_asort_down_ = -3 + integer(psb_ipk_), parameter :: psb_alsort_up_ = 4, psb_alsort_down_ = -4 + integer(psb_ipk_), parameter :: psb_sort_ovw_idx_ = 0, psb_sort_keep_idx_ = 1 + integer(psb_ipk_), parameter :: psb_heap_resize = 200 + integer(psb_ipk_), parameter :: psb_find_any_ = 0 + integer(psb_ipk_), parameter :: psb_find_first_ge_ = 1 + integer(psb_ipk_), parameter :: psb_find_last_le_ = 2 + ! ! Sparse matrix constants diff --git a/base/modules/serial/psb_base_mat_mod.F90 b/base/modules/serial/psb_base_mat_mod.F90 index af4e4c6f1..2380fcb26 100644 --- a/base/modules/serial/psb_base_mat_mod.F90 +++ b/base/modules/serial/psb_base_mat_mod.F90 @@ -73,6 +73,19 @@ module psb_base_mat_mod use psb_const_mod use psi_serial_mod + ! Algs for SPSPMM + integer(psb_ipk_), parameter :: spspmm_serial = 0 + integer(psb_ipk_), parameter :: spspmm_omp_gustavson = 1 + integer(psb_ipk_), parameter :: spspmm_omp_gustavson_1d = 2 + integer(psb_ipk_), parameter :: spspmm_serial_rb_tree = 3 + integer(psb_ipk_), parameter :: spspmm_omp_rb_tree = 4 + integer(psb_ipk_), parameter :: spspmm_omp_two_pass = 5 +#if defined(OPENMP) + integer(psb_ipk_), save :: spspmm_impl = spspmm_omp_gustavson +#else + integer(psb_ipk_), save :: spspmm_impl = spspmm_serial +#endif + ! !> \namespace psb_base_mod \class psb_base_sparse_mat !! The basic data about your matrix. @@ -1904,4 +1917,22 @@ contains end subroutine psb_base_from_lbase + function psb_get_spspmm_impl() result(impl_id) + integer(psb_ipk_) :: impl_id + impl_id = spspmm_impl + end function psb_get_spspmm_impl + + subroutine psb_set_spspmm_impl(impl_id) + integer(psb_ipk_), intent(in) :: impl_id + + select case(impl_id) + case (spspmm_serial,spspmm_omp_gustavson,spspmm_omp_gustavson_1d,& + & spspmm_serial_rb_tree,spspmm_omp_rb_tree, spspmm_omp_two_pass) + spspmm_impl = impl_id + case default + + write (*,*) "Invalid implementation id",impl_id + end select + end subroutine psb_set_spspmm_impl + end module psb_base_mat_mod diff --git a/base/modules/serial/psb_c_base_mat_mod.F90 b/base/modules/serial/psb_c_base_mat_mod.F90 index 7a7bbb1f5..33982e3a1 100644 --- a/base/modules/serial/psb_c_base_mat_mod.F90 +++ b/base/modules/serial/psb_c_base_mat_mod.F90 @@ -168,6 +168,8 @@ module psb_c_base_mat_mod procedure, pass(a) :: reallocate_nz => psb_c_coo_reallocate_nz procedure, pass(a) :: allocate_mnnz => psb_c_coo_allocate_mnnz procedure, pass(a) :: ensure_size => psb_c_coo_ensure_size + procedure, pass(a) :: tril => psb_c_coo_tril + procedure, pass(a) :: triu => psb_c_coo_triu procedure, pass(a) :: cp_to_coo => psb_c_cp_coo_to_coo procedure, pass(a) :: cp_from_coo => psb_c_cp_coo_from_coo procedure, pass(a) :: cp_to_fmt => psb_c_cp_coo_to_fmt @@ -1866,18 +1868,6 @@ module psb_c_base_mat_mod end subroutine psb_c_fix_coo_inner end interface - interface - subroutine psb_c_fix_coo_inner_colmajor(nr,nc,nzin,dupl,& - & ia,ja,val,iaux,nzout,info) - import - integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl - integer(psb_ipk_), intent(inout) :: ia(:), ja(:), iaux(:) - complex(psb_spk_), intent(inout) :: val(:) - integer(psb_ipk_), intent(out) :: nzout - integer(psb_ipk_), intent(out) :: info - end subroutine psb_c_fix_coo_inner_colmajor - end interface - interface subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,& & ia,ja,val,iaux,nzout,info) @@ -1906,6 +1896,93 @@ module psb_c_base_mat_mod integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_c_fix_coo end interface + ! + !> Function tril: + !! \memberof psb_c_coo_sparse_mat + !! \brief Copy the lower triangle, i.e. all entries + !! A(I,J) such that J-I <= DIAG + !! default value is DIAG=0, i.e. lower triangle up to + !! the main diagonal. + !! DIAG=-1 means copy the strictly lower triangle + !! DIAG= 1 means copy the lower triangle plus the first diagonal + !! of the upper triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! + !! \param l the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param u [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_c_coo_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_c_coo_sparse_mat), optional, intent(out) :: u + end subroutine psb_c_coo_tril + end interface + + ! + !> Function triu: + !! \memberof psb_c_coo_sparse_mat + !! \brief Copy the upper triangle, i.e. all entries + !! A(I,J) such that DIAG <= J-I + !! default value is DIAG=0, i.e. upper triangle from + !! the main diagonal up. + !! DIAG= 1 means copy the strictly upper triangle + !! DIAG=-1 means copy the upper triangle plus the first diagonal + !! of the lower triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! Optionally copies the lower triangle at the same time + !! + !! \param u the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param l [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_c_coo_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_c_coo_sparse_mat), optional, intent(out) :: l + end subroutine psb_c_coo_triu + end interface + !> !! \memberof psb_c_coo_sparse_mat diff --git a/base/modules/serial/psb_c_base_vect_mod.F90 b/base/modules/serial/psb_c_base_vect_mod.F90 index 44044771f..df15e0c9c 100644 --- a/base/modules/serial/psb_c_base_vect_mod.F90 +++ b/base/modules/serial/psb_c_base_vect_mod.F90 @@ -481,7 +481,11 @@ contains implicit none class(psb_c_base_vect_type), intent(inout) :: x - if (allocated(x%v)) x%v=czero + if (allocated(x%v)) then + !$omp workshare + x%v(:)=czero + !$omp end workshare + end if call x%set_host() end subroutine c_base_zero diff --git a/base/modules/serial/psb_d_base_mat_mod.F90 b/base/modules/serial/psb_d_base_mat_mod.F90 index eb49905d7..5f4c76df4 100644 --- a/base/modules/serial/psb_d_base_mat_mod.F90 +++ b/base/modules/serial/psb_d_base_mat_mod.F90 @@ -168,6 +168,8 @@ module psb_d_base_mat_mod procedure, pass(a) :: reallocate_nz => psb_d_coo_reallocate_nz procedure, pass(a) :: allocate_mnnz => psb_d_coo_allocate_mnnz procedure, pass(a) :: ensure_size => psb_d_coo_ensure_size + procedure, pass(a) :: tril => psb_d_coo_tril + procedure, pass(a) :: triu => psb_d_coo_triu procedure, pass(a) :: cp_to_coo => psb_d_cp_coo_to_coo procedure, pass(a) :: cp_from_coo => psb_d_cp_coo_from_coo procedure, pass(a) :: cp_to_fmt => psb_d_cp_coo_to_fmt @@ -1866,18 +1868,6 @@ module psb_d_base_mat_mod end subroutine psb_d_fix_coo_inner end interface - interface - subroutine psb_d_fix_coo_inner_colmajor(nr,nc,nzin,dupl,& - & ia,ja,val,iaux,nzout,info) - import - integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl - integer(psb_ipk_), intent(inout) :: ia(:), ja(:), iaux(:) - real(psb_dpk_), intent(inout) :: val(:) - integer(psb_ipk_), intent(out) :: nzout - integer(psb_ipk_), intent(out) :: info - end subroutine psb_d_fix_coo_inner_colmajor - end interface - interface subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,& & ia,ja,val,iaux,nzout,info) @@ -1906,6 +1896,93 @@ module psb_d_base_mat_mod integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_d_fix_coo end interface + ! + !> Function tril: + !! \memberof psb_d_coo_sparse_mat + !! \brief Copy the lower triangle, i.e. all entries + !! A(I,J) such that J-I <= DIAG + !! default value is DIAG=0, i.e. lower triangle up to + !! the main diagonal. + !! DIAG=-1 means copy the strictly lower triangle + !! DIAG= 1 means copy the lower triangle plus the first diagonal + !! of the upper triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! + !! \param l the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param u [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_d_coo_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import + class(psb_d_coo_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_d_coo_sparse_mat), optional, intent(out) :: u + end subroutine psb_d_coo_tril + end interface + + ! + !> Function triu: + !! \memberof psb_d_coo_sparse_mat + !! \brief Copy the upper triangle, i.e. all entries + !! A(I,J) such that DIAG <= J-I + !! default value is DIAG=0, i.e. upper triangle from + !! the main diagonal up. + !! DIAG= 1 means copy the strictly upper triangle + !! DIAG=-1 means copy the upper triangle plus the first diagonal + !! of the lower triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! Optionally copies the lower triangle at the same time + !! + !! \param u the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param l [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_d_coo_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import + class(psb_d_coo_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_d_coo_sparse_mat), optional, intent(out) :: l + end subroutine psb_d_coo_triu + end interface + !> !! \memberof psb_d_coo_sparse_mat diff --git a/base/modules/serial/psb_d_base_vect_mod.F90 b/base/modules/serial/psb_d_base_vect_mod.F90 index a28d12f69..87f5b0e46 100644 --- a/base/modules/serial/psb_d_base_vect_mod.F90 +++ b/base/modules/serial/psb_d_base_vect_mod.F90 @@ -488,7 +488,11 @@ contains implicit none class(psb_d_base_vect_type), intent(inout) :: x - if (allocated(x%v)) x%v=dzero + if (allocated(x%v)) then + !$omp workshare + x%v(:)=dzero + !$omp end workshare + end if call x%set_host() end subroutine d_base_zero diff --git a/base/modules/serial/psb_i_base_vect_mod.F90 b/base/modules/serial/psb_i_base_vect_mod.F90 index 0289ecd08..a5cddeb56 100644 --- a/base/modules/serial/psb_i_base_vect_mod.F90 +++ b/base/modules/serial/psb_i_base_vect_mod.F90 @@ -417,7 +417,11 @@ contains implicit none class(psb_i_base_vect_type), intent(inout) :: x - if (allocated(x%v)) x%v=izero + if (allocated(x%v)) then + !$omp workshare + x%v(:)=izero + !$omp end workshare + end if call x%set_host() end subroutine i_base_zero diff --git a/base/modules/serial/psb_l_base_vect_mod.F90 b/base/modules/serial/psb_l_base_vect_mod.F90 index d8654f63b..93b29e17e 100644 --- a/base/modules/serial/psb_l_base_vect_mod.F90 +++ b/base/modules/serial/psb_l_base_vect_mod.F90 @@ -418,7 +418,11 @@ contains implicit none class(psb_l_base_vect_type), intent(inout) :: x - if (allocated(x%v)) x%v=lzero + if (allocated(x%v)) then + !$omp workshare + x%v(:)=lzero + !$omp end workshare + end if call x%set_host() end subroutine l_base_zero diff --git a/base/modules/serial/psb_s_base_mat_mod.F90 b/base/modules/serial/psb_s_base_mat_mod.F90 index 79c8222b8..92bda7d8e 100644 --- a/base/modules/serial/psb_s_base_mat_mod.F90 +++ b/base/modules/serial/psb_s_base_mat_mod.F90 @@ -168,6 +168,8 @@ module psb_s_base_mat_mod procedure, pass(a) :: reallocate_nz => psb_s_coo_reallocate_nz procedure, pass(a) :: allocate_mnnz => psb_s_coo_allocate_mnnz procedure, pass(a) :: ensure_size => psb_s_coo_ensure_size + procedure, pass(a) :: tril => psb_s_coo_tril + procedure, pass(a) :: triu => psb_s_coo_triu procedure, pass(a) :: cp_to_coo => psb_s_cp_coo_to_coo procedure, pass(a) :: cp_from_coo => psb_s_cp_coo_from_coo procedure, pass(a) :: cp_to_fmt => psb_s_cp_coo_to_fmt @@ -1866,18 +1868,6 @@ module psb_s_base_mat_mod end subroutine psb_s_fix_coo_inner end interface - interface - subroutine psb_s_fix_coo_inner_colmajor(nr,nc,nzin,dupl,& - & ia,ja,val,iaux,nzout,info) - import - integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl - integer(psb_ipk_), intent(inout) :: ia(:), ja(:), iaux(:) - real(psb_spk_), intent(inout) :: val(:) - integer(psb_ipk_), intent(out) :: nzout - integer(psb_ipk_), intent(out) :: info - end subroutine psb_s_fix_coo_inner_colmajor - end interface - interface subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,& & ia,ja,val,iaux,nzout,info) @@ -1906,6 +1896,93 @@ module psb_s_base_mat_mod integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_s_fix_coo end interface + ! + !> Function tril: + !! \memberof psb_s_coo_sparse_mat + !! \brief Copy the lower triangle, i.e. all entries + !! A(I,J) such that J-I <= DIAG + !! default value is DIAG=0, i.e. lower triangle up to + !! the main diagonal. + !! DIAG=-1 means copy the strictly lower triangle + !! DIAG= 1 means copy the lower triangle plus the first diagonal + !! of the upper triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! + !! \param l the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param u [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_s_coo_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import + class(psb_s_coo_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_s_coo_sparse_mat), optional, intent(out) :: u + end subroutine psb_s_coo_tril + end interface + + ! + !> Function triu: + !! \memberof psb_s_coo_sparse_mat + !! \brief Copy the upper triangle, i.e. all entries + !! A(I,J) such that DIAG <= J-I + !! default value is DIAG=0, i.e. upper triangle from + !! the main diagonal up. + !! DIAG= 1 means copy the strictly upper triangle + !! DIAG=-1 means copy the upper triangle plus the first diagonal + !! of the lower triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! Optionally copies the lower triangle at the same time + !! + !! \param u the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param l [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_s_coo_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import + class(psb_s_coo_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_s_coo_sparse_mat), optional, intent(out) :: l + end subroutine psb_s_coo_triu + end interface + !> !! \memberof psb_s_coo_sparse_mat diff --git a/base/modules/serial/psb_s_base_vect_mod.F90 b/base/modules/serial/psb_s_base_vect_mod.F90 index 4bd6bbfbb..fccd846bd 100644 --- a/base/modules/serial/psb_s_base_vect_mod.F90 +++ b/base/modules/serial/psb_s_base_vect_mod.F90 @@ -488,7 +488,11 @@ contains implicit none class(psb_s_base_vect_type), intent(inout) :: x - if (allocated(x%v)) x%v=szero + if (allocated(x%v)) then + !$omp workshare + x%v(:)=szero + !$omp end workshare + end if call x%set_host() end subroutine s_base_zero diff --git a/base/modules/serial/psb_z_base_mat_mod.F90 b/base/modules/serial/psb_z_base_mat_mod.F90 index 5b6ca07b7..3e8196f48 100644 --- a/base/modules/serial/psb_z_base_mat_mod.F90 +++ b/base/modules/serial/psb_z_base_mat_mod.F90 @@ -168,6 +168,8 @@ module psb_z_base_mat_mod procedure, pass(a) :: reallocate_nz => psb_z_coo_reallocate_nz procedure, pass(a) :: allocate_mnnz => psb_z_coo_allocate_mnnz procedure, pass(a) :: ensure_size => psb_z_coo_ensure_size + procedure, pass(a) :: tril => psb_z_coo_tril + procedure, pass(a) :: triu => psb_z_coo_triu procedure, pass(a) :: cp_to_coo => psb_z_cp_coo_to_coo procedure, pass(a) :: cp_from_coo => psb_z_cp_coo_from_coo procedure, pass(a) :: cp_to_fmt => psb_z_cp_coo_to_fmt @@ -1866,18 +1868,6 @@ module psb_z_base_mat_mod end subroutine psb_z_fix_coo_inner end interface - interface - subroutine psb_z_fix_coo_inner_colmajor(nr,nc,nzin,dupl,& - & ia,ja,val,iaux,nzout,info) - import - integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl - integer(psb_ipk_), intent(inout) :: ia(:), ja(:), iaux(:) - complex(psb_dpk_), intent(inout) :: val(:) - integer(psb_ipk_), intent(out) :: nzout - integer(psb_ipk_), intent(out) :: info - end subroutine psb_z_fix_coo_inner_colmajor - end interface - interface subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,& & ia,ja,val,iaux,nzout,info) @@ -1906,6 +1896,93 @@ module psb_z_base_mat_mod integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_z_fix_coo end interface + ! + !> Function tril: + !! \memberof psb_z_coo_sparse_mat + !! \brief Copy the lower triangle, i.e. all entries + !! A(I,J) such that J-I <= DIAG + !! default value is DIAG=0, i.e. lower triangle up to + !! the main diagonal. + !! DIAG=-1 means copy the strictly lower triangle + !! DIAG= 1 means copy the lower triangle plus the first diagonal + !! of the upper triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! + !! \param l the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param u [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_z_coo_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_z_coo_sparse_mat), optional, intent(out) :: u + end subroutine psb_z_coo_tril + end interface + + ! + !> Function triu: + !! \memberof psb_z_coo_sparse_mat + !! \brief Copy the upper triangle, i.e. all entries + !! A(I,J) such that DIAG <= J-I + !! default value is DIAG=0, i.e. upper triangle from + !! the main diagonal up. + !! DIAG= 1 means copy the strictly upper triangle + !! DIAG=-1 means copy the upper triangle plus the first diagonal + !! of the lower triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! Optionally copies the lower triangle at the same time + !! + !! \param u the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param l [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_z_coo_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_z_coo_sparse_mat), optional, intent(out) :: l + end subroutine psb_z_coo_triu + end interface + !> !! \memberof psb_z_coo_sparse_mat diff --git a/base/modules/serial/psb_z_base_vect_mod.F90 b/base/modules/serial/psb_z_base_vect_mod.F90 index c52dcd59c..2a14de21f 100644 --- a/base/modules/serial/psb_z_base_vect_mod.F90 +++ b/base/modules/serial/psb_z_base_vect_mod.F90 @@ -481,7 +481,11 @@ contains implicit none class(psb_z_base_vect_type), intent(inout) :: x - if (allocated(x%v)) x%v=zzero + if (allocated(x%v)) then + !$omp workshare + x%v(:)=zzero + !$omp end workshare + end if call x%set_host() end subroutine z_base_zero diff --git a/base/psblas/psb_cnrm2.f90 b/base/psblas/psb_cnrm2.f90 index 027750374..0de8ed162 100644 --- a/base/psblas/psb_cnrm2.f90 +++ b/base/psblas/psb_cnrm2.f90 @@ -356,7 +356,7 @@ function psb_cnrm2_vect(x, desc_a, info,global) result(res) idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = dble(ndm-1)/dble(ndm) - res = res - sqrt(cone - dd*(abs(x%v%v(idx))/res)**2) + res = res * sqrt(sone - dd*(abs(x%v%v(idx))/res)**2) end do end if else @@ -465,7 +465,7 @@ function psb_cnrm2_weight_vect(x,w, desc_a, info,global,aux) result(res) idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = dble(ndm-1)/dble(ndm) - res = res - sqrt(cone - dd*(abs(x%v%v(idx))/res)**2) + res = res * sqrt(sone - dd*(abs(x%v%v(idx))/res)**2) end do end if else @@ -577,7 +577,7 @@ function psb_cnrm2_weightmask_vect(x,w,idv, desc_a, info,global, aux) result(re idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = dble(ndm-1)/dble(ndm) - res = res - sqrt(cone - dd*(abs(x%v%v(idx))/res)**2) + res = res * sqrt(sone - dd*(abs(x%v%v(idx))/res)**2) end do end if else diff --git a/base/psblas/psb_dnrm2.f90 b/base/psblas/psb_dnrm2.f90 index 6985bcb42..7ebe94391 100644 --- a/base/psblas/psb_dnrm2.f90 +++ b/base/psblas/psb_dnrm2.f90 @@ -356,7 +356,7 @@ function psb_dnrm2_vect(x, desc_a, info,global) result(res) idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = dble(ndm-1)/dble(ndm) - res = res - sqrt(done - dd*(abs(x%v%v(idx))/res)**2) + res = res * sqrt(done - dd*(abs(x%v%v(idx))/res)**2) end do end if else @@ -465,7 +465,7 @@ function psb_dnrm2_weight_vect(x,w, desc_a, info,global,aux) result(res) idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = dble(ndm-1)/dble(ndm) - res = res - sqrt(done - dd*(abs(x%v%v(idx))/res)**2) + res = res * sqrt(done - dd*(abs(x%v%v(idx))/res)**2) end do end if else @@ -577,7 +577,7 @@ function psb_dnrm2_weightmask_vect(x,w,idv, desc_a, info,global, aux) result(re idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = dble(ndm-1)/dble(ndm) - res = res - sqrt(done - dd*(abs(x%v%v(idx))/res)**2) + res = res * sqrt(done - dd*(abs(x%v%v(idx))/res)**2) end do end if else diff --git a/base/psblas/psb_snrm2.f90 b/base/psblas/psb_snrm2.f90 index d3cdaae2f..bb9b3effb 100644 --- a/base/psblas/psb_snrm2.f90 +++ b/base/psblas/psb_snrm2.f90 @@ -356,7 +356,7 @@ function psb_snrm2_vect(x, desc_a, info,global) result(res) idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = dble(ndm-1)/dble(ndm) - res = res - sqrt(sone - dd*(abs(x%v%v(idx))/res)**2) + res = res * sqrt(sone - dd*(abs(x%v%v(idx))/res)**2) end do end if else @@ -465,7 +465,7 @@ function psb_snrm2_weight_vect(x,w, desc_a, info,global,aux) result(res) idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = dble(ndm-1)/dble(ndm) - res = res - sqrt(sone - dd*(abs(x%v%v(idx))/res)**2) + res = res * sqrt(sone - dd*(abs(x%v%v(idx))/res)**2) end do end if else @@ -577,7 +577,7 @@ function psb_snrm2_weightmask_vect(x,w,idv, desc_a, info,global, aux) result(re idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = dble(ndm-1)/dble(ndm) - res = res - sqrt(sone - dd*(abs(x%v%v(idx))/res)**2) + res = res * sqrt(sone - dd*(abs(x%v%v(idx))/res)**2) end do end if else diff --git a/base/psblas/psb_znrm2.f90 b/base/psblas/psb_znrm2.f90 index afb54aec2..5612a01db 100644 --- a/base/psblas/psb_znrm2.f90 +++ b/base/psblas/psb_znrm2.f90 @@ -356,7 +356,7 @@ function psb_znrm2_vect(x, desc_a, info,global) result(res) idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = dble(ndm-1)/dble(ndm) - res = res - sqrt(zone - dd*(abs(x%v%v(idx))/res)**2) + res = res * sqrt(done - dd*(abs(x%v%v(idx))/res)**2) end do end if else @@ -465,7 +465,7 @@ function psb_znrm2_weight_vect(x,w, desc_a, info,global,aux) result(res) idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = dble(ndm-1)/dble(ndm) - res = res - sqrt(zone - dd*(abs(x%v%v(idx))/res)**2) + res = res * sqrt(done - dd*(abs(x%v%v(idx))/res)**2) end do end if else @@ -577,7 +577,7 @@ function psb_znrm2_weightmask_vect(x,w,idv, desc_a, info,global, aux) result(re idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = dble(ndm-1)/dble(ndm) - res = res - sqrt(zone - dd*(abs(x%v%v(idx))/res)**2) + res = res * sqrt(done - dd*(abs(x%v%v(idx))/res)**2) end do end if else diff --git a/base/serial/impl/Makefile b/base/serial/impl/Makefile index 000887418..37f400f05 100644 --- a/base/serial/impl/Makefile +++ b/base/serial/impl/Makefile @@ -7,16 +7,20 @@ BOBJS=psb_base_mat_impl.o \ psb_s_base_mat_impl.o psb_d_base_mat_impl.o psb_c_base_mat_impl.o psb_z_base_mat_impl.o #\ psb_s_lbase_mat_impl.o psb_d_lbase_mat_impl.o psb_c_lbase_mat_impl.o psb_z_lbase_mat_impl.o -SOBJS=psb_s_csr_impl.o psb_s_coo_impl.o psb_s_csc_impl.o psb_s_mat_impl.o +SOBJS=psb_s_csr_impl.o psb_s_coo_impl.o psb_s_csc_impl.o psb_s_mat_impl.o\ + psb_s_rb_idx_tree_impl.o #\ psb_s_lcoo_impl.o psb_s_lcsr_impl.o -DOBJS=psb_d_csr_impl.o psb_d_coo_impl.o psb_d_csc_impl.o psb_d_mat_impl.o +DOBJS=psb_d_csr_impl.o psb_d_coo_impl.o psb_d_csc_impl.o psb_d_mat_impl.o\ + psb_d_rb_idx_tree_impl.o #\ psb_d_lcoo_impl.o psb_d_lcsr_impl.o -COBJS=psb_c_csr_impl.o psb_c_coo_impl.o psb_c_csc_impl.o psb_c_mat_impl.o +COBJS=psb_c_csr_impl.o psb_c_coo_impl.o psb_c_csc_impl.o psb_c_mat_impl.o\ + psb_c_rb_idx_tree_impl.o #\ psb_c_lcoo_impl.o psb_c_lcsr_impl.o -ZOBJS=psb_z_csr_impl.o psb_z_coo_impl.o psb_z_csc_impl.o psb_z_mat_impl.o +ZOBJS=psb_z_csr_impl.o psb_z_coo_impl.o psb_z_csc_impl.o psb_z_mat_impl.o\ + psb_z_rb_idx_tree_impl.o #\ psb_z_lcoo_impl.o psb_z_lcsr_impl.o diff --git a/base/serial/impl/psb_c_coo_impl.F90 b/base/serial/impl/psb_c_coo_impl.F90 index 7e3c81603..46391deee 100644 --- a/base/serial/impl/psb_c_coo_impl.F90 +++ b/base/serial/impl/psb_c_coo_impl.F90 @@ -2817,6 +2817,9 @@ subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_realloc_mod use psb_sort_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_csput_a +#if defined(OPENMP) + use omp_lib +#endif implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a @@ -2828,7 +2831,7 @@ subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) integer(psb_ipk_) :: err_act character(len=20) :: name='c_coo_csput_a_impl' logical, parameter :: debug=.false. - integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit + integer(psb_ipk_) :: nza, i,j,k, nzl, isza, nzaold, debug_level, debug_unit info = psb_success_ debug_unit = psb_get_debug_unit() @@ -2860,10 +2863,13 @@ subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) if (nz == 0) return - - nza = a%get_nzeros() - isza = a%get_size() if (a%is_bld()) then + ! Structure here is peculiar, because this function can be called + ! either within a parallel region, or outside. + ! Hence the call to set_nzeros done here. + !$omp critical + nza = a%get_nzeros() + isza = a%get_size() ! Build phase. Must handle reallocations in a sensible way. if (isza < (nza+nz)) then call a%reallocate(max(nza+nz,int(1.5*isza))) @@ -2871,16 +2877,20 @@ subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) isza = a%get_size() if (isza < (nza+nz)) then info = psb_err_alloc_dealloc_; call psb_errpush(info,name) - goto 9999 + else + nzaold = nza + nza = nza + nz + call a%set_nzeros(nza) end if - - call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& + !$omp end critical + if (info /= 0) goto 9999 + call psb_inner_ins(nz,ia,ja,val,nzaold,a%ia,a%ja,a%val,isza,& & imin,imax,jmin,jmax,info) - call a%set_nzeros(nza) call a%set_sorted(.false.) - - + else if (a%is_upd()) then + nza = a%get_nzeros() + isza = a%get_size() if (a%is_dev()) call a%sync() @@ -2949,7 +2959,6 @@ contains end if end do !$OMP END PARALLEL DO - nza = nza + nz #else do i=1, nz @@ -3478,6 +3487,602 @@ subroutine psb_c_coo_mv_from(a,b) end subroutine psb_c_coo_mv_from +! +! COO implementation of tril/triu +! +subroutine psb_c_coo_tril(a,l,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,u) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_tril + implicit none + + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_c_coo_sparse_mat), optional, intent(out) :: u + + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k + integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + character(len=20) :: name='tril' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + +#if defined(OPENMP) + block + integer(psb_ipk_), allocatable :: lrws(:),urws(:) + integer(psb_ipk_) :: lpnt, upnt, lnz, unz + call psb_realloc(mb,lrws,info) + !$omp workshare + lrws(:) = 0 + !$omp end workshare + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + !write(0,*) 'Invocation of COO%TRIL', present(u),nz + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + if (info == 0) call psb_realloc(mb,urws,info) + !$omp workshare + urws(:) = 0 + !$omp end workshare + !write(0,*) 'omp version of COO%TRIL/TRIU' + lnz = 0 + unz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws,urws) reduction(+: lnz,unz) + loop1: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic update + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + !$omp end atomic + lnz = lnz + 1 + else + !$omp atomic update + urws(i-imin_+1) = urws(i-imin_+1) +1 + !$omp end atomic + unz = unz + 1 + end if + end if + end do loop1 + !$omp end parallel do + + call psi_exscan(mb,lrws,info) + call psi_exscan(mb,urws,info) + !write(0,*) lrws(:), urws(:) + !$omp parallel do private(i,j,k,lpnt,upnt) shared(imin_,imax_,a) + loop2: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic capture + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + lpnt = lrws(i-imin_+1) + !$omp end atomic + l%ia(lpnt) = a%ia(k) + l%ja(lpnt) = a%ja(k) + l%val(lpnt) = a%val(k) + else + !$omp atomic capture + urws(i-imin_+1) = urws(i-imin_+1) +1 + upnt = urws(i-imin_+1) + !$omp end atomic + u%ia(upnt) = a%ia(k) + u%ja(upnt) = a%ja(k) + u%val(upnt) = a%val(k) + end if + end if + end do loop2 + !$omp end parallel do + !write(0,*) 'End of copyout',lnz,unz + call l%set_nzeros(lnz) + call l%fix(info) + call u%set_nzeros(unz) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) then + !$omp workshare + u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + if ((diag_ >=-1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + lnz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws) reduction(+: lnz) + loop3: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic update + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + !$omp end atomic + lnz = lnz + 1 + end if + end if + end do loop3 + !$omp end parallel do + call psi_exscan(mb,lrws,info) + !$omp parallel do private(i,j,k,lpnt) shared(imin_,imax_,a) + loop4: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic capture + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + lpnt = lrws(i-imin_+1) + !$omp end atomic + l%ia(lpnt) = a%ia(k) + l%ja(lpnt) = a%ja(k) + l%val(lpnt) = a%val(k) + end if + end if + end do loop4 + !$omp end parallel do + call l%set_nzeros(lnz) + call l%fix(info) + end if + nzout = l%get_nzeros() + if (rscale_) then + !$omp workshare + l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if + end block + +#else + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, ia=>a%ia) + loop1: do k=1,nz + i = ia(k) + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + nzlin = nzlin + 1 + l%ia(nzlin) = i + l%ja(nzlin) = ja(k) + l%val(nzlin) = val(k) + else + nzuin = nzuin + 1 + u%ia(nzuin) = i + u%ja(nzuin) = ja(k) + u%val(nzuin) = val(k) + end if + end if + end do loop1 + end associate + + call l%set_nzeros(nzlin) + call u%set_nzeros(nzuin) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >=-1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + nzin = l%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, ia=>a%ia) + loop2: do k=1,nz + i = ia(k) + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + nzin = nzin + 1 + l%ia(nzin) = i + l%ja(nzin) = ja(k) + l%val(nzin) = val(k) + end if + end if + end do loop2 + end associate + call l%set_nzeros(nzin) + end if + call l%fix(info) + nzout = l%get_nzeros() + if (rscale_) & + & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if +#endif + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_coo_tril + +subroutine psb_c_coo_triu(a,u,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,l) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_triu + implicit none + + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_c_coo_sparse_mat), optional, intent(out) :: l + + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k + integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + character(len=20) :: name='triu' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + +#if defined(OPENMP) + block + integer(psb_ipk_), allocatable :: lrws(:),urws(:) + integer(psb_ipk_) :: lpnt, upnt, lnz, unz + call psb_realloc(mb,urws,info) + !$omp workshare + urws(:) = 0 + !$omp end workshare + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + !write(0,*) 'Invocation of COO%TRIL', present(u),nz + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + if (info == 0) call psb_realloc(mb,urws,info) + !$omp workshare + lrws(:) = 0 + !$omp end workshare + !write(0,*) 'omp version of COO%TRIL/TRIU' + lnz = 0 + unz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws,urws) reduction(+: lnz,unz) + loop1: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)>=diag_) then + !$omp atomic update + urws(i-imin_+1) = urws(i-imin_+1) +1 + !$omp end atomic + unz = unz + 1 + end if + end if + end do loop3 + !$omp end parallel do + call psi_exscan(mb,urws,info) + !$omp parallel do private(i,j,k,upnt) shared(imin_,imax_,a) + loop4: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)>=diag_) then + !$omp atomic capture + urws(i-imin_+1) = urws(i-imin_+1) +1 + upnt = urws(i-imin_+1) + !$omp end atomic + u%ia(upnt) = a%ia(k) + u%ja(upnt) = a%ja(k) + u%val(upnt) = a%val(k) + end if + end if + end do loop4 + !$omp end parallel do + call u%set_nzeros(unz) + call u%fix(info) + end if + nzout = u%get_nzeros() + if (rscale_) then + !$omp workshare + u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + + if ((diag_ >= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_upper(.true.) + end if + end block + + +#else + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, ia=>a%ia) + loop1: do k=1,nz + i = ia(k) + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)a%val, ja => a%ja, ia=>a%ia) + loop2: do k=1,nz + i = ia(k) + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)>=diag_) then + nzin = nzin + 1 + u%ia(nzin) = i + u%ja(nzin) = ja(k) + u%val(nzin) = val(k) + end if + end if + end do loop2 + end associate + call u%set_nzeros(nzin) + end if + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + + if ((diag_ >= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if +#endif + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_coo_triu + subroutine psb_c_fix_coo(a,info,idir) use psb_const_mod @@ -3561,7 +4166,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) character(len=20) :: name = 'psb_fixcoo' logical :: srt_inp, use_buffers #if defined(OPENMP) - integer(psb_ipk_) :: work,first_idx,last_idx,first_elem,last_elem,s,nthreads,ithread + integer(psb_ipk_) :: work,idxstart,idxend,first_elem,last_elem,s,nthreads,ithread integer(psb_ipk_) :: saved_elem,old_val,nxt_val,err,act_row,act_col,maxthreads integer(psb_ipk_), allocatable :: sum(:),kaux(:),idxaux(:) #endif @@ -3620,8 +4225,6 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ! Dirty trick: call ROWMAJOR with rows <-> columns call psb_c_fix_coo_inner_rowmajor(nc,nr,nzin,dupl,& & ja,ia,val,iaux,nzout,info) -!!$ call psb_c_fix_coo_inner_colmajor(nr,nc,nzin,dupl,& -!!$ & ia,ja,val,iaux,nzout,info) case default write(debug_unit,*) trim(name),': unknown direction ',idir_ info = psb_err_internal_error_ @@ -3660,12 +4263,13 @@ subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf integer(psb_ipk_), allocatable :: ias(:),jas(:), ix2(:) complex(psb_spk_), allocatable :: vs(:) integer(psb_ipk_) :: nza, nzl,iret - integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii + integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii, i1, i2 integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name = 'psb_fixcoo' logical :: srt_inp, use_buffers + real(psb_dpk_) :: t0, t1 #if defined(OPENMP) - integer(psb_ipk_) :: work,first_idx,last_idx,first_elem,last_elem,s,nthreads,ithread + integer(psb_ipk_) :: work,idxstart,idxend,first_elem,last_elem,s,nthreads,ithread integer(psb_ipk_) :: saved_elem,old_val,nxt_val,err,act_row,act_col,maxthreads integer(psb_ipk_), allocatable :: sum(:),kaux(:),idxaux(:) #endif @@ -3747,9 +4351,9 @@ subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf ! Here, starting from 'iaux', we apply a fixing in order to obtain the starting ! index for each row. We do the same on 'kaux' !$OMP PARALLEL default(none) & - !$OMP shared(idxaux,ia,ja,val,ias,jas,vs,nthreads,sum,nr,nc,nzin,iaux,kaux,dupl,err) & - !$OMP private(s,i,j,k,ithread,first_idx,last_idx,work,nxt_val,old_val,saved_elem, & - !$OMP first_elem,last_elem,nzl,iret,act_row) + !$OMP shared(t0,t1,idxaux,ia,ja,val,ias,jas,vs,nthreads,sum,nr,nc,nzin,iaux,kaux,dupl,err) & + !$OMP private(s,i,j,k,ithread,idxstart,idxend,work,nxt_val,old_val,saved_elem, & + !$OMP first_elem,last_elem,nzl,iret,act_row,i1,i2) reduction(max: info) !$OMP SINGLE nthreads = omp_get_num_threads() @@ -3762,81 +4366,46 @@ subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf work = nr/nthreads if (ithread < MOD(nr,nthreads)) then work = work + 1 - first_idx = ithread*work + 1 + idxstart = ithread*work + 1 else - first_idx = ithread*work + MOD(nr,nthreads) + 1 + idxstart = ithread*work + MOD(nr,nthreads) + 1 end if - last_idx = first_idx + work - 1 - - !------------------------------------------- - ! ------------ iaux composition -------------- - ! 'iaux' will have the start index for each row - - s = 0 - do i=first_idx,last_idx - s = s + iaux(i) - end do - sum(ithread+2) = s + idxend = idxstart + work - 1 + !write(0,*) 'fix_coo_inner: trying with exscan' + call psi_exscan(nr+1,iaux,info,shift=ione) !$OMP BARRIER - !$OMP SINGLE - do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) - end do + !t0 = omp_get_wtime() !$OMP END SINGLE - - if (work > 0) then - saved_elem = iaux(first_idx) - end if - - if (ithread == 0) then - iaux(1) = 1 - end if - - !$OMP BARRIER - - if (work > 0) then - old_val = iaux(first_idx+1) - iaux(first_idx+1) = saved_elem + sum(ithread+1) - end if - - do i=first_idx+2,last_idx+1 - nxt_val = iaux(i) - iaux(i) = iaux(i-1) + old_val - old_val = nxt_val - end do - - ! -------------------------------------- - - !$OMP BARRIER - + ! ------------------ Sorting and buffers ------------------- ! Let's use an auxiliary buffer, 'idxaux', to get indices leaving ! unmodified 'iaux' - do j=first_idx,last_idx + do j=idxstart,idxend idxaux(j) = iaux(j) end do - ! Here we sort data inside the auxiliary buffers do i=1,nzin act_row = ia(i) - if ((act_row >= first_idx) .and. (act_row <= last_idx)) then + if ((act_row >= idxstart) .and. (act_row <= idxend)) then ias(idxaux(act_row)) = ia(i) jas(idxaux(act_row)) = ja(i) vs(idxaux(act_row)) = val(i) - idxaux(act_row) = idxaux(act_row) + 1 end if end do !$OMP BARRIER - + !$OMP SINGLE + !t1 = omp_get_wtime() + !write(0,*) ithread,'Srt&Cpy :',t1-t0 + !$OMP END SINGLE ! Let's sort column indices and values. After that we will store ! the number of unique values in 'kaux' - do j=first_idx,last_idx + do j=idxstart,idxend first_elem = iaux(j) last_elem = iaux(j+1) - 1 nzl = last_elem - first_elem + 1 @@ -3865,45 +4434,7 @@ subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf ! -------------------------------------------------- ! ---------------- kaux composition ---------------- - !$OMP SINGLE - sum(:) = 0 - sum(1) = 1 - !$OMP END SINGLE - - s = 0 - do i=first_idx,last_idx - s = s + kaux(i) - end do - sum(ithread+2) = s - - !$OMP BARRIER - - !$OMP SINGLE - do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) - end do - kaux(nr+1) = sum(nthreads+1) - !$OMP END SINGLE - - if (work > 0) then - saved_elem = kaux(first_idx) - end if - if (ithread == 0) then - kaux(1) = 1 - end if - - !$OMP BARRIER - - if (work > 0) then - old_val = kaux(first_idx+1) - kaux(first_idx+1) = saved_elem + sum(ithread+1) - end if - - do i=first_idx+2,last_idx+1 - nxt_val = kaux(i) - kaux(i) = kaux(i-1) + old_val - old_val = nxt_val - end do + call psi_exscan(nr+1,kaux,i,shift=ione) !$OMP BARRIER @@ -3911,7 +4442,7 @@ subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf select case(dupl) case(psb_dupl_ovwrt_) - !$OMP DO schedule(STATIC) + !$OMP DO schedule(dynamic,32) do j=1,nr first_elem = iaux(j) last_elem = iaux(j+1) - 1 @@ -3940,7 +4471,7 @@ subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf !$OMP END DO case(psb_dupl_add_) - !$OMP DO schedule(STATIC) + !$OMP DO schedule(dynamic,32) do j=1,nr first_elem = iaux(j) last_elem = iaux(j+1) - 1 @@ -3969,7 +4500,7 @@ subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf !$OMP END DO case(psb_dupl_err_) - !$OMP DO schedule(STATIC) + !$OMP DO schedule(dynamic,32) do j=1,nr first_elem = iaux(j) last_elem = iaux(j+1) - 1 @@ -4174,7 +4705,7 @@ subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf #if defined(OPENMP) !$OMP PARALLEL default(none) & !$OMP shared(nr,nc,nzin,iaux,ia,ja,val,nthreads) & - !$OMP private(i,j,first_idx,last_idx,nzl,act_row,iret,ithread, & + !$OMP private(i,j,idxstart,idxend,nzl,act_row,iret,ithread, & !$OMP work,first_elem,last_elem) !$OMP SINGLE @@ -4188,22 +4719,22 @@ subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf work = nr/nthreads if (ithread < MOD(nr,nthreads)) then work = work + 1 - first_idx = ithread*work + 1 + idxstart = ithread*work + 1 else - first_idx = ithread*work + MOD(nr,nthreads) + 1 + idxstart = ithread*work + MOD(nr,nthreads) + 1 end if - last_idx = first_idx + work - 1 + idxend = idxstart + work - 1 ! --------------------------------------------------- first_elem = 0 last_elem = -1 - act_row = first_idx + act_row = idxstart do j=1,nzin if (ia(j) < act_row) then cycle - else if ((ia(j) > last_idx) .or. (work < 1)) then + else if ((ia(j) > idxend) .or. (work < 1)) then exit else if (ia(j) > act_row) then nzl = last_elem - first_elem + 1 @@ -4333,684 +4864,14 @@ subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf end subroutine psb_c_fix_coo_inner_rowmajor -subroutine psb_c_fix_coo_inner_colmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,info) - use psb_const_mod + +subroutine psb_c_cp_coo_to_lcoo(a,b,info) use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_c_fix_coo_inner_colmajor - use psb_string_mod - use psb_ip_reord_mod - use psb_sort_mod -#if defined(OPENMP) - use omp_lib -#endif + use psb_c_base_mat_mod, psb_protect_name => psb_c_cp_coo_to_lcoo implicit none - - integer(psb_ipk_), intent(in) :: nr, nc, nzin, dupl - integer(psb_ipk_), intent(inout) :: ia(:), ja(:), iaux(:) - complex(psb_spk_), intent(inout) :: val(:) - integer(psb_ipk_), intent(out) :: nzout, info - !locals - integer(psb_ipk_), allocatable :: ias(:),jas(:), ix2(:) - complex(psb_spk_), allocatable :: vs(:) - integer(psb_ipk_) :: nza, nzl,iret - integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name = 'psb_fixcoo' - logical :: srt_inp, use_buffers -#if defined(OPENMP) - integer(psb_ipk_) :: work,first_idx,last_idx,first_elem,last_elem,s,nthreads,ithread - integer(psb_ipk_) :: saved_elem,old_val,nxt_val,err,act_row,act_col,maxthreads - integer(psb_ipk_), allocatable :: sum(:),kaux(:),idxaux(:) -#endif - info = psb_success_ - - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if (nc <= nzin) then - ! Avoid strange situations with large indices -#if defined(OPENMP) - allocate(ias(nzin),jas(nzin),vs(nzin), stat=info) -#else - allocate(ias(nzin),jas(nzin),vs(nzin),ix2(nzin+2), stat=info) -#endif - use_buffers = (info == 0) - else - use_buffers = .false. - end if - - if (use_buffers) then - iaux(:) = 0 -#if defined(OPENMP) - !$OMP PARALLEL DO default(none) schedule(STATIC) & - !$OMP shared(nzin,ja,nc,iaux) & - !$OMP private(i) & - !$OMP reduction(.and.:use_buffers) - do i=1,nzin - if ((ja(i) < 1).or.(ja(i) > nc)) then - use_buffers = .false. - ! Invalid indices are placed outside the considered range - ja(i) = nc+2 - else - !$OMP ATOMIC UPDATE - iaux(ja(i)) = iaux(ja(i)) + 1 - end if - end do - !$OMP END PARALLEL DO -#else - !srt_inp = .true. - do i=1,nzin - if ((ja(i) < 1).or.(ja(i) > nc)) then - use_buffers = .false. - !ja(i) = nc+2 - !srt_inp = .false. - exit - end if - - iaux(ja(i)) = iaux(ja(i)) + 1 - - !srt_inp = srt_inp .and.(ja(i-1)<=ja(i)) - end do -#endif - end if - - !use_buffers=use_buffers.and.srt_inp - - ! Check again use_buffers. We enter here if nzin >= nc and - ! all the indices are valid - if (use_buffers) then -#if defined(OPENMP) - allocate(kaux(MAX(nzin,nc)+2),idxaux(MAX((nr+2)*maxthreads,nc)),sum(maxthreads+1),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - kaux(:) = 0 - sum(:) = 0 - sum(1) = 1 - err = 0 - - ! Here, starting from 'iaux', we apply a fixing in order to obtain the starting - ! index for each column. We do the same on 'kaux' - !$OMP PARALLEL default(none) & - !$OMP shared(idxaux,ia,ja,val,ias,jas,vs,nthreads,sum,nr,nc,nzin,iaux,kaux,dupl,err) & - !$OMP private(s,i,j,k,ithread,first_idx,last_idx,work,nxt_val,old_val,saved_elem, & - !$OMP first_elem,last_elem,nzl,iret,act_col) - - !$OMP SINGLE - nthreads = omp_get_num_threads() - !$OMP END SINGLE - - ithread = omp_get_thread_num() - - ! -------- thread-specific workload -------- - - work = nc/nthreads - if (ithread < MOD(nc,nthreads)) then - work = work + 1 - first_idx = ithread*work + 1 - else - first_idx = ithread*work + MOD(nc,nthreads) + 1 - end if - - last_idx = first_idx + work - 1 - - !------------------------------------------- - ! ---------- iaux composition -------------- - - s = 0 - do i=first_idx,last_idx - s = s + iaux(i) - end do - sum(ithread+2) = s - - !$OMP BARRIER - - !$OMP SINGLE - do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) - end do - !$OMP END SINGLE - - if (work > 0) then - saved_elem = iaux(first_idx) - end if - if (ithread == 0) then - iaux(1) = 1 - end if - - !$OMP BARRIER - - if (work > 0) then - old_val = iaux(first_idx+1) - iaux(first_idx+1) = saved_elem + sum(ithread+1) - end if - - do i=first_idx+2,last_idx+1 - nxt_val = iaux(i) - iaux(i) = iaux(i-1) + old_val - old_val = nxt_val - end do - - ! -------------------------------------- - - !$OMP BARRIER - - ! ------------------ Sorting and buffers ------------------- - - ! Let's use an auxiliary buffer to get indices - do j=first_idx,last_idx - idxaux(j) = iaux(j) - end do - - ! Here we sort data inside the auxiliary buffers - do i=1,nzin - act_col = ja(i) - if (act_col >= first_idx .and. act_col <= last_idx) then - ias(idxaux(act_col)) = ia(i) - jas(idxaux(act_col)) = ja(i) - vs(idxaux(act_col)) = val(i) - - idxaux(act_col) = idxaux(act_col) + 1 - end if - end do - - !$OMP BARRIER - - ! Let's sort column indices and values. After that we will store - ! the number of unique values in 'kaux' - do j=first_idx,last_idx - first_elem = iaux(j) - last_elem = iaux(j+1) - 1 - nzl = last_elem - first_elem + 1 - - ! The column has elements? - if (nzl > 0) then - call psi_msort_up(nzl,ias(first_elem:last_elem), & - & idxaux((ithread*(nr+2))+1:(ithread*(nr+2))+nzl+2),iret) - - if (iret == 0) then - call psb_ip_reord(nzl,vs(first_elem:last_elem),& - & ias(first_elem:last_elem),jas(first_elem:last_elem), & - & idxaux((ithread*(nr+2))+1:(ithread*(nr+2))+nzl+2)) - end if - - ! Over each column we count the unique values - kaux(j) = 1 - do i=first_elem+1,last_elem - if (ias(i) == ias(i-1) .and. jas(i) == jas(i-1)) then - cycle - end if - kaux(j) = kaux(j) + 1 - end do - end if - end do - - ! -------------------------------------------------- - - ! ---------------- kaux composition ---------------- - - !$OMP SINGLE - sum(:) = 0 - sum(1) = 1 - !$OMP END SINGLE - - s = 0 - do i=first_idx,last_idx - s = s + kaux(i) - end do - sum(ithread+2) = s - - !$OMP BARRIER - - !$OMP SINGLE - do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) - end do - !$OMP END SINGLE - - if (work > 0) then - saved_elem = kaux(first_idx) - end if - if (ithread == 0) then - kaux(1) = 1 - end if - - !$OMP BARRIER - - if (work > 0) then - old_val = kaux(first_idx+1) - kaux(first_idx+1) = saved_elem + sum(ithread+1) - end if - - do i=first_idx+2,last_idx+1 - nxt_val = kaux(i) - kaux(i) = kaux(i-1) + old_val - old_val = nxt_val - end do - - !$OMP BARRIER - - ! ------------------------------------------------ - - select case(dupl) - case(psb_dupl_ovwrt_) - !$OMP DO schedule(STATIC) - do j=1,nc - first_elem = iaux(j) - last_elem = iaux(j+1) - 1 - - if (first_elem > last_elem) then - cycle - end if - - k = kaux(j) - - val(k) = vs(first_elem) - ia(k) = ias(first_elem) - ja(k) = jas(first_elem) - - do i=first_elem+1,last_elem - if ((ias(i) == ias(i-1)).and.(jas(i) == jas(i-1))) then - val(k) = vs(i) - else - k = k + 1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - endif - end do - end do - !$OMP END DO - - case(psb_dupl_add_) - !$OMP DO schedule(STATIC) - do j=1,nc - first_elem = iaux(j) - last_elem = iaux(j+1) - 1 - - if (first_elem > last_elem) then - cycle - end if - - k = kaux(j) - - val(k) = vs(first_elem) - ia(k) = ias(first_elem) - ja(k) = jas(first_elem) - - do i=first_elem+1,last_elem - if ((ias(i) == ias(i-1)).and.(jas(i) == jas(i-1))) then - val(k) = val(k) + vs(i) - else - k = k + 1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - endif - end do - end do - !$OMP END DO - - case(psb_dupl_err_) - !$OMP DO schedule(STATIC) - do j=1,nc - first_elem = iaux(j) - last_elem = iaux(j+1) - 1 - - if (first_elem > last_elem) then - cycle - end if - - k = kaux(j) - - val(k) = vs(first_elem) - ia(k) = ias(first_elem) - ja(k) = jas(first_elem) - - do i=first_elem+1,last_elem - if ((ias(i) == ias(i-1)).and.(jas(i) == jas(i-1))) then - err = 1 - else - k = k + 1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - end if - end do - end do - !$OMP END DO - - case default - !$OMP SINGLE - err = 2 - !$OMP END SINGLE - end select - - !$OMP END PARALLEL - - if (err == 1) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else if (err == 2) then - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl - info =-7 - return - end if - - nzout = kaux(nc+1) - 1 - - deallocate(sum,kaux,idxaux,stat=info) -#else - !if (.not.srt_inp) then - ip = iaux(1) - iaux(1) = 0 - do i=2, nc - is = iaux(i) - iaux(i) = ip - ip = ip + is - end do - iaux(nc+1) = ip - - do i=1,nzin - icl = ja(i) - ip = iaux(icl) + 1 - ias(ip) = ia(i) - jas(ip) = ja(i) - vs(ip) = val(i) - iaux(icl) = ip - end do - !end if - - select case(dupl) - case(psb_dupl_ovwrt_) - k = 0 - i = 1 - do j=1, nc - nzl = iaux(j)-i+1 - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ias(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,vs(i:imx),& - & ias(i:imx),jas(i:imx),ix2) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - end if - end do - - case(psb_dupl_add_) - k = 0 - i = 1 - do j=1, nc - nzl = iaux(j)-i+1 - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ias(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,vs(i:imx),& - & ias(i:imx),jas(i:imx),ix2) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = val(k) + vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - end if - end do - - case(psb_dupl_err_) - k = 0 - i = 1 - do j=1, nc - nzl = iaux(j)-i+1 - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ias(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,vs(i:imx),& - & ias(i:imx),jas(i:imx),ix2) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - end if - end do - - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl - info =-7 - return - end select - - nzout = k - - deallocate(ix2, stat=info) -#endif - - deallocate(ias,jas,vs, stat=info) - - else if (.not.use_buffers) then - - call psi_msort_up(nzin,ja(1:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(nzin,val,ia,ja,iaux) -#if defined(OPENMP) - !$OMP PARALLEL default(none) & - !$OMP shared(nr,nc,nzin,iaux,ia,ja,val,nthreads) & - !$OMP private(i,j,first_idx,last_idx,nzl,act_col, & - !$OMP iret,ithread,work,first_elem,last_elem) - - !$OMP SINGLE - nthreads = omp_get_num_threads() - !$OMP END SINGLE - - ithread = omp_get_thread_num() - - ! -------- thread-specific workload -------- - - work = nc/nthreads - if (ithread < MOD(nc,nthreads)) then - work = work + 1 - first_idx = ithread*work + 1 - else - first_idx = ithread*work + MOD(nc,nthreads) + 1 - end if - - last_idx = first_idx + work - 1 - - ! --------------------------------------------------- - - first_elem = 0 - last_elem = -1 - act_col = first_idx - do j=1,nzin - if (ja(j) < act_col) then - cycle - else if ((ja(j) > last_idx) .or. (work < 1)) then - exit - else if (ja(j) > act_col) then - nzl = last_elem - first_elem + 1 - - if (nzl > 0) then - call psi_msort_up(nzl,ia(first_elem:),iaux((ithread*(nr+2))+1:(ithread*(nr+2))+nzl+2),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(first_elem:last_elem),& - & ia(first_elem:last_elem),ja(first_elem:last_elem),& - & iaux((ithread*(nr+2))+1:(ithread*(nr+2))+nzl+2)) - end if - - act_col = act_col + 1 - first_elem = 0 - last_elem = -1 - else - if (first_elem == 0) then - first_elem = j - end if - - last_elem = j - end if - end do - !$OMP END PARALLEL -#else - i = 1 - j = i - do while (i <= nzin) - do while ((ja(j) == ja(i))) - j = j+1 - if (j > nzin) exit - enddo - nzl = j - i - call psi_msort_up(nzl,ia(i:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(i:i+nzl-1),& - & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) - i = j - enddo -#endif - - i = 1 - irw = ia(i) - icl = ja(i) - j = 1 - - - select case(dupl) - case(psb_dupl_ovwrt_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) < 1 .or. ia(j) > nr) .or. (ja(j) < 1 .or. ja(j) > nc)) cycle - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_add_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) < 1 .or. ia(j) > nr) .or. (ja(j) < 1 .or. ja(j) > nc)) cycle - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(i) + val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_err_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) < 1 .or. ia(j) > nr) .or. (ja(j) < 1 .or. ja(j) > nc)) cycle - if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl - info =-7 - end select - - nzout = i - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end second loop' - - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_c_fix_coo_inner_colmajor - - -subroutine psb_c_cp_coo_to_lcoo(a,b,info) - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_c_cp_coo_to_lcoo - implicit none - class(psb_c_coo_sparse_mat), intent(in) :: a - class(psb_lc_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_lpk_) :: nz @@ -5296,7 +5157,7 @@ function psb_lc_coo_maxval(a) result(res) #if defined(OPENMP) block integer(psb_ipk_) :: i - !$omp parallel do private(i) + !$omp parallel do private(i) reduction(max:res) do i=1, nnz res = max(res,abs(a%val(i))) end do @@ -5363,7 +5224,7 @@ function psb_lc_coo_csnmi(a) result(res) #if defined(OPENMP) block integer(psb_ipk_) :: i - !$omp parallel do private(i) + !$omp parallel do private(i) reduction(max:res) do i=1, m res = max(res,abs(vt(i))) end do @@ -5413,7 +5274,7 @@ function psb_lc_coo_csnm1(a) result(res) #if defined(OPENMP) block integer(psb_ipk_) :: i - !$omp parallel do private(i) + !$omp parallel do private(i) reduction(max:res) do i=1, n res = max(res,abs(vt(i))) end do @@ -8335,3 +8196,4 @@ subroutine psb_lc_cp_coo_from_icoo(a,b,info) return end subroutine psb_lc_cp_coo_from_icoo + diff --git a/base/serial/impl/psb_c_csc_impl.F90 b/base/serial/impl/psb_c_csc_impl.F90 index 6360d73a1..54332d063 100644 --- a/base/serial/impl/psb_c_csc_impl.F90 +++ b/base/serial/impl/psb_c_csc_impl.F90 @@ -2189,6 +2189,9 @@ subroutine psb_c_mv_csc_from_coo(a,b,info) use psb_error_mod use psb_c_base_mat_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_mv_csc_from_coo +#if defined(OPENMP) + use omp_lib +#endif implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a @@ -2223,18 +2226,33 @@ subroutine psb_c_mv_csc_from_coo(a,b,info) call psb_realloc(nc+1,a%icp,info) call b%free() +#if defined(OPENMP) + + !$OMP PARALLEL default(shared) + + !$OMP WORKSHARE a%icp(:) = 0 + !$OMP END WORKSHARE + + !$OMP DO schedule(STATIC) & + !$OMP private(k,i) do k=1,nza i = itemp(k) - a%icp(i) = a%icp(i) + 1 + !$OMP ATOMIC UPDATE + a%icp(i+1) = a%icp(i+1) + 1 + !$OMP END ATOMIC end do - ip = 1 - do i=1,nc - nrl = a%icp(i) - a%icp(i) = ip - ip = ip + nrl + !$OMP END DO + call psi_exscan(nc+1,a%icp,info,shift=ione) + !$OMP END PARALLEL +#else + a%icp(:) = 0 + do k=1,nza + i = itemp(k) + a%icp(i) = a%icp(i) + 1 end do - a%icp(nc+1) = ip + call psi_exscan(nc+1,a%icp,info,shift=ione) +#endif call a%set_host() @@ -2311,9 +2329,28 @@ subroutine psb_c_cp_csc_to_fmt(a,b,info) b%psb_c_base_sparse_mat = a%psb_c_base_sparse_mat nc = a%get_ncols() nz = a%get_nzeros() - if (info == 0) call psb_safe_cpy( a%icp(1:nc+1), b%icp , info) - if (info == 0) call psb_safe_cpy( a%ia(1:nz), b%ia , info) - if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + if (.false.) then + if (info == 0) call psb_safe_cpy( a%icp(1:nc+1), b%icp , info) + if (info == 0) call psb_safe_cpy( a%ia(1:nz), b%ia , info) + if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + else + ! Despite the implementation in safe_cpy, it seems better this way + call psb_realloc(nc+1,b%icp,info) + call psb_realloc(nz,b%ia,info) + call psb_realloc(nz,b%val,info) + !$omp parallel do private(i) schedule(static) + do i=1,nc+1 + b%icp(i)=a%icp(i) + end do + !$omp end parallel do + !$omp parallel do private(j) schedule(static) + do j=1,nz + b%ia(j) = a%ia(j) + b%val(j) = a%val(j) + end do + !$omp end parallel do + end if + call b%set_host() class default @@ -2425,9 +2462,27 @@ subroutine psb_c_cp_csc_from_fmt(a,b,info) a%psb_c_base_sparse_mat = b%psb_c_base_sparse_mat nc = b%get_ncols() nz = b%get_nzeros() - if (info == 0) call psb_safe_cpy( b%icp(1:nc+1), a%icp , info) - if (info == 0) call psb_safe_cpy( b%ia(1:nz), a%ia , info) - if (info == 0) call psb_safe_cpy( b%val(1:nz), a%val , info) + if (.false.) then + if (info == 0) call psb_safe_cpy( b%icp(1:nc+1), a%icp , info) + if (info == 0) call psb_safe_cpy( b%ia(1:nz), a%ia , info) + if (info == 0) call psb_safe_cpy( b%val(1:nz), a%val , info) + else + ! Despite the implementation in safe_cpy, it seems better this way + call psb_realloc(nc+1,a%icp,info) + call psb_realloc(nz,a%ia,info) + call psb_realloc(nz,a%val,info) + !$omp parallel do private(i) schedule(static) + do i=1,nc+1 + a%icp(i)=b%icp(i) + end do + !$omp end parallel do + !$omp parallel do private(j) schedule(static) + do j=1,nz + a%ia(j)=b%ia(j) + a%val(j)=b%val(j) + end do + !$omp end parallel do + end if call a%set_host() class default diff --git a/base/serial/impl/psb_c_csr_impl.F90 b/base/serial/impl/psb_c_csr_impl.F90 index 4744d9475..f6426f499 100644 --- a/base/serial/impl/psb_c_csr_impl.F90 +++ b/base/serial/impl/psb_c_csr_impl.F90 @@ -152,6 +152,7 @@ contains !$omp parallel do private(i,j, acc) schedule(static) do i=1,m acc = czero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -163,6 +164,7 @@ contains !$omp parallel do private(i,j, acc) do i=1,m acc = czero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -174,6 +176,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = czero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -189,6 +192,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = czero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -200,6 +204,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = czero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -211,6 +216,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = czero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -225,6 +231,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = czero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -236,6 +243,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = czero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -247,6 +255,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = czero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -261,6 +270,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = czero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -272,6 +282,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = czero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -283,6 +294,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = czero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -2277,7 +2289,155 @@ subroutine psb_c_csr_tril(a,l,info,& nb = jmax_ endif +#if defined(OPENMP) + block + integer(psb_ipk_), allocatable :: lrws(:),urws(:) + integer(psb_ipk_) :: lpnt, upnt, lnz, unz + call psb_realloc(mb,lrws,info) + !$omp workshare + lrws(:) = 0 + !$omp end workshare + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + !write(0,*) 'Invocation of COO%TRIL', present(u),nz + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + if (info == 0) call psb_realloc(mb,urws,info) + !$omp workshare + urws(:) = 0 + !$omp end workshare + !write(0,*) 'omp version of COO%TRIL/TRIU' + lnz = 0 + unz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws,urws) reduction(+: lnz,unz) + loop1: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic update + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + !$omp end atomic + lnz = lnz + 1 + else + !$omp atomic update + urws(i-imin_+1) = urws(i-imin_+1) +1 + !$omp end atomic + unz = unz + 1 + end if + end if + end do + end do loop1 + !$omp end parallel do + + call psi_exscan(mb,lrws,info) + call psi_exscan(mb,urws,info) + !write(0,*) lrws(:), urws(:) + !$omp parallel do private(i,j,k,lpnt,upnt) shared(imin_,imax_,a) + loop2: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic capture + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + lpnt = lrws(i-imin_+1) + !$omp end atomic + l%ia(lpnt) = i + l%ja(lpnt) = a%ja(k) + l%val(lpnt) = a%val(k) + else + !$omp atomic capture + urws(i-imin_+1) = urws(i-imin_+1) +1 + upnt = urws(i-imin_+1) + !$omp end atomic + u%ia(upnt) = i + u%ja(upnt) = a%ja(k) + u%val(upnt) = a%val(k) + end if + end if + end do + end do loop2 + !$omp end parallel do + !write(0,*) 'End of copyout',lnz,unz + call l%set_nzeros(lnz) + call l%fix(info) + call u%set_nzeros(unz) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) then + !$omp workshare + u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + if ((diag_ >=-1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + lnz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws) reduction(+: lnz) + loop3: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic update + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + !$omp end atomic + lnz = lnz + 1 + end if + end if + end do + end do loop3 + !$omp end parallel do + call psi_exscan(mb,lrws,info) + !$omp parallel do private(i,j,k,lpnt) shared(imin_,imax_,a) + loop4: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic capture + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + lpnt = lrws(i-imin_+1) + !$omp end atomic + l%ia(lpnt) = i + l%ja(lpnt) = a%ja(k) + l%val(lpnt) = a%val(k) + end if + end if + end do + end do loop4 + !$omp end parallel do + call l%set_nzeros(lnz) + call l%fix(info) + end if + nzout = l%get_nzeros() + if (rscale_) then + !$omp workshare + l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if + end block +#else nz = a%get_nzeros() call l%allocate(mb,nb,nz) @@ -2347,7 +2507,7 @@ subroutine psb_c_csr_tril(a,l,info,& call l%set_triangle(.true.) call l%set_lower(.true.) end if - +#endif if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2431,6 +2591,158 @@ subroutine psb_c_csr_triu(a,u,info,& endif +#if defined(OPENMP) + block + integer(psb_ipk_), allocatable :: lrws(:),urws(:) + integer(psb_ipk_) :: lpnt, upnt, lnz, unz + call psb_realloc(mb,urws,info) + !$omp workshare + urws(:) = 0 + !$omp end workshare + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + !write(0,*) 'Invocation of COO%TRIL', present(u),nz + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + if (info == 0) call psb_realloc(mb,urws,info) + !$omp workshare + lrws(:) = 0 + !$omp end workshare + !write(0,*) 'omp version of COO%TRIL/TRIU' + lnz = 0 + unz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws,urws) reduction(+: lnz,unz) + loop1: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)=diag_) then + !$omp atomic update + urws(i-imin_+1) = urws(i-imin_+1) +1 + !$omp end atomic + unz = unz + 1 + end if + end if + end do + end do loop3 + !$omp end parallel do + call psi_exscan(mb,urws,info) + !$omp parallel do private(i,j,k,upnt) shared(imin_,imax_,a) + loop4: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)>=diag_) then + !$omp atomic capture + urws(i-imin_+1) = urws(i-imin_+1) +1 + upnt = urws(i-imin_+1) + !$omp end atomic + u%ia(upnt) = i + u%ja(upnt) = a%ja(k) + u%val(upnt) = a%val(k) + end if + end if + end do + end do loop4 + !$omp end parallel do + call u%set_nzeros(unz) + call u%fix(info) + end if + nzout = u%get_nzeros() + if (rscale_) then + !$omp workshare + u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + + if ((diag_ >= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_upper(.true.) + end if + end block + + +#else + nz = a%get_nzeros() call u%allocate(mb,nb,nz) @@ -2499,7 +2811,7 @@ subroutine psb_c_csr_triu(a,u,info,& call u%set_triangle(.true.) call u%set_upper(.true.) end if - +#endif if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2844,6 +3156,9 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) use psb_realloc_mod use psb_c_base_mat_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_cp_csr_from_coo +#if defined(OPENMP) + use omp_lib +#endif implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a @@ -2860,12 +3175,6 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) character(len=20) :: name='c_cp_csr_from_coo' logical :: use_openmp = .false. - !$ integer(psb_ipk_), allocatable :: sum(:) - !$ integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s,j - !$ integer(psb_ipk_) :: nxt_val,old_val,saved_elem,maxthreads - !$ use_openmp = .true. - - info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2904,98 +3213,39 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) if (info == psb_success_) call psb_safe_ab_cpy(b%ja,a%ja,info) if (info == psb_success_) call psb_safe_ab_cpy(b%val,a%val,info) if (info == psb_success_) call psb_realloc(max(nr+1,nc+1),a%irp,info) - + endif + +#if defined(OPENMP) + + !$OMP PARALLEL default(shared) reduction(max:info) + + !$OMP WORKSHARE a%irp(:) = 0 - -!!$ if (use_openmp) then -!!$ !$ maxthreads = omp_get_max_threads() -!!$ !$ allocate(sum(maxthreads+1)) -!!$ !$ sum(:) = 0 -!!$ !$ sum(1) = 1 -!!$ -!!$ !$OMP PARALLEL default(none) & -!!$ !$OMP shared(nza,itemp,a,nthreads,sum,nr) & -!!$ !$OMP private(ithread,work,first_idx,last_idx,s,saved_elem,nxt_val,old_val) -!!$ -!!$ !$OMP DO schedule(STATIC) & -!!$ !$OMP private(k,i) -!!$ do k=1,nza -!!$ i = itemp(k) -!!$ a%irp(i) = a%irp(i) + 1 -!!$ end do -!!$ !$OMP END DO -!!$ -!!$ !$OMP SINGLE -!!$ !$ nthreads = omp_get_num_threads() -!!$ !$OMP END SINGLE -!!$ -!!$ !$ ithread = omp_get_thread_num() -!!$ -!!$ !$ work = nr/nthreads -!!$ !$ if (ithread < MOD(nr,nthreads)) then -!!$ !$ work = work + 1 -!!$ !$ first_idx = ithread*work + 1 -!!$ !$ else -!!$ !$ first_idx = ithread*work + MOD(nr,nthreads) + 1 -!!$ !$ end if -!!$ -!!$ !$ last_idx = first_idx + work - 1 -!!$ -!!$ !$ s = 0 -!!$ !$ do i=first_idx,last_idx -!!$ !$ s = s + a%irp(i) -!!$ !$ end do -!!$ !$ if (work > 0) then -!!$ !$ sum(ithread+2) = s -!!$ !$ end if -!!$ -!!$ !$OMP BARRIER -!!$ -!!$ !$OMP SINGLE -!!$ !$ do i=2,nthreads+1 -!!$ !$ sum(i) = sum(i) + sum(i-1) -!!$ !$ end do -!!$ !$OMP END SINGLE -!!$ -!!$ !$ if (work > 0) then -!!$ !$ saved_elem = a%irp(first_idx) -!!$ !$ end if -!!$ !$ if (ithread == 0) then -!!$ !$ a%irp(1) = 1 -!!$ !$ end if -!!$ -!!$ !$OMP BARRIER -!!$ -!!$ !$ if (work > 0) then -!!$ !$ old_val = a%irp(first_idx+1) -!!$ !$ a%irp(first_idx+1) = saved_elem + sum(ithread+1) -!!$ !$ end if -!!$ -!!$ !$ do i=first_idx+2,last_idx+1 -!!$ !$ nxt_val = a%irp(i) -!!$ !$ a%irp(i) = a%irp(i-1) + old_val -!!$ !$ old_val = nxt_val -!!$ !$ end do -!!$ -!!$ !$OMP END PARALLEL -!!$ else - - do k=1,nza - i = itemp(k) - a%irp(i) = a%irp(i) + 1 - end do - ip = 1 - do i=1,nr - ncl = a%irp(i) - a%irp(i) = ip - ip = ip + ncl - end do - a%irp(nr+1) = ip -!!$ end if - call a%set_host() + !$OMP END WORKSHARE + + !$OMP DO schedule(STATIC) & + !$OMP private(k,i) + do k=1,nza + i = itemp(k) + !$OMP ATOMIC UPDATE + a%irp(i) = a%irp(i) + 1 + !$OMP END ATOMIC + end do + !$OMP END DO + call psi_exscan(nr+1,a%irp,info,shift=ione) + !$OMP END PARALLEL +#else + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + call psi_exscan(nr+1,a%irp,info,shift=ione) +#endif + call a%set_host() end subroutine psb_c_cp_csr_from_coo @@ -3096,6 +3346,9 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) use psb_error_mod use psb_c_base_mat_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_mv_csr_from_coo +#if defined(OPENMP) + use omp_lib +#endif implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a @@ -3109,13 +3362,6 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='mv_from_coo' - logical :: use_openmp = .false. - - ! $ integer(psb_ipk_), allocatable :: sum(:) - ! $ integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s - ! $ integer(psb_ipk_) :: nxt_val,old_val,saved_elem - ! $ use_openmp = .true. - info = psb_success_ debug_unit = psb_get_debug_unit() @@ -3139,90 +3385,34 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) call psb_realloc(max(nr+1,nc+1),a%irp,info) call b%free() +#if defined(OPENMP) + !$OMP PARALLEL default(shared) reduction(max:info) + + !$OMP WORKSHARE a%irp(:) = 0 + !$OMP END WORKSHARE + + !$OMP DO schedule(STATIC) & + !$OMP private(k,i) + do k=1,nza + i = itemp(k) + !$OMP ATOMIC UPDATE + a%irp(i) = a%irp(i) + 1 + !$OMP END ATOMIC + end do + !$OMP END DO + call psi_exscan(nr+1,a%irp,info,shift=ione) + !$OMP END PARALLEL +#else + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + call psi_exscan(nr+1,a%irp,info,shift=ione) +#endif -!!$ if (use_openmp) then -!!$ !$OMP PARALLEL default(none) & -!!$ !$OMP shared(sum,nthreads,nr,a,itemp,nza) & -!!$ !$OMP private(ithread,work,first_idx,last_idx,s,saved_elem,nxt_val,old_val) -!!$ -!!$ !$OMP DO schedule(STATIC) & -!!$ !$OMP private(k,i) -!!$ do k=1,nza -!!$ i = itemp(k) -!!$ a%irp(i) = a%irp(i) + 1 -!!$ end do -!!$ !$OMP END DO -!!$ -!!$ !$OMP SINGLE -!!$ !$ nthreads = omp_get_num_threads() -!!$ !$ allocate(sum(nthreads+1)) -!!$ !$ sum(:) = 0 -!!$ !$ sum(1) = 1 -!!$ !$OMP END SINGLE -!!$ -!!$ !$ ithread = omp_get_thread_num() -!!$ -!!$ !$ work = nr/nthreads -!!$ !$ if (ithread < MOD(nr,nthreads)) then -!!$ !$ work = work + 1 -!!$ !$ first_idx = ithread*work + 1 -!!$ !$ else -!!$ !$ first_idx = ithread*work + MOD(nr,nthreads) + 1 -!!$ !$ end if -!!$ -!!$ !$ last_idx = first_idx + work - 1 -!!$ -!!$ !$ s = 0 -!!$ !$ do i=first_idx,last_idx -!!$ !$ s = s + a%irp(i) -!!$ !$ end do -!!$ !$ if (work > 0) then -!!$ !$ sum(ithread+2) = s -!!$ !$ end if -!!$ -!!$ !$OMP BARRIER -!!$ -!!$ !$OMP SINGLE -!!$ !$ do i=2,nthreads+1 -!!$ !$ sum(i) = sum(i) + sum(i-1) -!!$ !$ end do -!!$ !$OMP END SINGLE -!!$ -!!$ !$ if (work > 0) then -!!$ !$ saved_elem = a%irp(first_idx) -!!$ !$ end if -!!$ !$ if (ithread == 0) then -!!$ !$ a%irp(1) = 1 -!!$ !$ end if -!!$ -!!$ !$ if (work > 0) then -!!$ !$ old_val = a%irp(first_idx+1) -!!$ !$ a%irp(first_idx+1) = saved_elem + sum(ithread+1) -!!$ !$ end if -!!$ -!!$ !$ do i=first_idx+2,last_idx+1 -!!$ !$ nxt_val = a%irp(i) -!!$ !$ a%irp(i) = a%irp(i-1) + old_val -!!$ !$ old_val = nxt_val -!!$ !$ end do -!!$ -!!$ !$OMP END PARALLEL -!!$ else - do k=1,nza - i = itemp(k) - a%irp(i) = a%irp(i) + 1 - end do - ip = 1 - do i=1,nr - ncl = a%irp(i) - a%irp(i) = ip - ip = ip + ncl - end do - a%irp(nr+1) = ip -!!$ end if - call a%set_host() end subroutine psb_c_mv_csr_from_coo @@ -3300,9 +3490,28 @@ subroutine psb_c_cp_csr_to_fmt(a,b,info) b%psb_c_base_sparse_mat = a%psb_c_base_sparse_mat nr = a%get_nrows() nz = a%get_nzeros() - if (info == 0) call psb_safe_cpy( a%irp(1:nr+1), b%irp , info) - if (info == 0) call psb_safe_cpy( a%ja(1:nz), b%ja , info) - if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + if (.false.) then + if (info == 0) call psb_safe_cpy( a%irp(1:nr+1), b%irp , info) + if (info == 0) call psb_safe_cpy( a%ja(1:nz), b%ja , info) + if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + else + ! Despite the implementation in safe_cpy, it seems better this way + call psb_realloc(nr+1,b%irp,info) + call psb_realloc(nz,b%ja,info) + call psb_realloc(nz,b%val,info) + !$omp parallel do private(i) schedule(static) + do i=1,nr+1 + b%irp(i)=a%irp(i) + end do + !$omp end parallel do + !$omp parallel do private(j) schedule(static) + do j=1,nz + b%ja(j) = a%ja(j) + b%val(j) = a%val(j) + end do + !$omp end parallel do + end if + call b%set_host() class default @@ -3386,9 +3595,27 @@ subroutine psb_c_cp_csr_from_fmt(a,b,info) a%psb_c_base_sparse_mat = b%psb_c_base_sparse_mat nr = b%get_nrows() nz = b%get_nzeros() - if (info == 0) call psb_safe_cpy( b%irp(1:nr+1), a%irp , info) - if (info == 0) call psb_safe_cpy( b%ja(1:nz) , a%ja , info) - if (info == 0) call psb_safe_cpy( b%val(1:nz) , a%val , info) + if (.false.) then + if (info == 0) call psb_safe_cpy( b%irp(1:nr+1), a%irp , info) + if (info == 0) call psb_safe_cpy( b%ja(1:nz) , a%ja , info) + if (info == 0) call psb_safe_cpy( b%val(1:nz) , a%val , info) + else + ! Despite the implementation in safe_cpy, it seems better this way + call psb_realloc(nr+1,a%irp,info) + call psb_realloc(nz,a%ja,info) + call psb_realloc(nz,a%val,info) + !$omp parallel do private(i) schedule(static) + do i=1,nr+1 + a%irp(i)=b%irp(i) + end do + !$omp end parallel do + !$omp parallel do private(j) schedule(static) + do j=1,nz + a%ja(j)=b%ja(j) + a%val(j)=b%val(j) + end do + !$omp end parallel do + end if call a%set_host() class default @@ -3427,6 +3654,540 @@ subroutine psb_c_csr_clean_zeros(a, info) call a%set_host() end subroutine psb_c_csr_clean_zeros +#if defined(OPENMP) +subroutine psb_ccsrspspmm(a,b,c,info) + use psb_c_mat_mod + use psb_serial_mod, psb_protect_name => psb_ccsrspspmm + + implicit none + + class(psb_c_csr_sparse_mat), intent(in) :: a,b + type(psb_c_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: ma,na,mb,nb, nzc, nza, nzb + character(len=20) :: name + integer(psb_ipk_) :: err_act + name='psb_csrspspmm' + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + if (b%is_dev()) call b%sync() + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb + info = psb_err_invalid_matrix_sizes_ + call psb_errpush(info,name) + goto 9999 + endif + + select case(spspmm_impl) + case (spspmm_serial) + ! Estimate number of nonzeros on output. + nza = a%get_nzeros() + nzb = b%get_nzeros() + nzc = 2*(nza+nzb) + call c%allocate(ma,nb,nzc) + + call csr_spspmm(a,b,c,info) + case (spspmm_omp_gustavson) + call spmm_omp_gustavson(a,b,c,info) + case (spspmm_omp_gustavson_1d) + call spmm_omp_gustavson_1d(a,b,c,info) + case (spspmm_serial_rb_tree) + call spmm_serial_rb_tree(a,b,c,info) + case (spspmm_omp_rb_tree) + call spmm_omp_rb_tree(a,b,c,info) + case (spspmm_omp_two_pass) + call spmm_omp_two_pass(a,b,c,info) + case default + write(psb_err_unit,*) 'Unknown spspmm implementation' + ! push error + goto 9999 + end select + + call c%set_asb() + call c%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csr_spspmm(a,b,c,info) + implicit none + type(psb_c_csr_sparse_mat), intent(in) :: a,b + type(psb_c_csr_sparse_mat), intent(inout) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: ma,na,mb,nb + integer(psb_ipk_), allocatable :: irow(:), idxs(:) + complex(psb_spk_), allocatable :: row(:) + integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, & + & nzc,nnzre, isz, ipb, irwsz, nrc, nze + complex(psb_spk_) :: cfb + + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = min(size(c%val),size(c%ja)) + isz = max(ma,na,mb,nb) + call psb_realloc(isz,row,info) + if (info == 0) call psb_realloc(isz,idxs,info) + if (info == 0) call psb_realloc(isz,irow,info) + if (info /= 0) return + row = dzero + irow = 0 + nzc = 1 + do j = 1,ma + c%irp(j) = nzc + nrc = 0 + do k = a%irp(j), a%irp(j+1)-1 + irw = a%ja(k) + cfb = a%val(k) + irwsz = b%irp(irw+1)-b%irp(irw) + do i = b%irp(irw),b%irp(irw+1)-1 + icl = b%ja(i) + if (irow(icl) 0 ) then + if ((nzc+nrc)>nze) then + nze = max(ma*((nzc+j-1)/j),nzc+2*nrc) + call psb_realloc(nze,c%val,info) + if (info == 0) call psb_realloc(nze,c%ja,info) + if (info /= 0) return + end if + + call psb_qsort(idxs(1:nrc)) + do i=1, nrc + irw = idxs(i) + c%ja(nzc) = irw + c%val(nzc) = row(irw) + row(irw) = dzero + nzc = nzc + 1 + end do + end if + end do + + c%irp(ma+1) = nzc + end subroutine csr_spspmm + + ! gustavson's algorithm using perfect hashing + ! and OpenMP parallelisation + subroutine spmm_omp_gustavson(a,b,c,info) + use omp_lib + + implicit none + type(psb_c_csr_sparse_mat), intent(in) :: a,b + type(psb_c_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + complex(psb_spk_), allocatable :: vals(:), acc(:) + integer(psb_ipk_) :: ma, nb + integer(psb_ipk_), allocatable :: col_inds(:), offsets(:) + integer(psb_ipk_) :: irw, jj, j, k, nnz, rwnz, thread_upperbound, start_idx, end_idx + + ma = a%get_nrows() + nb = b%get_ncols() + + call c%allocate(ma, nb) + c%irp(1) = 1 + + ! dense accumulator + ! https://sc18.supercomputing.org/proceedings/workshops/workshop_files/ws_lasalss115s2-file1.pdf + call psb_realloc(nb, acc, info) + + allocate(offsets(omp_get_max_threads())) + !$omp parallel private(vals,col_inds,nnz,rwnz,thread_upperbound,acc,start_idx,end_idx) & + !$omp shared(a,b,c,offsets) + thread_upperbound = 0 + start_idx = 0 + !$omp do schedule(static) private(irw, jj, j) + do irw = 1, ma + if (start_idx == 0) then + start_idx = irw + end if + end_idx = irw + do jj = a%irp(irw), a%irp(irw + 1) - 1 + j = a%ja(jj) + thread_upperbound = thread_upperbound + b%irp(j+1) - b%irp(j) + end do + end do + !$omp end do + + call psb_realloc(thread_upperbound, vals, info) + call psb_realloc(thread_upperbound, col_inds, info) + + ! possible bottleneck + acc = 0 + + nnz = 0 + !$omp do schedule(static) private(irw, jj, j, k) + do irw = 1, ma + rwnz = 0 + do jj = a%irp(irw), a%irp(irw + 1) - 1 + j = a%ja(jj) + do k = b%irp(j), b%irp(j + 1) - 1 + if (acc(b%ja(k)) == 0) then + nnz = nnz + 1 + rwnz = rwnz + 1 + col_inds(nnz) = b%ja(k) + end if + acc(b%ja(k)) = acc(b%ja(k)) + a%val(jj) * b%val(k) + end do + end do + call psb_qsort(col_inds(nnz - rwnz + 1:nnz)) + + do k = nnz - rwnz + 1, nnz + vals(k) = acc(col_inds(k)) + acc(col_inds(k)) = 0 + end do + c%irp(irw + 1) = rwnz + end do + !$omp end do + + offsets(omp_get_thread_num() + 1) = nnz + !$omp barrier + + ! possible bottleneck + !$omp single + do k = 1, omp_get_num_threads() - 1 + offsets(k + 1) = offsets(k + 1) + offsets(k) + end do + !$omp end single + + !$omp barrier + + if (omp_get_thread_num() /= 0) then + c%irp(start_idx) = offsets(omp_get_thread_num()) + 1 + end if + + do irw = start_idx, end_idx - 1 + c%irp(irw + 1) = c%irp(irw + 1) + c%irp(irw) + end do + + !$omp barrier + + !$omp single + c%irp(ma + 1) = c%irp(ma + 1) + c%irp(ma) + call psb_realloc(c%irp(ma + 1), c%val, info) + call psb_realloc(c%irp(ma + 1), c%ja, info) + !$omp end single + + c%val(c%irp(start_idx):c%irp(end_idx + 1) - 1) = vals(1:nnz) + c%ja(c%irp(start_idx):c%irp(end_idx + 1) - 1) = col_inds(1:nnz) + !$omp end parallel + end subroutine spmm_omp_gustavson + + subroutine spmm_omp_gustavson_1d(a,b,c,info) + use omp_lib + + implicit none + type(psb_c_csr_sparse_mat), intent(in) :: a,b + type(psb_c_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + complex(psb_spk_), allocatable :: vals(:), acc(:) + integer(psb_ipk_) :: ma, nb + integer(psb_ipk_), allocatable :: col_inds(:), offsets(:) + integer(psb_ipk_) :: irw, jj, j, k, nnz, rwnz, thread_upperbound, & + start_idx, end_idx , blk, blk_size, rwstart,& + rwblk, rwblkrem, nblks + + ma = a%get_nrows() + nb = b%get_ncols() + + call c%allocate(ma, nb) + c%irp(1) = 1 + + ! dense accumulator + ! https://sc18.supercomputing.org/proceedings/workshops/workshop_files/ws_lasalss115s2-file1.pdf + call psb_realloc(nb, acc, info) + allocate(offsets(omp_get_max_threads())) + + nblks = 4 * omp_get_max_threads() + rwblk = (ma / nblks) + rwblkrem = modulo(ma, nblks) + !$omp parallel private(vals,col_inds,nnz,thread_upperbound,acc,start_idx,end_idx) shared(a,b,c,offsets) + thread_upperbound = 0 + start_idx = 0 + !$omp do schedule(static) private(irw, jj, j) + do irw = 1, ma + do jj = a%irp(irw), a%irp(irw + 1) - 1 + j = a%ja(jj) + thread_upperbound = thread_upperbound + b%irp(j+1) - b%irp(j) + end do + end do + !$omp end do + + call psb_realloc(thread_upperbound, vals, info) + call psb_realloc(thread_upperbound, col_inds, info) + + ! possible bottleneck + acc = 0 + + nnz = 0 + !$omp do schedule(static) private(irw,jj,j,k,rwnz,blk,blk_size,rwstart) + do blk = 0, nblks - 1 + if (blk < rwblkrem) then + blk_size = rwblk + 1 + rwstart = blk * rwblk + blk + 1 + else + blk_size = rwblk + rwstart = blk * rwblk & + + rwblkrem + 1 + end if + do irw = rwstart, rwstart + blk_size - 1 + if (start_idx == 0) then + start_idx = irw + end if + end_idx = irw + rwnz = 0 + do jj = a%irp(irw), a%irp(irw + 1) - 1 + j = a%ja(jj) + do k = b%irp(j), b%irp(j + 1) - 1 + if (acc(b%ja(k)) == 0) then + nnz = nnz + 1 + rwnz = rwnz + 1 + col_inds(nnz) = b%ja(k) + end if + acc(b%ja(k)) = acc(b%ja(k)) + a%val(jj) * b%val(k) + end do + end do + call psb_qsort(col_inds(nnz - rwnz + 1:nnz)) + + do k = nnz - rwnz + 1, nnz + vals(k) = acc(col_inds(k)) + acc(col_inds(k)) = 0 + end do + c%irp(irw + 1) = rwnz + end do + end do + !$omp end do + + offsets(omp_get_thread_num() + 1) = nnz + !$omp barrier + + ! possible bottleneck + !$omp single + do k = 1, omp_get_num_threads() - 1 + offsets(k + 1) = offsets(k + 1) + offsets(k) + end do + !$omp end single + + !$omp barrier + + if (omp_get_thread_num() /= 0) then + c%irp(start_idx) = offsets(omp_get_thread_num()) + 1 + end if + + do irw = start_idx, end_idx - 1 + c%irp(irw + 1) = c%irp(irw + 1) + c%irp(irw) + end do + + !$omp barrier + + !$omp single + c%irp(ma + 1) = c%irp(ma + 1) + c%irp(ma) + call psb_realloc(c%irp(ma + 1), c%val, info) + call psb_realloc(c%irp(ma + 1), c%ja, info) + !$omp end single + + c%val(c%irp(start_idx):c%irp(end_idx + 1) - 1) = vals(1:nnz) + c%ja(c%irp(start_idx):c%irp(end_idx + 1) - 1) = col_inds(1:nnz) + !$omp end parallel + end subroutine spmm_omp_gustavson_1d + + subroutine spmm_serial_rb_tree(a,b,c,info) + use psb_rb_idx_tree_mod + implicit none + type(psb_c_csr_sparse_mat), intent(in) :: a,b + type(psb_c_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: a_m, b_n + integer(psb_ipk_) :: row, col + type(psb_c_rb_idx_tree), allocatable :: row_accs(:) + + a_m = a%get_nrows() + b_n = b%get_ncols() + + allocate(row_accs(a_m)) + call c%allocate(a_m, b_n) + + do row = 1, a_m + row_accs(row)%nnz = 0 + nullify(row_accs(row)%root) + do col = a%irp(row), a%irp(row + 1) - 1 + call psb_rb_idx_tree_scalar_sparse_row_mul(row_accs(row), a%val(col), b, a%ja(col)) + end do + end do + call psb_rb_idx_tree_merge(row_accs, c) + + deallocate(row_accs) + + info = 0 + end subroutine spmm_serial_rb_tree + + subroutine spmm_omp_rb_tree(a,b,c,info) + use omp_lib + use psb_rb_idx_tree_mod + implicit none + type(psb_c_csr_sparse_mat), intent(in) :: a,b + type(psb_c_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: a_m, b_n + integer(psb_ipk_) :: row, col + type(psb_c_rb_idx_tree), allocatable :: row_accs(:) + real(8) :: tic, toc + + a_m = a%get_nrows() + b_n = b%get_ncols() + + call c%allocate(a_m, b_n) + + allocate(row_accs(a_m)) + call c%allocate(a_m, b_n) + + !$omp parallel do schedule(static) + do row = 1, a_m + row_accs(row)%nnz = 0 + nullify(row_accs(row)%root) + do col = a%irp(row), a%irp(row + 1) - 1 + call psb_rb_idx_tree_scalar_sparse_row_mul(row_accs(row), a%val(col), b, a%ja(col)) + end do + end do + !$omp end parallel do + + call psb_rb_idx_tree_merge(row_accs, c) + + deallocate(row_accs) + info = 0 + end subroutine spmm_omp_rb_tree + + subroutine compute_indices(a, b, c, info) + implicit none + type(psb_c_csr_sparse_mat), intent(in) :: a,b + type(psb_c_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + integer :: full_mat_bound + integer :: row, col, i, j, k, nnz + + full_mat_bound = 0 + !omp parallel do schedule(static) reduction(+:full_mat_bound) + do row = 1, a%get_nrows() + do col = a%irp(row), a%irp(row + 1) - 1 + j = a%ja(col) + full_mat_bound = full_mat_bound + b%irp(j+1) - b%irp(j) + end do + end do + !omp end parallel do + + call psb_realloc(a%get_nrows() + 1, c%irp, info) + call psb_realloc(full_mat_bound, c%ja, info) + c%ja = 0 + c%irp(1) = 1 + + nnz = 0 + + do row = 1, a%get_nrows() + do col = a%irp(row), a%irp(row + 1) - 1 + do i = b%irp(a%ja(col)), b%irp(a%ja(col) + 1) - 1 + k = 0 + do while(c%ja(c%irp(row) + k) /= 0 .and. c%ja(c%irp(row) + k) /= b%ja(i)) + k = k + 1 + end do + if (c%ja(c%irp(row) + k) == 0) then + c%ja(c%irp(row)+k) = b%ja(i) + nnz = nnz + 1 + end if + end do + end do + c%irp(row + 1) = nnz + 1 + call psb_qsort(c%ja(c%irp(row):c%irp(row + 1)-1)) + end do + + + call psb_realloc(nnz, c%ja, info) + call psb_realloc(nnz, c%val, info) + + c%val = 0 + end subroutine compute_indices + + subroutine direct_scalar_sparse_row_mul(out_mat, out_row_num, scalar, mat, trgt_row_num) + type(psb_c_csr_sparse_mat), intent(inout) :: out_mat + integer(psb_ipk_), intent(in) :: out_row_num + complex(psb_spk_), intent(in) :: scalar + type(psb_c_csr_sparse_mat), intent(in) :: mat + integer(psb_ipk_), intent(in) :: trgt_row_num + + integer(psb_ipk_) :: i, k, row_start, row_end + + row_start = out_mat%irp(out_row_num) + row_end = out_mat%irp(out_row_num + 1) - 1 + + do i = mat%irp(trgt_row_num), mat%irp(trgt_row_num + 1) - 1 + do k = out_mat%irp(out_row_num), out_mat%irp(out_row_num + 1) - 1 + if (out_mat%ja(k) == mat%ja(i)) then + out_mat%val(k) = out_mat%val(k) + scalar * mat%val(i) + exit + end if + end do + end do + + end subroutine direct_scalar_sparse_row_mul + + subroutine spmm_omp_two_pass(a,b,c,info) + use omp_lib + + implicit none + type(psb_c_csr_sparse_mat), intent(in) :: a,b + type(psb_c_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: a_m, b_n, row, col + + a_m = a%get_nrows() + b_n = b%get_ncols() + + call c%allocate(a_m, b_n) + + call compute_indices(a, b, c, info) + + !$omp parallel do schedule(static) + do row = 1, a_m + do col = a%irp(row), a%irp(row + 1) - 1 + call direct_scalar_sparse_row_mul(c, row, a%val(col), b, a%ja(col)) + end do + end do + !$omp end parallel do + end subroutine spmm_omp_two_pass + +end subroutine psb_ccsrspspmm + +#else + subroutine psb_ccsrspspmm(a,b,c,info) use psb_c_mat_mod use psb_serial_mod, psb_protect_name => psb_ccsrspspmm @@ -3810,7 +4571,6 @@ subroutine psb_c_cp_ecsr_from_fmt(a,b,info) end subroutine psb_c_cp_ecsr_from_fmt - ! ! ! lc version diff --git a/base/serial/impl/psb_c_rb_idx_tree_impl.F90 b/base/serial/impl/psb_c_rb_idx_tree_impl.F90 new file mode 100644 index 000000000..42704c6ef --- /dev/null +++ b/base/serial/impl/psb_c_rb_idx_tree_impl.F90 @@ -0,0 +1,329 @@ +! +! 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. +! +! +! +! package: psb_c_rb_idx_tree_impl +! +! Red black tree implementation ordered by index +! +! Each node contains and index and a double precision value +! +! The tree should always be well balanced +! +! inserting a node with an existing index will +! add up the new value to the old one +! Contributed by Dimitri Walther +! +subroutine psb_c_rb_idx_tree_insert(this, idx, val) + use psb_c_rb_idx_tree_mod, psb_protect_name => psb_c_rb_idx_tree_insert + implicit none + class(psb_c_rb_idx_tree), intent(inout) :: this + integer(psb_ipk_), intent(in) :: idx + complex(psb_spk_), intent(in) :: val + + character(len=22) :: name + type(psb_c_rb_idx_node), pointer :: new_node + type(psb_c_rb_idx_node), pointer :: current, previous + name='psb_rb_idx_tree_insert' + + allocate(new_node) + new_node%idx = idx + new_node%val = val + nullify(new_node%left) + nullify(new_node%right) + nullify(new_node%parent) + new_node%is_red = .true. + + + if (.not. associated(this%root)) then + this%root => new_node + this%nnz = 1 + new_node%is_red = .false. + return + end if + + current => this%root + + do while (associated(current)) + previous => current + + if (idx == current%idx) then + current%val = current%val + val + deallocate(new_node) + return + else if (idx < current%idx) then + current => current%left + else + + current => current%right + end if + end do + + if (idx < previous%idx) then + new_node%parent => previous + previous%left => new_node + else + new_node%parent => previous + previous%right => new_node + end if + + call psb_c_rb_idx_tree_fix_insertion(this, new_node) + + this%nnz = this%nnz + 1 +end subroutine psb_c_rb_idx_tree_insert + +subroutine psb_c_rb_idx_tree_fix_insertion(this, node) + use psb_c_rb_idx_tree_mod, psb_protect_name => psb_c_rb_idx_tree_fix_insertion + implicit none + class(psb_c_rb_idx_tree), intent(inout) :: this + type(psb_c_rb_idx_node), pointer, intent(inout) :: node + + character(len=29) :: name + type(psb_c_rb_idx_node), pointer :: current, parent, grand_parent, uncle + name = 'psb_rb_idx_tree_fix_insertion' + + current => node + parent => current%parent + do while(associated(parent) .and. parent%is_red) + ! grand parent exist because root can't be red + grand_parent => parent%parent + if (parent%idx < grand_parent%idx) then + uncle => grand_parent%right + else + uncle => grand_parent%left + end if + + if (associated(uncle) .and. uncle%is_red) then + parent%is_red = .false. + uncle%is_red = .false. + grand_parent%is_red = .true. + current => grand_parent + parent => current%parent + + ! Left-Left case + else if (current%idx < parent%idx .and. & + parent%idx < grand_parent%idx) then + call psb_c_rb_idx_tree_rotate_right(grand_parent) + call psb_c_rb_idx_tree_swap_colors(parent, grand_parent) + + if (this%root%idx == grand_parent%idx) this%root => parent + + return + ! Left-Right case + else if (current%idx > parent%idx .and. & + parent%idx < grand_parent%idx) then + call psb_c_rb_idx_tree_rotate_left(parent) + call psb_c_rb_idx_tree_rotate_right(grand_parent) + call psb_c_rb_idx_tree_swap_colors(current, grand_parent) + + if (this%root%idx == grand_parent%idx) this%root => current + + return + ! Right-Right case + else if (current%idx > parent%idx .and. & + parent%idx > grand_parent%idx) then + call psb_c_rb_idx_tree_rotate_left(grand_parent) + call psb_c_rb_idx_tree_swap_colors(parent, grand_parent) + + if (this%root%idx == grand_parent%idx) this%root => parent + + return + ! Right-Left case + else + call psb_c_rb_idx_tree_rotate_right(parent) + call psb_c_rb_idx_tree_rotate_left(grand_parent) + call psb_c_rb_idx_tree_swap_colors(current, grand_parent) + + if (this%root%idx == grand_parent%idx) this%root => current + + return + end if + end do + + this%root%is_red = .false. +end subroutine psb_c_rb_idx_tree_fix_insertion + +subroutine psb_c_rb_idx_tree_swap_colors(n1, n2) + use psb_c_rb_idx_tree_mod, psb_protect_name => psb_c_rb_idx_tree_swap_colors + implicit none + type(psb_c_rb_idx_node), pointer, intent(inout) :: n1, n2 + + character(len=27) :: name + logical :: tmp + name='psb_rb_idx_tree_swap_colors' + + tmp = n1%is_red + n1%is_red = n2%is_red + n2%is_red = tmp +end subroutine psb_c_rb_idx_tree_swap_colors + +subroutine psb_c_rb_idx_tree_rotate_right(node) + use psb_c_rb_idx_tree_mod, psb_protect_name => psb_c_rb_idx_tree_rotate_right + implicit none + type(psb_c_rb_idx_node), pointer, intent(inout) :: node + + character(len=28) :: name + type(psb_c_rb_idx_node), pointer :: l, lr + name='psb_rb_idx_tree_rotate_right' + + if (.not. associated(node%left)) return + + l => node%left + lr => l%right + node%left => lr + + if (associated(lr)) lr%parent => node + + if (associated(node%parent)) then + if (node%idx < node%parent%idx) then + node%parent%left => l + else + node%parent%right => l + end if + end if + + l%parent => node%parent + node%parent => l + + l%right => node +end subroutine psb_c_rb_idx_tree_rotate_right + +subroutine psb_c_rb_idx_tree_rotate_left(node) + use psb_c_rb_idx_tree_mod, psb_protect_name => psb_c_rb_idx_tree_rotate_left + implicit none + type(psb_c_rb_idx_node), pointer, intent(inout) :: node + + character(len=27) :: name + type(psb_c_rb_idx_node), pointer :: r, rl + name='psb_rb_idx_tree_rotate_left' + + if (.not. associated(node%right)) return + + r => node%right + rl => r%left + node%right => rl + + if (associated(rl)) rl%parent => node + + if (associated(node%parent)) then + if (node%idx < node%parent%idx) then + node%parent%left => r + else + node%parent%right => r + end if + end if + + r%parent => node%parent + node%parent => r + + r%left => node +end subroutine psb_c_rb_idx_tree_rotate_left + +subroutine psb_c_rb_idx_tree_scalar_sparse_row_mul(tree, scalar, mat, row_num) + use psb_c_rb_idx_tree_mod, psb_protect_name => psb_c_rb_idx_tree_scalar_sparse_row_mul + use psb_c_csr_mat_mod, only : psb_c_csr_sparse_mat + implicit none + type(psb_c_rb_idx_tree), intent(inout) :: tree + complex(psb_spk_), intent(in) :: scalar + type(psb_c_csr_sparse_mat), intent(in) :: mat + integer(psb_ipk_), intent(in) :: row_num + + character(len=37) :: name + integer(psb_ipk_) :: i + name='psb_rb_idx_tree_scalar_sparse_row_mul' + + do i = mat%irp(row_num), mat%irp(row_num + 1) - 1 + call tree%insert(mat%ja(i),scalar * mat%val(i)) + end do + +end subroutine psb_c_rb_idx_tree_scalar_sparse_row_mul + +subroutine psb_c_rb_idx_tree_merge(trees, mat) +#if defined(OPENMP) + use omp_lib +#endif + use psb_realloc_mod + use psb_c_rb_idx_tree_mod, psb_protect_name => psb_c_rb_idx_tree_merge + use psb_c_csr_mat_mod, only : psb_c_csr_sparse_mat + implicit none + type(psb_c_rb_idx_tree), allocatable, intent(inout) :: trees(:) + type(psb_c_csr_sparse_mat), intent(inout) :: mat + + character(len=21) :: name + integer(psb_ipk_) :: i, j, rows, info, nnz + type(psb_c_rb_idx_node), pointer :: current, previous + name='psb_rb_idx_tree_merge' + + rows = size(trees) + + mat%irp(1) = 1 + + do i=1, rows + mat%irp(i + 1) = mat%irp(i) + trees(i)%nnz + end do + + nnz = mat%irp(rows + 1) + call psb_realloc(nnz, mat%val, info) + call psb_realloc(nnz, mat%ja, info) + +#if defined(OPENMP) + !$omp parallel do schedule(static), private(current, previous, j) +#endif + do i = 1, size(trees) + j = 0 + current => trees(i)%root + do while(associated(current)) + ! go to the left-most node + do while(associated(current%left)) + current => current%left + end do + mat%val(j + mat%irp(i)) = current%val + mat%ja(j + mat%irp(i)) = current%idx + j = j + 1 + + previous => current + if (associated(current%right)) then + if (associated(current%parent)) then + current%parent%left => current%right + end if + current%right%parent => current%parent + current => current%right + else + current => current%parent + if (associated(current)) nullify(current%left) + end if + deallocate(previous) + end do + end do +#if defined(OPENMP) + !$omp end parallel do +#endif +end subroutine psb_c_rb_idx_tree_merge diff --git a/base/serial/impl/psb_d_coo_impl.F90 b/base/serial/impl/psb_d_coo_impl.F90 index f326e46fa..c2babf8e0 100644 --- a/base/serial/impl/psb_d_coo_impl.F90 +++ b/base/serial/impl/psb_d_coo_impl.F90 @@ -2817,6 +2817,9 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_realloc_mod use psb_sort_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csput_a +#if defined(OPENMP) + use omp_lib +#endif implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a @@ -2828,7 +2831,7 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) integer(psb_ipk_) :: err_act character(len=20) :: name='d_coo_csput_a_impl' logical, parameter :: debug=.false. - integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit + integer(psb_ipk_) :: nza, i,j,k, nzl, isza, nzaold, debug_level, debug_unit info = psb_success_ debug_unit = psb_get_debug_unit() @@ -2860,10 +2863,13 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) if (nz == 0) return - - nza = a%get_nzeros() - isza = a%get_size() if (a%is_bld()) then + ! Structure here is peculiar, because this function can be called + ! either within a parallel region, or outside. + ! Hence the call to set_nzeros done here. + !$omp critical + nza = a%get_nzeros() + isza = a%get_size() ! Build phase. Must handle reallocations in a sensible way. if (isza < (nza+nz)) then call a%reallocate(max(nza+nz,int(1.5*isza))) @@ -2871,16 +2877,20 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) isza = a%get_size() if (isza < (nza+nz)) then info = psb_err_alloc_dealloc_; call psb_errpush(info,name) - goto 9999 + else + nzaold = nza + nza = nza + nz + call a%set_nzeros(nza) end if - - call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& + !$omp end critical + if (info /= 0) goto 9999 + call psb_inner_ins(nz,ia,ja,val,nzaold,a%ia,a%ja,a%val,isza,& & imin,imax,jmin,jmax,info) - call a%set_nzeros(nza) call a%set_sorted(.false.) - - + else if (a%is_upd()) then + nza = a%get_nzeros() + isza = a%get_size() if (a%is_dev()) call a%sync() @@ -2949,7 +2959,6 @@ contains end if end do !$OMP END PARALLEL DO - nza = nza + nz #else do i=1, nz @@ -3478,6 +3487,602 @@ subroutine psb_d_coo_mv_from(a,b) end subroutine psb_d_coo_mv_from +! +! COO implementation of tril/triu +! +subroutine psb_d_coo_tril(a,l,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,u) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_tril + implicit none + + class(psb_d_coo_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_d_coo_sparse_mat), optional, intent(out) :: u + + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k + integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + character(len=20) :: name='tril' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + +#if defined(OPENMP) + block + integer(psb_ipk_), allocatable :: lrws(:),urws(:) + integer(psb_ipk_) :: lpnt, upnt, lnz, unz + call psb_realloc(mb,lrws,info) + !$omp workshare + lrws(:) = 0 + !$omp end workshare + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + !write(0,*) 'Invocation of COO%TRIL', present(u),nz + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + if (info == 0) call psb_realloc(mb,urws,info) + !$omp workshare + urws(:) = 0 + !$omp end workshare + !write(0,*) 'omp version of COO%TRIL/TRIU' + lnz = 0 + unz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws,urws) reduction(+: lnz,unz) + loop1: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic update + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + !$omp end atomic + lnz = lnz + 1 + else + !$omp atomic update + urws(i-imin_+1) = urws(i-imin_+1) +1 + !$omp end atomic + unz = unz + 1 + end if + end if + end do loop1 + !$omp end parallel do + + call psi_exscan(mb,lrws,info) + call psi_exscan(mb,urws,info) + !write(0,*) lrws(:), urws(:) + !$omp parallel do private(i,j,k,lpnt,upnt) shared(imin_,imax_,a) + loop2: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic capture + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + lpnt = lrws(i-imin_+1) + !$omp end atomic + l%ia(lpnt) = a%ia(k) + l%ja(lpnt) = a%ja(k) + l%val(lpnt) = a%val(k) + else + !$omp atomic capture + urws(i-imin_+1) = urws(i-imin_+1) +1 + upnt = urws(i-imin_+1) + !$omp end atomic + u%ia(upnt) = a%ia(k) + u%ja(upnt) = a%ja(k) + u%val(upnt) = a%val(k) + end if + end if + end do loop2 + !$omp end parallel do + !write(0,*) 'End of copyout',lnz,unz + call l%set_nzeros(lnz) + call l%fix(info) + call u%set_nzeros(unz) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) then + !$omp workshare + u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + if ((diag_ >=-1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + lnz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws) reduction(+: lnz) + loop3: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic update + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + !$omp end atomic + lnz = lnz + 1 + end if + end if + end do loop3 + !$omp end parallel do + call psi_exscan(mb,lrws,info) + !$omp parallel do private(i,j,k,lpnt) shared(imin_,imax_,a) + loop4: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic capture + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + lpnt = lrws(i-imin_+1) + !$omp end atomic + l%ia(lpnt) = a%ia(k) + l%ja(lpnt) = a%ja(k) + l%val(lpnt) = a%val(k) + end if + end if + end do loop4 + !$omp end parallel do + call l%set_nzeros(lnz) + call l%fix(info) + end if + nzout = l%get_nzeros() + if (rscale_) then + !$omp workshare + l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if + end block + +#else + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, ia=>a%ia) + loop1: do k=1,nz + i = ia(k) + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + nzlin = nzlin + 1 + l%ia(nzlin) = i + l%ja(nzlin) = ja(k) + l%val(nzlin) = val(k) + else + nzuin = nzuin + 1 + u%ia(nzuin) = i + u%ja(nzuin) = ja(k) + u%val(nzuin) = val(k) + end if + end if + end do loop1 + end associate + + call l%set_nzeros(nzlin) + call u%set_nzeros(nzuin) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >=-1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + nzin = l%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, ia=>a%ia) + loop2: do k=1,nz + i = ia(k) + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + nzin = nzin + 1 + l%ia(nzin) = i + l%ja(nzin) = ja(k) + l%val(nzin) = val(k) + end if + end if + end do loop2 + end associate + call l%set_nzeros(nzin) + end if + call l%fix(info) + nzout = l%get_nzeros() + if (rscale_) & + & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if +#endif + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_coo_tril + +subroutine psb_d_coo_triu(a,u,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,l) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_triu + implicit none + + class(psb_d_coo_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_d_coo_sparse_mat), optional, intent(out) :: l + + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k + integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + character(len=20) :: name='triu' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + +#if defined(OPENMP) + block + integer(psb_ipk_), allocatable :: lrws(:),urws(:) + integer(psb_ipk_) :: lpnt, upnt, lnz, unz + call psb_realloc(mb,urws,info) + !$omp workshare + urws(:) = 0 + !$omp end workshare + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + !write(0,*) 'Invocation of COO%TRIL', present(u),nz + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + if (info == 0) call psb_realloc(mb,urws,info) + !$omp workshare + lrws(:) = 0 + !$omp end workshare + !write(0,*) 'omp version of COO%TRIL/TRIU' + lnz = 0 + unz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws,urws) reduction(+: lnz,unz) + loop1: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)>=diag_) then + !$omp atomic update + urws(i-imin_+1) = urws(i-imin_+1) +1 + !$omp end atomic + unz = unz + 1 + end if + end if + end do loop3 + !$omp end parallel do + call psi_exscan(mb,urws,info) + !$omp parallel do private(i,j,k,upnt) shared(imin_,imax_,a) + loop4: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)>=diag_) then + !$omp atomic capture + urws(i-imin_+1) = urws(i-imin_+1) +1 + upnt = urws(i-imin_+1) + !$omp end atomic + u%ia(upnt) = a%ia(k) + u%ja(upnt) = a%ja(k) + u%val(upnt) = a%val(k) + end if + end if + end do loop4 + !$omp end parallel do + call u%set_nzeros(unz) + call u%fix(info) + end if + nzout = u%get_nzeros() + if (rscale_) then + !$omp workshare + u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + + if ((diag_ >= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_upper(.true.) + end if + end block + + +#else + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, ia=>a%ia) + loop1: do k=1,nz + i = ia(k) + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)a%val, ja => a%ja, ia=>a%ia) + loop2: do k=1,nz + i = ia(k) + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)>=diag_) then + nzin = nzin + 1 + u%ia(nzin) = i + u%ja(nzin) = ja(k) + u%val(nzin) = val(k) + end if + end if + end do loop2 + end associate + call u%set_nzeros(nzin) + end if + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + + if ((diag_ >= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if +#endif + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_coo_triu + subroutine psb_d_fix_coo(a,info,idir) use psb_const_mod @@ -3561,7 +4166,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) character(len=20) :: name = 'psb_fixcoo' logical :: srt_inp, use_buffers #if defined(OPENMP) - integer(psb_ipk_) :: work,first_idx,last_idx,first_elem,last_elem,s,nthreads,ithread + integer(psb_ipk_) :: work,idxstart,idxend,first_elem,last_elem,s,nthreads,ithread integer(psb_ipk_) :: saved_elem,old_val,nxt_val,err,act_row,act_col,maxthreads integer(psb_ipk_), allocatable :: sum(:),kaux(:),idxaux(:) #endif @@ -3620,8 +4225,6 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ! Dirty trick: call ROWMAJOR with rows <-> columns call psb_d_fix_coo_inner_rowmajor(nc,nr,nzin,dupl,& & ja,ia,val,iaux,nzout,info) -!!$ call psb_d_fix_coo_inner_colmajor(nr,nc,nzin,dupl,& -!!$ & ia,ja,val,iaux,nzout,info) case default write(debug_unit,*) trim(name),': unknown direction ',idir_ info = psb_err_internal_error_ @@ -3660,12 +4263,13 @@ subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf integer(psb_ipk_), allocatable :: ias(:),jas(:), ix2(:) real(psb_dpk_), allocatable :: vs(:) integer(psb_ipk_) :: nza, nzl,iret - integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii + integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii, i1, i2 integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name = 'psb_fixcoo' logical :: srt_inp, use_buffers + real(psb_dpk_) :: t0, t1 #if defined(OPENMP) - integer(psb_ipk_) :: work,first_idx,last_idx,first_elem,last_elem,s,nthreads,ithread + integer(psb_ipk_) :: work,idxstart,idxend,first_elem,last_elem,s,nthreads,ithread integer(psb_ipk_) :: saved_elem,old_val,nxt_val,err,act_row,act_col,maxthreads integer(psb_ipk_), allocatable :: sum(:),kaux(:),idxaux(:) #endif @@ -3747,9 +4351,9 @@ subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf ! Here, starting from 'iaux', we apply a fixing in order to obtain the starting ! index for each row. We do the same on 'kaux' !$OMP PARALLEL default(none) & - !$OMP shared(idxaux,ia,ja,val,ias,jas,vs,nthreads,sum,nr,nc,nzin,iaux,kaux,dupl,err) & - !$OMP private(s,i,j,k,ithread,first_idx,last_idx,work,nxt_val,old_val,saved_elem, & - !$OMP first_elem,last_elem,nzl,iret,act_row) + !$OMP shared(t0,t1,idxaux,ia,ja,val,ias,jas,vs,nthreads,sum,nr,nc,nzin,iaux,kaux,dupl,err) & + !$OMP private(s,i,j,k,ithread,idxstart,idxend,work,nxt_val,old_val,saved_elem, & + !$OMP first_elem,last_elem,nzl,iret,act_row,i1,i2) reduction(max: info) !$OMP SINGLE nthreads = omp_get_num_threads() @@ -3762,81 +4366,46 @@ subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf work = nr/nthreads if (ithread < MOD(nr,nthreads)) then work = work + 1 - first_idx = ithread*work + 1 + idxstart = ithread*work + 1 else - first_idx = ithread*work + MOD(nr,nthreads) + 1 + idxstart = ithread*work + MOD(nr,nthreads) + 1 end if - last_idx = first_idx + work - 1 - - !------------------------------------------- - ! ------------ iaux composition -------------- - ! 'iaux' will have the start index for each row - - s = 0 - do i=first_idx,last_idx - s = s + iaux(i) - end do - sum(ithread+2) = s + idxend = idxstart + work - 1 + !write(0,*) 'fix_coo_inner: trying with exscan' + call psi_exscan(nr+1,iaux,info,shift=ione) !$OMP BARRIER - !$OMP SINGLE - do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) - end do + !t0 = omp_get_wtime() !$OMP END SINGLE - - if (work > 0) then - saved_elem = iaux(first_idx) - end if - - if (ithread == 0) then - iaux(1) = 1 - end if - - !$OMP BARRIER - - if (work > 0) then - old_val = iaux(first_idx+1) - iaux(first_idx+1) = saved_elem + sum(ithread+1) - end if - - do i=first_idx+2,last_idx+1 - nxt_val = iaux(i) - iaux(i) = iaux(i-1) + old_val - old_val = nxt_val - end do - - ! -------------------------------------- - - !$OMP BARRIER - + ! ------------------ Sorting and buffers ------------------- ! Let's use an auxiliary buffer, 'idxaux', to get indices leaving ! unmodified 'iaux' - do j=first_idx,last_idx + do j=idxstart,idxend idxaux(j) = iaux(j) end do - ! Here we sort data inside the auxiliary buffers do i=1,nzin act_row = ia(i) - if ((act_row >= first_idx) .and. (act_row <= last_idx)) then + if ((act_row >= idxstart) .and. (act_row <= idxend)) then ias(idxaux(act_row)) = ia(i) jas(idxaux(act_row)) = ja(i) vs(idxaux(act_row)) = val(i) - idxaux(act_row) = idxaux(act_row) + 1 end if end do !$OMP BARRIER - + !$OMP SINGLE + !t1 = omp_get_wtime() + !write(0,*) ithread,'Srt&Cpy :',t1-t0 + !$OMP END SINGLE ! Let's sort column indices and values. After that we will store ! the number of unique values in 'kaux' - do j=first_idx,last_idx + do j=idxstart,idxend first_elem = iaux(j) last_elem = iaux(j+1) - 1 nzl = last_elem - first_elem + 1 @@ -3865,45 +4434,7 @@ subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf ! -------------------------------------------------- ! ---------------- kaux composition ---------------- - !$OMP SINGLE - sum(:) = 0 - sum(1) = 1 - !$OMP END SINGLE - - s = 0 - do i=first_idx,last_idx - s = s + kaux(i) - end do - sum(ithread+2) = s - - !$OMP BARRIER - - !$OMP SINGLE - do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) - end do - kaux(nr+1) = sum(nthreads+1) - !$OMP END SINGLE - - if (work > 0) then - saved_elem = kaux(first_idx) - end if - if (ithread == 0) then - kaux(1) = 1 - end if - - !$OMP BARRIER - - if (work > 0) then - old_val = kaux(first_idx+1) - kaux(first_idx+1) = saved_elem + sum(ithread+1) - end if - - do i=first_idx+2,last_idx+1 - nxt_val = kaux(i) - kaux(i) = kaux(i-1) + old_val - old_val = nxt_val - end do + call psi_exscan(nr+1,kaux,i,shift=ione) !$OMP BARRIER @@ -3911,7 +4442,7 @@ subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf select case(dupl) case(psb_dupl_ovwrt_) - !$OMP DO schedule(STATIC) + !$OMP DO schedule(dynamic,32) do j=1,nr first_elem = iaux(j) last_elem = iaux(j+1) - 1 @@ -3940,7 +4471,7 @@ subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf !$OMP END DO case(psb_dupl_add_) - !$OMP DO schedule(STATIC) + !$OMP DO schedule(dynamic,32) do j=1,nr first_elem = iaux(j) last_elem = iaux(j+1) - 1 @@ -3969,7 +4500,7 @@ subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf !$OMP END DO case(psb_dupl_err_) - !$OMP DO schedule(STATIC) + !$OMP DO schedule(dynamic,32) do j=1,nr first_elem = iaux(j) last_elem = iaux(j+1) - 1 @@ -4174,7 +4705,7 @@ subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf #if defined(OPENMP) !$OMP PARALLEL default(none) & !$OMP shared(nr,nc,nzin,iaux,ia,ja,val,nthreads) & - !$OMP private(i,j,first_idx,last_idx,nzl,act_row,iret,ithread, & + !$OMP private(i,j,idxstart,idxend,nzl,act_row,iret,ithread, & !$OMP work,first_elem,last_elem) !$OMP SINGLE @@ -4188,22 +4719,22 @@ subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf work = nr/nthreads if (ithread < MOD(nr,nthreads)) then work = work + 1 - first_idx = ithread*work + 1 + idxstart = ithread*work + 1 else - first_idx = ithread*work + MOD(nr,nthreads) + 1 + idxstart = ithread*work + MOD(nr,nthreads) + 1 end if - last_idx = first_idx + work - 1 + idxend = idxstart + work - 1 ! --------------------------------------------------- first_elem = 0 last_elem = -1 - act_row = first_idx + act_row = idxstart do j=1,nzin if (ia(j) < act_row) then cycle - else if ((ia(j) > last_idx) .or. (work < 1)) then + else if ((ia(j) > idxend) .or. (work < 1)) then exit else if (ia(j) > act_row) then nzl = last_elem - first_elem + 1 @@ -4333,684 +4864,14 @@ subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf end subroutine psb_d_fix_coo_inner_rowmajor -subroutine psb_d_fix_coo_inner_colmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,info) - use psb_const_mod + +subroutine psb_d_cp_coo_to_lcoo(a,b,info) use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_d_fix_coo_inner_colmajor - use psb_string_mod - use psb_ip_reord_mod - use psb_sort_mod -#if defined(OPENMP) - use omp_lib -#endif + use psb_d_base_mat_mod, psb_protect_name => psb_d_cp_coo_to_lcoo implicit none - - integer(psb_ipk_), intent(in) :: nr, nc, nzin, dupl - integer(psb_ipk_), intent(inout) :: ia(:), ja(:), iaux(:) - real(psb_dpk_), intent(inout) :: val(:) - integer(psb_ipk_), intent(out) :: nzout, info - !locals - integer(psb_ipk_), allocatable :: ias(:),jas(:), ix2(:) - real(psb_dpk_), allocatable :: vs(:) - integer(psb_ipk_) :: nza, nzl,iret - integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name = 'psb_fixcoo' - logical :: srt_inp, use_buffers -#if defined(OPENMP) - integer(psb_ipk_) :: work,first_idx,last_idx,first_elem,last_elem,s,nthreads,ithread - integer(psb_ipk_) :: saved_elem,old_val,nxt_val,err,act_row,act_col,maxthreads - integer(psb_ipk_), allocatable :: sum(:),kaux(:),idxaux(:) -#endif - info = psb_success_ - - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if (nc <= nzin) then - ! Avoid strange situations with large indices -#if defined(OPENMP) - allocate(ias(nzin),jas(nzin),vs(nzin), stat=info) -#else - allocate(ias(nzin),jas(nzin),vs(nzin),ix2(nzin+2), stat=info) -#endif - use_buffers = (info == 0) - else - use_buffers = .false. - end if - - if (use_buffers) then - iaux(:) = 0 -#if defined(OPENMP) - !$OMP PARALLEL DO default(none) schedule(STATIC) & - !$OMP shared(nzin,ja,nc,iaux) & - !$OMP private(i) & - !$OMP reduction(.and.:use_buffers) - do i=1,nzin - if ((ja(i) < 1).or.(ja(i) > nc)) then - use_buffers = .false. - ! Invalid indices are placed outside the considered range - ja(i) = nc+2 - else - !$OMP ATOMIC UPDATE - iaux(ja(i)) = iaux(ja(i)) + 1 - end if - end do - !$OMP END PARALLEL DO -#else - !srt_inp = .true. - do i=1,nzin - if ((ja(i) < 1).or.(ja(i) > nc)) then - use_buffers = .false. - !ja(i) = nc+2 - !srt_inp = .false. - exit - end if - - iaux(ja(i)) = iaux(ja(i)) + 1 - - !srt_inp = srt_inp .and.(ja(i-1)<=ja(i)) - end do -#endif - end if - - !use_buffers=use_buffers.and.srt_inp - - ! Check again use_buffers. We enter here if nzin >= nc and - ! all the indices are valid - if (use_buffers) then -#if defined(OPENMP) - allocate(kaux(MAX(nzin,nc)+2),idxaux(MAX((nr+2)*maxthreads,nc)),sum(maxthreads+1),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - kaux(:) = 0 - sum(:) = 0 - sum(1) = 1 - err = 0 - - ! Here, starting from 'iaux', we apply a fixing in order to obtain the starting - ! index for each column. We do the same on 'kaux' - !$OMP PARALLEL default(none) & - !$OMP shared(idxaux,ia,ja,val,ias,jas,vs,nthreads,sum,nr,nc,nzin,iaux,kaux,dupl,err) & - !$OMP private(s,i,j,k,ithread,first_idx,last_idx,work,nxt_val,old_val,saved_elem, & - !$OMP first_elem,last_elem,nzl,iret,act_col) - - !$OMP SINGLE - nthreads = omp_get_num_threads() - !$OMP END SINGLE - - ithread = omp_get_thread_num() - - ! -------- thread-specific workload -------- - - work = nc/nthreads - if (ithread < MOD(nc,nthreads)) then - work = work + 1 - first_idx = ithread*work + 1 - else - first_idx = ithread*work + MOD(nc,nthreads) + 1 - end if - - last_idx = first_idx + work - 1 - - !------------------------------------------- - ! ---------- iaux composition -------------- - - s = 0 - do i=first_idx,last_idx - s = s + iaux(i) - end do - sum(ithread+2) = s - - !$OMP BARRIER - - !$OMP SINGLE - do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) - end do - !$OMP END SINGLE - - if (work > 0) then - saved_elem = iaux(first_idx) - end if - if (ithread == 0) then - iaux(1) = 1 - end if - - !$OMP BARRIER - - if (work > 0) then - old_val = iaux(first_idx+1) - iaux(first_idx+1) = saved_elem + sum(ithread+1) - end if - - do i=first_idx+2,last_idx+1 - nxt_val = iaux(i) - iaux(i) = iaux(i-1) + old_val - old_val = nxt_val - end do - - ! -------------------------------------- - - !$OMP BARRIER - - ! ------------------ Sorting and buffers ------------------- - - ! Let's use an auxiliary buffer to get indices - do j=first_idx,last_idx - idxaux(j) = iaux(j) - end do - - ! Here we sort data inside the auxiliary buffers - do i=1,nzin - act_col = ja(i) - if (act_col >= first_idx .and. act_col <= last_idx) then - ias(idxaux(act_col)) = ia(i) - jas(idxaux(act_col)) = ja(i) - vs(idxaux(act_col)) = val(i) - - idxaux(act_col) = idxaux(act_col) + 1 - end if - end do - - !$OMP BARRIER - - ! Let's sort column indices and values. After that we will store - ! the number of unique values in 'kaux' - do j=first_idx,last_idx - first_elem = iaux(j) - last_elem = iaux(j+1) - 1 - nzl = last_elem - first_elem + 1 - - ! The column has elements? - if (nzl > 0) then - call psi_msort_up(nzl,ias(first_elem:last_elem), & - & idxaux((ithread*(nr+2))+1:(ithread*(nr+2))+nzl+2),iret) - - if (iret == 0) then - call psb_ip_reord(nzl,vs(first_elem:last_elem),& - & ias(first_elem:last_elem),jas(first_elem:last_elem), & - & idxaux((ithread*(nr+2))+1:(ithread*(nr+2))+nzl+2)) - end if - - ! Over each column we count the unique values - kaux(j) = 1 - do i=first_elem+1,last_elem - if (ias(i) == ias(i-1) .and. jas(i) == jas(i-1)) then - cycle - end if - kaux(j) = kaux(j) + 1 - end do - end if - end do - - ! -------------------------------------------------- - - ! ---------------- kaux composition ---------------- - - !$OMP SINGLE - sum(:) = 0 - sum(1) = 1 - !$OMP END SINGLE - - s = 0 - do i=first_idx,last_idx - s = s + kaux(i) - end do - sum(ithread+2) = s - - !$OMP BARRIER - - !$OMP SINGLE - do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) - end do - !$OMP END SINGLE - - if (work > 0) then - saved_elem = kaux(first_idx) - end if - if (ithread == 0) then - kaux(1) = 1 - end if - - !$OMP BARRIER - - if (work > 0) then - old_val = kaux(first_idx+1) - kaux(first_idx+1) = saved_elem + sum(ithread+1) - end if - - do i=first_idx+2,last_idx+1 - nxt_val = kaux(i) - kaux(i) = kaux(i-1) + old_val - old_val = nxt_val - end do - - !$OMP BARRIER - - ! ------------------------------------------------ - - select case(dupl) - case(psb_dupl_ovwrt_) - !$OMP DO schedule(STATIC) - do j=1,nc - first_elem = iaux(j) - last_elem = iaux(j+1) - 1 - - if (first_elem > last_elem) then - cycle - end if - - k = kaux(j) - - val(k) = vs(first_elem) - ia(k) = ias(first_elem) - ja(k) = jas(first_elem) - - do i=first_elem+1,last_elem - if ((ias(i) == ias(i-1)).and.(jas(i) == jas(i-1))) then - val(k) = vs(i) - else - k = k + 1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - endif - end do - end do - !$OMP END DO - - case(psb_dupl_add_) - !$OMP DO schedule(STATIC) - do j=1,nc - first_elem = iaux(j) - last_elem = iaux(j+1) - 1 - - if (first_elem > last_elem) then - cycle - end if - - k = kaux(j) - - val(k) = vs(first_elem) - ia(k) = ias(first_elem) - ja(k) = jas(first_elem) - - do i=first_elem+1,last_elem - if ((ias(i) == ias(i-1)).and.(jas(i) == jas(i-1))) then - val(k) = val(k) + vs(i) - else - k = k + 1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - endif - end do - end do - !$OMP END DO - - case(psb_dupl_err_) - !$OMP DO schedule(STATIC) - do j=1,nc - first_elem = iaux(j) - last_elem = iaux(j+1) - 1 - - if (first_elem > last_elem) then - cycle - end if - - k = kaux(j) - - val(k) = vs(first_elem) - ia(k) = ias(first_elem) - ja(k) = jas(first_elem) - - do i=first_elem+1,last_elem - if ((ias(i) == ias(i-1)).and.(jas(i) == jas(i-1))) then - err = 1 - else - k = k + 1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - end if - end do - end do - !$OMP END DO - - case default - !$OMP SINGLE - err = 2 - !$OMP END SINGLE - end select - - !$OMP END PARALLEL - - if (err == 1) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else if (err == 2) then - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl - info =-7 - return - end if - - nzout = kaux(nc+1) - 1 - - deallocate(sum,kaux,idxaux,stat=info) -#else - !if (.not.srt_inp) then - ip = iaux(1) - iaux(1) = 0 - do i=2, nc - is = iaux(i) - iaux(i) = ip - ip = ip + is - end do - iaux(nc+1) = ip - - do i=1,nzin - icl = ja(i) - ip = iaux(icl) + 1 - ias(ip) = ia(i) - jas(ip) = ja(i) - vs(ip) = val(i) - iaux(icl) = ip - end do - !end if - - select case(dupl) - case(psb_dupl_ovwrt_) - k = 0 - i = 1 - do j=1, nc - nzl = iaux(j)-i+1 - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ias(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,vs(i:imx),& - & ias(i:imx),jas(i:imx),ix2) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - end if - end do - - case(psb_dupl_add_) - k = 0 - i = 1 - do j=1, nc - nzl = iaux(j)-i+1 - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ias(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,vs(i:imx),& - & ias(i:imx),jas(i:imx),ix2) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = val(k) + vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - end if - end do - - case(psb_dupl_err_) - k = 0 - i = 1 - do j=1, nc - nzl = iaux(j)-i+1 - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ias(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,vs(i:imx),& - & ias(i:imx),jas(i:imx),ix2) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - end if - end do - - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl - info =-7 - return - end select - - nzout = k - - deallocate(ix2, stat=info) -#endif - - deallocate(ias,jas,vs, stat=info) - - else if (.not.use_buffers) then - - call psi_msort_up(nzin,ja(1:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(nzin,val,ia,ja,iaux) -#if defined(OPENMP) - !$OMP PARALLEL default(none) & - !$OMP shared(nr,nc,nzin,iaux,ia,ja,val,nthreads) & - !$OMP private(i,j,first_idx,last_idx,nzl,act_col, & - !$OMP iret,ithread,work,first_elem,last_elem) - - !$OMP SINGLE - nthreads = omp_get_num_threads() - !$OMP END SINGLE - - ithread = omp_get_thread_num() - - ! -------- thread-specific workload -------- - - work = nc/nthreads - if (ithread < MOD(nc,nthreads)) then - work = work + 1 - first_idx = ithread*work + 1 - else - first_idx = ithread*work + MOD(nc,nthreads) + 1 - end if - - last_idx = first_idx + work - 1 - - ! --------------------------------------------------- - - first_elem = 0 - last_elem = -1 - act_col = first_idx - do j=1,nzin - if (ja(j) < act_col) then - cycle - else if ((ja(j) > last_idx) .or. (work < 1)) then - exit - else if (ja(j) > act_col) then - nzl = last_elem - first_elem + 1 - - if (nzl > 0) then - call psi_msort_up(nzl,ia(first_elem:),iaux((ithread*(nr+2))+1:(ithread*(nr+2))+nzl+2),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(first_elem:last_elem),& - & ia(first_elem:last_elem),ja(first_elem:last_elem),& - & iaux((ithread*(nr+2))+1:(ithread*(nr+2))+nzl+2)) - end if - - act_col = act_col + 1 - first_elem = 0 - last_elem = -1 - else - if (first_elem == 0) then - first_elem = j - end if - - last_elem = j - end if - end do - !$OMP END PARALLEL -#else - i = 1 - j = i - do while (i <= nzin) - do while ((ja(j) == ja(i))) - j = j+1 - if (j > nzin) exit - enddo - nzl = j - i - call psi_msort_up(nzl,ia(i:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(i:i+nzl-1),& - & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) - i = j - enddo -#endif - - i = 1 - irw = ia(i) - icl = ja(i) - j = 1 - - - select case(dupl) - case(psb_dupl_ovwrt_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) < 1 .or. ia(j) > nr) .or. (ja(j) < 1 .or. ja(j) > nc)) cycle - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_add_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) < 1 .or. ia(j) > nr) .or. (ja(j) < 1 .or. ja(j) > nc)) cycle - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(i) + val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_err_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) < 1 .or. ia(j) > nr) .or. (ja(j) < 1 .or. ja(j) > nc)) cycle - if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl - info =-7 - end select - - nzout = i - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end second loop' - - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_d_fix_coo_inner_colmajor - - -subroutine psb_d_cp_coo_to_lcoo(a,b,info) - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_d_cp_coo_to_lcoo - implicit none - class(psb_d_coo_sparse_mat), intent(in) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + class(psb_d_coo_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_lpk_) :: nz @@ -5296,7 +5157,7 @@ function psb_ld_coo_maxval(a) result(res) #if defined(OPENMP) block integer(psb_ipk_) :: i - !$omp parallel do private(i) + !$omp parallel do private(i) reduction(max:res) do i=1, nnz res = max(res,abs(a%val(i))) end do @@ -5363,7 +5224,7 @@ function psb_ld_coo_csnmi(a) result(res) #if defined(OPENMP) block integer(psb_ipk_) :: i - !$omp parallel do private(i) + !$omp parallel do private(i) reduction(max:res) do i=1, m res = max(res,abs(vt(i))) end do @@ -5413,7 +5274,7 @@ function psb_ld_coo_csnm1(a) result(res) #if defined(OPENMP) block integer(psb_ipk_) :: i - !$omp parallel do private(i) + !$omp parallel do private(i) reduction(max:res) do i=1, n res = max(res,abs(vt(i))) end do @@ -8335,3 +8196,4 @@ subroutine psb_ld_cp_coo_from_icoo(a,b,info) return end subroutine psb_ld_cp_coo_from_icoo + diff --git a/base/serial/impl/psb_d_csc_impl.F90 b/base/serial/impl/psb_d_csc_impl.F90 index 3b9b1b42b..1761b0514 100644 --- a/base/serial/impl/psb_d_csc_impl.F90 +++ b/base/serial/impl/psb_d_csc_impl.F90 @@ -2189,6 +2189,9 @@ subroutine psb_d_mv_csc_from_coo(a,b,info) use psb_error_mod use psb_d_base_mat_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_mv_csc_from_coo +#if defined(OPENMP) + use omp_lib +#endif implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a @@ -2223,18 +2226,33 @@ subroutine psb_d_mv_csc_from_coo(a,b,info) call psb_realloc(nc+1,a%icp,info) call b%free() +#if defined(OPENMP) + + !$OMP PARALLEL default(shared) + + !$OMP WORKSHARE a%icp(:) = 0 + !$OMP END WORKSHARE + + !$OMP DO schedule(STATIC) & + !$OMP private(k,i) do k=1,nza i = itemp(k) - a%icp(i) = a%icp(i) + 1 + !$OMP ATOMIC UPDATE + a%icp(i+1) = a%icp(i+1) + 1 + !$OMP END ATOMIC end do - ip = 1 - do i=1,nc - nrl = a%icp(i) - a%icp(i) = ip - ip = ip + nrl + !$OMP END DO + call psi_exscan(nc+1,a%icp,info,shift=ione) + !$OMP END PARALLEL +#else + a%icp(:) = 0 + do k=1,nza + i = itemp(k) + a%icp(i) = a%icp(i) + 1 end do - a%icp(nc+1) = ip + call psi_exscan(nc+1,a%icp,info,shift=ione) +#endif call a%set_host() @@ -2311,9 +2329,28 @@ subroutine psb_d_cp_csc_to_fmt(a,b,info) b%psb_d_base_sparse_mat = a%psb_d_base_sparse_mat nc = a%get_ncols() nz = a%get_nzeros() - if (info == 0) call psb_safe_cpy( a%icp(1:nc+1), b%icp , info) - if (info == 0) call psb_safe_cpy( a%ia(1:nz), b%ia , info) - if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + if (.false.) then + if (info == 0) call psb_safe_cpy( a%icp(1:nc+1), b%icp , info) + if (info == 0) call psb_safe_cpy( a%ia(1:nz), b%ia , info) + if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + else + ! Despite the implementation in safe_cpy, it seems better this way + call psb_realloc(nc+1,b%icp,info) + call psb_realloc(nz,b%ia,info) + call psb_realloc(nz,b%val,info) + !$omp parallel do private(i) schedule(static) + do i=1,nc+1 + b%icp(i)=a%icp(i) + end do + !$omp end parallel do + !$omp parallel do private(j) schedule(static) + do j=1,nz + b%ia(j) = a%ia(j) + b%val(j) = a%val(j) + end do + !$omp end parallel do + end if + call b%set_host() class default @@ -2425,9 +2462,27 @@ subroutine psb_d_cp_csc_from_fmt(a,b,info) a%psb_d_base_sparse_mat = b%psb_d_base_sparse_mat nc = b%get_ncols() nz = b%get_nzeros() - if (info == 0) call psb_safe_cpy( b%icp(1:nc+1), a%icp , info) - if (info == 0) call psb_safe_cpy( b%ia(1:nz), a%ia , info) - if (info == 0) call psb_safe_cpy( b%val(1:nz), a%val , info) + if (.false.) then + if (info == 0) call psb_safe_cpy( b%icp(1:nc+1), a%icp , info) + if (info == 0) call psb_safe_cpy( b%ia(1:nz), a%ia , info) + if (info == 0) call psb_safe_cpy( b%val(1:nz), a%val , info) + else + ! Despite the implementation in safe_cpy, it seems better this way + call psb_realloc(nc+1,a%icp,info) + call psb_realloc(nz,a%ia,info) + call psb_realloc(nz,a%val,info) + !$omp parallel do private(i) schedule(static) + do i=1,nc+1 + a%icp(i)=b%icp(i) + end do + !$omp end parallel do + !$omp parallel do private(j) schedule(static) + do j=1,nz + a%ia(j)=b%ia(j) + a%val(j)=b%val(j) + end do + !$omp end parallel do + end if call a%set_host() class default diff --git a/base/serial/impl/psb_d_csr_impl.F90 b/base/serial/impl/psb_d_csr_impl.F90 index 6d2b58ad7..40d97bc07 100644 --- a/base/serial/impl/psb_d_csr_impl.F90 +++ b/base/serial/impl/psb_d_csr_impl.F90 @@ -152,6 +152,7 @@ contains !$omp parallel do private(i,j, acc) schedule(static) do i=1,m acc = dzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -163,6 +164,7 @@ contains !$omp parallel do private(i,j, acc) do i=1,m acc = dzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -174,6 +176,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = dzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -189,6 +192,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = dzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -200,6 +204,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = dzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -211,6 +216,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = dzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -225,6 +231,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = dzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -236,6 +243,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = dzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -247,6 +255,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = dzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -261,6 +270,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = dzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -272,6 +282,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = dzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -283,6 +294,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = dzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -2277,7 +2289,155 @@ subroutine psb_d_csr_tril(a,l,info,& nb = jmax_ endif +#if defined(OPENMP) + block + integer(psb_ipk_), allocatable :: lrws(:),urws(:) + integer(psb_ipk_) :: lpnt, upnt, lnz, unz + call psb_realloc(mb,lrws,info) + !$omp workshare + lrws(:) = 0 + !$omp end workshare + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + !write(0,*) 'Invocation of COO%TRIL', present(u),nz + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + if (info == 0) call psb_realloc(mb,urws,info) + !$omp workshare + urws(:) = 0 + !$omp end workshare + !write(0,*) 'omp version of COO%TRIL/TRIU' + lnz = 0 + unz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws,urws) reduction(+: lnz,unz) + loop1: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic update + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + !$omp end atomic + lnz = lnz + 1 + else + !$omp atomic update + urws(i-imin_+1) = urws(i-imin_+1) +1 + !$omp end atomic + unz = unz + 1 + end if + end if + end do + end do loop1 + !$omp end parallel do + + call psi_exscan(mb,lrws,info) + call psi_exscan(mb,urws,info) + !write(0,*) lrws(:), urws(:) + !$omp parallel do private(i,j,k,lpnt,upnt) shared(imin_,imax_,a) + loop2: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic capture + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + lpnt = lrws(i-imin_+1) + !$omp end atomic + l%ia(lpnt) = i + l%ja(lpnt) = a%ja(k) + l%val(lpnt) = a%val(k) + else + !$omp atomic capture + urws(i-imin_+1) = urws(i-imin_+1) +1 + upnt = urws(i-imin_+1) + !$omp end atomic + u%ia(upnt) = i + u%ja(upnt) = a%ja(k) + u%val(upnt) = a%val(k) + end if + end if + end do + end do loop2 + !$omp end parallel do + !write(0,*) 'End of copyout',lnz,unz + call l%set_nzeros(lnz) + call l%fix(info) + call u%set_nzeros(unz) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) then + !$omp workshare + u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + if ((diag_ >=-1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + lnz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws) reduction(+: lnz) + loop3: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic update + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + !$omp end atomic + lnz = lnz + 1 + end if + end if + end do + end do loop3 + !$omp end parallel do + call psi_exscan(mb,lrws,info) + !$omp parallel do private(i,j,k,lpnt) shared(imin_,imax_,a) + loop4: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic capture + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + lpnt = lrws(i-imin_+1) + !$omp end atomic + l%ia(lpnt) = i + l%ja(lpnt) = a%ja(k) + l%val(lpnt) = a%val(k) + end if + end if + end do + end do loop4 + !$omp end parallel do + call l%set_nzeros(lnz) + call l%fix(info) + end if + nzout = l%get_nzeros() + if (rscale_) then + !$omp workshare + l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if + end block +#else nz = a%get_nzeros() call l%allocate(mb,nb,nz) @@ -2347,7 +2507,7 @@ subroutine psb_d_csr_tril(a,l,info,& call l%set_triangle(.true.) call l%set_lower(.true.) end if - +#endif if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2431,6 +2591,158 @@ subroutine psb_d_csr_triu(a,u,info,& endif +#if defined(OPENMP) + block + integer(psb_ipk_), allocatable :: lrws(:),urws(:) + integer(psb_ipk_) :: lpnt, upnt, lnz, unz + call psb_realloc(mb,urws,info) + !$omp workshare + urws(:) = 0 + !$omp end workshare + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + !write(0,*) 'Invocation of COO%TRIL', present(u),nz + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + if (info == 0) call psb_realloc(mb,urws,info) + !$omp workshare + lrws(:) = 0 + !$omp end workshare + !write(0,*) 'omp version of COO%TRIL/TRIU' + lnz = 0 + unz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws,urws) reduction(+: lnz,unz) + loop1: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)=diag_) then + !$omp atomic update + urws(i-imin_+1) = urws(i-imin_+1) +1 + !$omp end atomic + unz = unz + 1 + end if + end if + end do + end do loop3 + !$omp end parallel do + call psi_exscan(mb,urws,info) + !$omp parallel do private(i,j,k,upnt) shared(imin_,imax_,a) + loop4: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)>=diag_) then + !$omp atomic capture + urws(i-imin_+1) = urws(i-imin_+1) +1 + upnt = urws(i-imin_+1) + !$omp end atomic + u%ia(upnt) = i + u%ja(upnt) = a%ja(k) + u%val(upnt) = a%val(k) + end if + end if + end do + end do loop4 + !$omp end parallel do + call u%set_nzeros(unz) + call u%fix(info) + end if + nzout = u%get_nzeros() + if (rscale_) then + !$omp workshare + u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + + if ((diag_ >= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_upper(.true.) + end if + end block + + +#else + nz = a%get_nzeros() call u%allocate(mb,nb,nz) @@ -2499,7 +2811,7 @@ subroutine psb_d_csr_triu(a,u,info,& call u%set_triangle(.true.) call u%set_upper(.true.) end if - +#endif if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2844,6 +3156,9 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) use psb_realloc_mod use psb_d_base_mat_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_cp_csr_from_coo +#if defined(OPENMP) + use omp_lib +#endif implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a @@ -2860,12 +3175,6 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) character(len=20) :: name='d_cp_csr_from_coo' logical :: use_openmp = .false. - !$ integer(psb_ipk_), allocatable :: sum(:) - !$ integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s,j - !$ integer(psb_ipk_) :: nxt_val,old_val,saved_elem,maxthreads - !$ use_openmp = .true. - - info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2904,98 +3213,39 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) if (info == psb_success_) call psb_safe_ab_cpy(b%ja,a%ja,info) if (info == psb_success_) call psb_safe_ab_cpy(b%val,a%val,info) if (info == psb_success_) call psb_realloc(max(nr+1,nc+1),a%irp,info) - + endif + +#if defined(OPENMP) + + !$OMP PARALLEL default(shared) reduction(max:info) + + !$OMP WORKSHARE a%irp(:) = 0 - -!!$ if (use_openmp) then -!!$ !$ maxthreads = omp_get_max_threads() -!!$ !$ allocate(sum(maxthreads+1)) -!!$ !$ sum(:) = 0 -!!$ !$ sum(1) = 1 -!!$ -!!$ !$OMP PARALLEL default(none) & -!!$ !$OMP shared(nza,itemp,a,nthreads,sum,nr) & -!!$ !$OMP private(ithread,work,first_idx,last_idx,s,saved_elem,nxt_val,old_val) -!!$ -!!$ !$OMP DO schedule(STATIC) & -!!$ !$OMP private(k,i) -!!$ do k=1,nza -!!$ i = itemp(k) -!!$ a%irp(i) = a%irp(i) + 1 -!!$ end do -!!$ !$OMP END DO -!!$ -!!$ !$OMP SINGLE -!!$ !$ nthreads = omp_get_num_threads() -!!$ !$OMP END SINGLE -!!$ -!!$ !$ ithread = omp_get_thread_num() -!!$ -!!$ !$ work = nr/nthreads -!!$ !$ if (ithread < MOD(nr,nthreads)) then -!!$ !$ work = work + 1 -!!$ !$ first_idx = ithread*work + 1 -!!$ !$ else -!!$ !$ first_idx = ithread*work + MOD(nr,nthreads) + 1 -!!$ !$ end if -!!$ -!!$ !$ last_idx = first_idx + work - 1 -!!$ -!!$ !$ s = 0 -!!$ !$ do i=first_idx,last_idx -!!$ !$ s = s + a%irp(i) -!!$ !$ end do -!!$ !$ if (work > 0) then -!!$ !$ sum(ithread+2) = s -!!$ !$ end if -!!$ -!!$ !$OMP BARRIER -!!$ -!!$ !$OMP SINGLE -!!$ !$ do i=2,nthreads+1 -!!$ !$ sum(i) = sum(i) + sum(i-1) -!!$ !$ end do -!!$ !$OMP END SINGLE -!!$ -!!$ !$ if (work > 0) then -!!$ !$ saved_elem = a%irp(first_idx) -!!$ !$ end if -!!$ !$ if (ithread == 0) then -!!$ !$ a%irp(1) = 1 -!!$ !$ end if -!!$ -!!$ !$OMP BARRIER -!!$ -!!$ !$ if (work > 0) then -!!$ !$ old_val = a%irp(first_idx+1) -!!$ !$ a%irp(first_idx+1) = saved_elem + sum(ithread+1) -!!$ !$ end if -!!$ -!!$ !$ do i=first_idx+2,last_idx+1 -!!$ !$ nxt_val = a%irp(i) -!!$ !$ a%irp(i) = a%irp(i-1) + old_val -!!$ !$ old_val = nxt_val -!!$ !$ end do -!!$ -!!$ !$OMP END PARALLEL -!!$ else - - do k=1,nza - i = itemp(k) - a%irp(i) = a%irp(i) + 1 - end do - ip = 1 - do i=1,nr - ncl = a%irp(i) - a%irp(i) = ip - ip = ip + ncl - end do - a%irp(nr+1) = ip -!!$ end if - call a%set_host() + !$OMP END WORKSHARE + + !$OMP DO schedule(STATIC) & + !$OMP private(k,i) + do k=1,nza + i = itemp(k) + !$OMP ATOMIC UPDATE + a%irp(i) = a%irp(i) + 1 + !$OMP END ATOMIC + end do + !$OMP END DO + call psi_exscan(nr+1,a%irp,info,shift=ione) + !$OMP END PARALLEL +#else + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + call psi_exscan(nr+1,a%irp,info,shift=ione) +#endif + call a%set_host() end subroutine psb_d_cp_csr_from_coo @@ -3096,6 +3346,9 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) use psb_error_mod use psb_d_base_mat_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_mv_csr_from_coo +#if defined(OPENMP) + use omp_lib +#endif implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a @@ -3109,13 +3362,6 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='mv_from_coo' - logical :: use_openmp = .false. - - ! $ integer(psb_ipk_), allocatable :: sum(:) - ! $ integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s - ! $ integer(psb_ipk_) :: nxt_val,old_val,saved_elem - ! $ use_openmp = .true. - info = psb_success_ debug_unit = psb_get_debug_unit() @@ -3139,90 +3385,34 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) call psb_realloc(max(nr+1,nc+1),a%irp,info) call b%free() +#if defined(OPENMP) + !$OMP PARALLEL default(shared) reduction(max:info) + + !$OMP WORKSHARE a%irp(:) = 0 + !$OMP END WORKSHARE + + !$OMP DO schedule(STATIC) & + !$OMP private(k,i) + do k=1,nza + i = itemp(k) + !$OMP ATOMIC UPDATE + a%irp(i) = a%irp(i) + 1 + !$OMP END ATOMIC + end do + !$OMP END DO + call psi_exscan(nr+1,a%irp,info,shift=ione) + !$OMP END PARALLEL +#else + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + call psi_exscan(nr+1,a%irp,info,shift=ione) +#endif -!!$ if (use_openmp) then -!!$ !$OMP PARALLEL default(none) & -!!$ !$OMP shared(sum,nthreads,nr,a,itemp,nza) & -!!$ !$OMP private(ithread,work,first_idx,last_idx,s,saved_elem,nxt_val,old_val) -!!$ -!!$ !$OMP DO schedule(STATIC) & -!!$ !$OMP private(k,i) -!!$ do k=1,nza -!!$ i = itemp(k) -!!$ a%irp(i) = a%irp(i) + 1 -!!$ end do -!!$ !$OMP END DO -!!$ -!!$ !$OMP SINGLE -!!$ !$ nthreads = omp_get_num_threads() -!!$ !$ allocate(sum(nthreads+1)) -!!$ !$ sum(:) = 0 -!!$ !$ sum(1) = 1 -!!$ !$OMP END SINGLE -!!$ -!!$ !$ ithread = omp_get_thread_num() -!!$ -!!$ !$ work = nr/nthreads -!!$ !$ if (ithread < MOD(nr,nthreads)) then -!!$ !$ work = work + 1 -!!$ !$ first_idx = ithread*work + 1 -!!$ !$ else -!!$ !$ first_idx = ithread*work + MOD(nr,nthreads) + 1 -!!$ !$ end if -!!$ -!!$ !$ last_idx = first_idx + work - 1 -!!$ -!!$ !$ s = 0 -!!$ !$ do i=first_idx,last_idx -!!$ !$ s = s + a%irp(i) -!!$ !$ end do -!!$ !$ if (work > 0) then -!!$ !$ sum(ithread+2) = s -!!$ !$ end if -!!$ -!!$ !$OMP BARRIER -!!$ -!!$ !$OMP SINGLE -!!$ !$ do i=2,nthreads+1 -!!$ !$ sum(i) = sum(i) + sum(i-1) -!!$ !$ end do -!!$ !$OMP END SINGLE -!!$ -!!$ !$ if (work > 0) then -!!$ !$ saved_elem = a%irp(first_idx) -!!$ !$ end if -!!$ !$ if (ithread == 0) then -!!$ !$ a%irp(1) = 1 -!!$ !$ end if -!!$ -!!$ !$ if (work > 0) then -!!$ !$ old_val = a%irp(first_idx+1) -!!$ !$ a%irp(first_idx+1) = saved_elem + sum(ithread+1) -!!$ !$ end if -!!$ -!!$ !$ do i=first_idx+2,last_idx+1 -!!$ !$ nxt_val = a%irp(i) -!!$ !$ a%irp(i) = a%irp(i-1) + old_val -!!$ !$ old_val = nxt_val -!!$ !$ end do -!!$ -!!$ !$OMP END PARALLEL -!!$ else - do k=1,nza - i = itemp(k) - a%irp(i) = a%irp(i) + 1 - end do - ip = 1 - do i=1,nr - ncl = a%irp(i) - a%irp(i) = ip - ip = ip + ncl - end do - a%irp(nr+1) = ip -!!$ end if - call a%set_host() end subroutine psb_d_mv_csr_from_coo @@ -3300,9 +3490,28 @@ subroutine psb_d_cp_csr_to_fmt(a,b,info) b%psb_d_base_sparse_mat = a%psb_d_base_sparse_mat nr = a%get_nrows() nz = a%get_nzeros() - if (info == 0) call psb_safe_cpy( a%irp(1:nr+1), b%irp , info) - if (info == 0) call psb_safe_cpy( a%ja(1:nz), b%ja , info) - if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + if (.false.) then + if (info == 0) call psb_safe_cpy( a%irp(1:nr+1), b%irp , info) + if (info == 0) call psb_safe_cpy( a%ja(1:nz), b%ja , info) + if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + else + ! Despite the implementation in safe_cpy, it seems better this way + call psb_realloc(nr+1,b%irp,info) + call psb_realloc(nz,b%ja,info) + call psb_realloc(nz,b%val,info) + !$omp parallel do private(i) schedule(static) + do i=1,nr+1 + b%irp(i)=a%irp(i) + end do + !$omp end parallel do + !$omp parallel do private(j) schedule(static) + do j=1,nz + b%ja(j) = a%ja(j) + b%val(j) = a%val(j) + end do + !$omp end parallel do + end if + call b%set_host() class default @@ -3386,9 +3595,27 @@ subroutine psb_d_cp_csr_from_fmt(a,b,info) a%psb_d_base_sparse_mat = b%psb_d_base_sparse_mat nr = b%get_nrows() nz = b%get_nzeros() - if (info == 0) call psb_safe_cpy( b%irp(1:nr+1), a%irp , info) - if (info == 0) call psb_safe_cpy( b%ja(1:nz) , a%ja , info) - if (info == 0) call psb_safe_cpy( b%val(1:nz) , a%val , info) + if (.false.) then + if (info == 0) call psb_safe_cpy( b%irp(1:nr+1), a%irp , info) + if (info == 0) call psb_safe_cpy( b%ja(1:nz) , a%ja , info) + if (info == 0) call psb_safe_cpy( b%val(1:nz) , a%val , info) + else + ! Despite the implementation in safe_cpy, it seems better this way + call psb_realloc(nr+1,a%irp,info) + call psb_realloc(nz,a%ja,info) + call psb_realloc(nz,a%val,info) + !$omp parallel do private(i) schedule(static) + do i=1,nr+1 + a%irp(i)=b%irp(i) + end do + !$omp end parallel do + !$omp parallel do private(j) schedule(static) + do j=1,nz + a%ja(j)=b%ja(j) + a%val(j)=b%val(j) + end do + !$omp end parallel do + end if call a%set_host() class default @@ -3427,6 +3654,540 @@ subroutine psb_d_csr_clean_zeros(a, info) call a%set_host() end subroutine psb_d_csr_clean_zeros +#if defined(OPENMP) +subroutine psb_dcsrspspmm(a,b,c,info) + use psb_d_mat_mod + use psb_serial_mod, psb_protect_name => psb_dcsrspspmm + + implicit none + + class(psb_d_csr_sparse_mat), intent(in) :: a,b + type(psb_d_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: ma,na,mb,nb, nzc, nza, nzb + character(len=20) :: name + integer(psb_ipk_) :: err_act + name='psb_csrspspmm' + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + if (b%is_dev()) call b%sync() + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb + info = psb_err_invalid_matrix_sizes_ + call psb_errpush(info,name) + goto 9999 + endif + + select case(spspmm_impl) + case (spspmm_serial) + ! Estimate number of nonzeros on output. + nza = a%get_nzeros() + nzb = b%get_nzeros() + nzc = 2*(nza+nzb) + call c%allocate(ma,nb,nzc) + + call csr_spspmm(a,b,c,info) + case (spspmm_omp_gustavson) + call spmm_omp_gustavson(a,b,c,info) + case (spspmm_omp_gustavson_1d) + call spmm_omp_gustavson_1d(a,b,c,info) + case (spspmm_serial_rb_tree) + call spmm_serial_rb_tree(a,b,c,info) + case (spspmm_omp_rb_tree) + call spmm_omp_rb_tree(a,b,c,info) + case (spspmm_omp_two_pass) + call spmm_omp_two_pass(a,b,c,info) + case default + write(psb_err_unit,*) 'Unknown spspmm implementation' + ! push error + goto 9999 + end select + + call c%set_asb() + call c%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csr_spspmm(a,b,c,info) + implicit none + type(psb_d_csr_sparse_mat), intent(in) :: a,b + type(psb_d_csr_sparse_mat), intent(inout) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: ma,na,mb,nb + integer(psb_ipk_), allocatable :: irow(:), idxs(:) + real(psb_dpk_), allocatable :: row(:) + integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, & + & nzc,nnzre, isz, ipb, irwsz, nrc, nze + real(psb_dpk_) :: cfb + + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = min(size(c%val),size(c%ja)) + isz = max(ma,na,mb,nb) + call psb_realloc(isz,row,info) + if (info == 0) call psb_realloc(isz,idxs,info) + if (info == 0) call psb_realloc(isz,irow,info) + if (info /= 0) return + row = dzero + irow = 0 + nzc = 1 + do j = 1,ma + c%irp(j) = nzc + nrc = 0 + do k = a%irp(j), a%irp(j+1)-1 + irw = a%ja(k) + cfb = a%val(k) + irwsz = b%irp(irw+1)-b%irp(irw) + do i = b%irp(irw),b%irp(irw+1)-1 + icl = b%ja(i) + if (irow(icl) 0 ) then + if ((nzc+nrc)>nze) then + nze = max(ma*((nzc+j-1)/j),nzc+2*nrc) + call psb_realloc(nze,c%val,info) + if (info == 0) call psb_realloc(nze,c%ja,info) + if (info /= 0) return + end if + + call psb_qsort(idxs(1:nrc)) + do i=1, nrc + irw = idxs(i) + c%ja(nzc) = irw + c%val(nzc) = row(irw) + row(irw) = dzero + nzc = nzc + 1 + end do + end if + end do + + c%irp(ma+1) = nzc + end subroutine csr_spspmm + + ! gustavson's algorithm using perfect hashing + ! and OpenMP parallelisation + subroutine spmm_omp_gustavson(a,b,c,info) + use omp_lib + + implicit none + type(psb_d_csr_sparse_mat), intent(in) :: a,b + type(psb_d_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + real(psb_dpk_), allocatable :: vals(:), acc(:) + integer(psb_ipk_) :: ma, nb + integer(psb_ipk_), allocatable :: col_inds(:), offsets(:) + integer(psb_ipk_) :: irw, jj, j, k, nnz, rwnz, thread_upperbound, start_idx, end_idx + + ma = a%get_nrows() + nb = b%get_ncols() + + call c%allocate(ma, nb) + c%irp(1) = 1 + + ! dense accumulator + ! https://sc18.supercomputing.org/proceedings/workshops/workshop_files/ws_lasalss115s2-file1.pdf + call psb_realloc(nb, acc, info) + + allocate(offsets(omp_get_max_threads())) + !$omp parallel private(vals,col_inds,nnz,rwnz,thread_upperbound,acc,start_idx,end_idx) & + !$omp shared(a,b,c,offsets) + thread_upperbound = 0 + start_idx = 0 + !$omp do schedule(static) private(irw, jj, j) + do irw = 1, ma + if (start_idx == 0) then + start_idx = irw + end if + end_idx = irw + do jj = a%irp(irw), a%irp(irw + 1) - 1 + j = a%ja(jj) + thread_upperbound = thread_upperbound + b%irp(j+1) - b%irp(j) + end do + end do + !$omp end do + + call psb_realloc(thread_upperbound, vals, info) + call psb_realloc(thread_upperbound, col_inds, info) + + ! possible bottleneck + acc = 0 + + nnz = 0 + !$omp do schedule(static) private(irw, jj, j, k) + do irw = 1, ma + rwnz = 0 + do jj = a%irp(irw), a%irp(irw + 1) - 1 + j = a%ja(jj) + do k = b%irp(j), b%irp(j + 1) - 1 + if (acc(b%ja(k)) == 0) then + nnz = nnz + 1 + rwnz = rwnz + 1 + col_inds(nnz) = b%ja(k) + end if + acc(b%ja(k)) = acc(b%ja(k)) + a%val(jj) * b%val(k) + end do + end do + call psb_qsort(col_inds(nnz - rwnz + 1:nnz)) + + do k = nnz - rwnz + 1, nnz + vals(k) = acc(col_inds(k)) + acc(col_inds(k)) = 0 + end do + c%irp(irw + 1) = rwnz + end do + !$omp end do + + offsets(omp_get_thread_num() + 1) = nnz + !$omp barrier + + ! possible bottleneck + !$omp single + do k = 1, omp_get_num_threads() - 1 + offsets(k + 1) = offsets(k + 1) + offsets(k) + end do + !$omp end single + + !$omp barrier + + if (omp_get_thread_num() /= 0) then + c%irp(start_idx) = offsets(omp_get_thread_num()) + 1 + end if + + do irw = start_idx, end_idx - 1 + c%irp(irw + 1) = c%irp(irw + 1) + c%irp(irw) + end do + + !$omp barrier + + !$omp single + c%irp(ma + 1) = c%irp(ma + 1) + c%irp(ma) + call psb_realloc(c%irp(ma + 1), c%val, info) + call psb_realloc(c%irp(ma + 1), c%ja, info) + !$omp end single + + c%val(c%irp(start_idx):c%irp(end_idx + 1) - 1) = vals(1:nnz) + c%ja(c%irp(start_idx):c%irp(end_idx + 1) - 1) = col_inds(1:nnz) + !$omp end parallel + end subroutine spmm_omp_gustavson + + subroutine spmm_omp_gustavson_1d(a,b,c,info) + use omp_lib + + implicit none + type(psb_d_csr_sparse_mat), intent(in) :: a,b + type(psb_d_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + real(psb_dpk_), allocatable :: vals(:), acc(:) + integer(psb_ipk_) :: ma, nb + integer(psb_ipk_), allocatable :: col_inds(:), offsets(:) + integer(psb_ipk_) :: irw, jj, j, k, nnz, rwnz, thread_upperbound, & + start_idx, end_idx , blk, blk_size, rwstart,& + rwblk, rwblkrem, nblks + + ma = a%get_nrows() + nb = b%get_ncols() + + call c%allocate(ma, nb) + c%irp(1) = 1 + + ! dense accumulator + ! https://sc18.supercomputing.org/proceedings/workshops/workshop_files/ws_lasalss115s2-file1.pdf + call psb_realloc(nb, acc, info) + allocate(offsets(omp_get_max_threads())) + + nblks = 4 * omp_get_max_threads() + rwblk = (ma / nblks) + rwblkrem = modulo(ma, nblks) + !$omp parallel private(vals,col_inds,nnz,thread_upperbound,acc,start_idx,end_idx) shared(a,b,c,offsets) + thread_upperbound = 0 + start_idx = 0 + !$omp do schedule(static) private(irw, jj, j) + do irw = 1, ma + do jj = a%irp(irw), a%irp(irw + 1) - 1 + j = a%ja(jj) + thread_upperbound = thread_upperbound + b%irp(j+1) - b%irp(j) + end do + end do + !$omp end do + + call psb_realloc(thread_upperbound, vals, info) + call psb_realloc(thread_upperbound, col_inds, info) + + ! possible bottleneck + acc = 0 + + nnz = 0 + !$omp do schedule(static) private(irw,jj,j,k,rwnz,blk,blk_size,rwstart) + do blk = 0, nblks - 1 + if (blk < rwblkrem) then + blk_size = rwblk + 1 + rwstart = blk * rwblk + blk + 1 + else + blk_size = rwblk + rwstart = blk * rwblk & + + rwblkrem + 1 + end if + do irw = rwstart, rwstart + blk_size - 1 + if (start_idx == 0) then + start_idx = irw + end if + end_idx = irw + rwnz = 0 + do jj = a%irp(irw), a%irp(irw + 1) - 1 + j = a%ja(jj) + do k = b%irp(j), b%irp(j + 1) - 1 + if (acc(b%ja(k)) == 0) then + nnz = nnz + 1 + rwnz = rwnz + 1 + col_inds(nnz) = b%ja(k) + end if + acc(b%ja(k)) = acc(b%ja(k)) + a%val(jj) * b%val(k) + end do + end do + call psb_qsort(col_inds(nnz - rwnz + 1:nnz)) + + do k = nnz - rwnz + 1, nnz + vals(k) = acc(col_inds(k)) + acc(col_inds(k)) = 0 + end do + c%irp(irw + 1) = rwnz + end do + end do + !$omp end do + + offsets(omp_get_thread_num() + 1) = nnz + !$omp barrier + + ! possible bottleneck + !$omp single + do k = 1, omp_get_num_threads() - 1 + offsets(k + 1) = offsets(k + 1) + offsets(k) + end do + !$omp end single + + !$omp barrier + + if (omp_get_thread_num() /= 0) then + c%irp(start_idx) = offsets(omp_get_thread_num()) + 1 + end if + + do irw = start_idx, end_idx - 1 + c%irp(irw + 1) = c%irp(irw + 1) + c%irp(irw) + end do + + !$omp barrier + + !$omp single + c%irp(ma + 1) = c%irp(ma + 1) + c%irp(ma) + call psb_realloc(c%irp(ma + 1), c%val, info) + call psb_realloc(c%irp(ma + 1), c%ja, info) + !$omp end single + + c%val(c%irp(start_idx):c%irp(end_idx + 1) - 1) = vals(1:nnz) + c%ja(c%irp(start_idx):c%irp(end_idx + 1) - 1) = col_inds(1:nnz) + !$omp end parallel + end subroutine spmm_omp_gustavson_1d + + subroutine spmm_serial_rb_tree(a,b,c,info) + use psb_rb_idx_tree_mod + implicit none + type(psb_d_csr_sparse_mat), intent(in) :: a,b + type(psb_d_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: a_m, b_n + integer(psb_ipk_) :: row, col + type(psb_d_rb_idx_tree), allocatable :: row_accs(:) + + a_m = a%get_nrows() + b_n = b%get_ncols() + + allocate(row_accs(a_m)) + call c%allocate(a_m, b_n) + + do row = 1, a_m + row_accs(row)%nnz = 0 + nullify(row_accs(row)%root) + do col = a%irp(row), a%irp(row + 1) - 1 + call psb_rb_idx_tree_scalar_sparse_row_mul(row_accs(row), a%val(col), b, a%ja(col)) + end do + end do + call psb_rb_idx_tree_merge(row_accs, c) + + deallocate(row_accs) + + info = 0 + end subroutine spmm_serial_rb_tree + + subroutine spmm_omp_rb_tree(a,b,c,info) + use omp_lib + use psb_rb_idx_tree_mod + implicit none + type(psb_d_csr_sparse_mat), intent(in) :: a,b + type(psb_d_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: a_m, b_n + integer(psb_ipk_) :: row, col + type(psb_d_rb_idx_tree), allocatable :: row_accs(:) + real(8) :: tic, toc + + a_m = a%get_nrows() + b_n = b%get_ncols() + + call c%allocate(a_m, b_n) + + allocate(row_accs(a_m)) + call c%allocate(a_m, b_n) + + !$omp parallel do schedule(static) + do row = 1, a_m + row_accs(row)%nnz = 0 + nullify(row_accs(row)%root) + do col = a%irp(row), a%irp(row + 1) - 1 + call psb_rb_idx_tree_scalar_sparse_row_mul(row_accs(row), a%val(col), b, a%ja(col)) + end do + end do + !$omp end parallel do + + call psb_rb_idx_tree_merge(row_accs, c) + + deallocate(row_accs) + info = 0 + end subroutine spmm_omp_rb_tree + + subroutine compute_indices(a, b, c, info) + implicit none + type(psb_d_csr_sparse_mat), intent(in) :: a,b + type(psb_d_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + integer :: full_mat_bound + integer :: row, col, i, j, k, nnz + + full_mat_bound = 0 + !omp parallel do schedule(static) reduction(+:full_mat_bound) + do row = 1, a%get_nrows() + do col = a%irp(row), a%irp(row + 1) - 1 + j = a%ja(col) + full_mat_bound = full_mat_bound + b%irp(j+1) - b%irp(j) + end do + end do + !omp end parallel do + + call psb_realloc(a%get_nrows() + 1, c%irp, info) + call psb_realloc(full_mat_bound, c%ja, info) + c%ja = 0 + c%irp(1) = 1 + + nnz = 0 + + do row = 1, a%get_nrows() + do col = a%irp(row), a%irp(row + 1) - 1 + do i = b%irp(a%ja(col)), b%irp(a%ja(col) + 1) - 1 + k = 0 + do while(c%ja(c%irp(row) + k) /= 0 .and. c%ja(c%irp(row) + k) /= b%ja(i)) + k = k + 1 + end do + if (c%ja(c%irp(row) + k) == 0) then + c%ja(c%irp(row)+k) = b%ja(i) + nnz = nnz + 1 + end if + end do + end do + c%irp(row + 1) = nnz + 1 + call psb_qsort(c%ja(c%irp(row):c%irp(row + 1)-1)) + end do + + + call psb_realloc(nnz, c%ja, info) + call psb_realloc(nnz, c%val, info) + + c%val = 0 + end subroutine compute_indices + + subroutine direct_scalar_sparse_row_mul(out_mat, out_row_num, scalar, mat, trgt_row_num) + type(psb_d_csr_sparse_mat), intent(inout) :: out_mat + integer(psb_ipk_), intent(in) :: out_row_num + real(psb_dpk_), intent(in) :: scalar + type(psb_d_csr_sparse_mat), intent(in) :: mat + integer(psb_ipk_), intent(in) :: trgt_row_num + + integer(psb_ipk_) :: i, k, row_start, row_end + + row_start = out_mat%irp(out_row_num) + row_end = out_mat%irp(out_row_num + 1) - 1 + + do i = mat%irp(trgt_row_num), mat%irp(trgt_row_num + 1) - 1 + do k = out_mat%irp(out_row_num), out_mat%irp(out_row_num + 1) - 1 + if (out_mat%ja(k) == mat%ja(i)) then + out_mat%val(k) = out_mat%val(k) + scalar * mat%val(i) + exit + end if + end do + end do + + end subroutine direct_scalar_sparse_row_mul + + subroutine spmm_omp_two_pass(a,b,c,info) + use omp_lib + + implicit none + type(psb_d_csr_sparse_mat), intent(in) :: a,b + type(psb_d_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: a_m, b_n, row, col + + a_m = a%get_nrows() + b_n = b%get_ncols() + + call c%allocate(a_m, b_n) + + call compute_indices(a, b, c, info) + + !$omp parallel do schedule(static) + do row = 1, a_m + do col = a%irp(row), a%irp(row + 1) - 1 + call direct_scalar_sparse_row_mul(c, row, a%val(col), b, a%ja(col)) + end do + end do + !$omp end parallel do + end subroutine spmm_omp_two_pass + +end subroutine psb_dcsrspspmm + +#else + subroutine psb_dcsrspspmm(a,b,c,info) use psb_d_mat_mod use psb_serial_mod, psb_protect_name => psb_dcsrspspmm @@ -3810,7 +4571,6 @@ subroutine psb_d_cp_ecsr_from_fmt(a,b,info) end subroutine psb_d_cp_ecsr_from_fmt - ! ! ! ld version diff --git a/base/serial/impl/psb_d_rb_idx_tree_impl.F90 b/base/serial/impl/psb_d_rb_idx_tree_impl.F90 new file mode 100644 index 000000000..9b63d51cc --- /dev/null +++ b/base/serial/impl/psb_d_rb_idx_tree_impl.F90 @@ -0,0 +1,329 @@ +! +! 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. +! +! +! +! package: psb_d_rb_idx_tree_impl +! +! Red black tree implementation ordered by index +! +! Each node contains and index and a double precision value +! +! The tree should always be well balanced +! +! inserting a node with an existing index will +! add up the new value to the old one +! Contributed by Dimitri Walther +! +subroutine psb_d_rb_idx_tree_insert(this, idx, val) + use psb_d_rb_idx_tree_mod, psb_protect_name => psb_d_rb_idx_tree_insert + implicit none + class(psb_d_rb_idx_tree), intent(inout) :: this + integer(psb_ipk_), intent(in) :: idx + real(psb_dpk_), intent(in) :: val + + character(len=22) :: name + type(psb_d_rb_idx_node), pointer :: new_node + type(psb_d_rb_idx_node), pointer :: current, previous + name='psb_rb_idx_tree_insert' + + allocate(new_node) + new_node%idx = idx + new_node%val = val + nullify(new_node%left) + nullify(new_node%right) + nullify(new_node%parent) + new_node%is_red = .true. + + + if (.not. associated(this%root)) then + this%root => new_node + this%nnz = 1 + new_node%is_red = .false. + return + end if + + current => this%root + + do while (associated(current)) + previous => current + + if (idx == current%idx) then + current%val = current%val + val + deallocate(new_node) + return + else if (idx < current%idx) then + current => current%left + else + + current => current%right + end if + end do + + if (idx < previous%idx) then + new_node%parent => previous + previous%left => new_node + else + new_node%parent => previous + previous%right => new_node + end if + + call psb_d_rb_idx_tree_fix_insertion(this, new_node) + + this%nnz = this%nnz + 1 +end subroutine psb_d_rb_idx_tree_insert + +subroutine psb_d_rb_idx_tree_fix_insertion(this, node) + use psb_d_rb_idx_tree_mod, psb_protect_name => psb_d_rb_idx_tree_fix_insertion + implicit none + class(psb_d_rb_idx_tree), intent(inout) :: this + type(psb_d_rb_idx_node), pointer, intent(inout) :: node + + character(len=29) :: name + type(psb_d_rb_idx_node), pointer :: current, parent, grand_parent, uncle + name = 'psb_rb_idx_tree_fix_insertion' + + current => node + parent => current%parent + do while(associated(parent) .and. parent%is_red) + ! grand parent exist because root can't be red + grand_parent => parent%parent + if (parent%idx < grand_parent%idx) then + uncle => grand_parent%right + else + uncle => grand_parent%left + end if + + if (associated(uncle) .and. uncle%is_red) then + parent%is_red = .false. + uncle%is_red = .false. + grand_parent%is_red = .true. + current => grand_parent + parent => current%parent + + ! Left-Left case + else if (current%idx < parent%idx .and. & + parent%idx < grand_parent%idx) then + call psb_d_rb_idx_tree_rotate_right(grand_parent) + call psb_d_rb_idx_tree_swap_colors(parent, grand_parent) + + if (this%root%idx == grand_parent%idx) this%root => parent + + return + ! Left-Right case + else if (current%idx > parent%idx .and. & + parent%idx < grand_parent%idx) then + call psb_d_rb_idx_tree_rotate_left(parent) + call psb_d_rb_idx_tree_rotate_right(grand_parent) + call psb_d_rb_idx_tree_swap_colors(current, grand_parent) + + if (this%root%idx == grand_parent%idx) this%root => current + + return + ! Right-Right case + else if (current%idx > parent%idx .and. & + parent%idx > grand_parent%idx) then + call psb_d_rb_idx_tree_rotate_left(grand_parent) + call psb_d_rb_idx_tree_swap_colors(parent, grand_parent) + + if (this%root%idx == grand_parent%idx) this%root => parent + + return + ! Right-Left case + else + call psb_d_rb_idx_tree_rotate_right(parent) + call psb_d_rb_idx_tree_rotate_left(grand_parent) + call psb_d_rb_idx_tree_swap_colors(current, grand_parent) + + if (this%root%idx == grand_parent%idx) this%root => current + + return + end if + end do + + this%root%is_red = .false. +end subroutine psb_d_rb_idx_tree_fix_insertion + +subroutine psb_d_rb_idx_tree_swap_colors(n1, n2) + use psb_d_rb_idx_tree_mod, psb_protect_name => psb_d_rb_idx_tree_swap_colors + implicit none + type(psb_d_rb_idx_node), pointer, intent(inout) :: n1, n2 + + character(len=27) :: name + logical :: tmp + name='psb_rb_idx_tree_swap_colors' + + tmp = n1%is_red + n1%is_red = n2%is_red + n2%is_red = tmp +end subroutine psb_d_rb_idx_tree_swap_colors + +subroutine psb_d_rb_idx_tree_rotate_right(node) + use psb_d_rb_idx_tree_mod, psb_protect_name => psb_d_rb_idx_tree_rotate_right + implicit none + type(psb_d_rb_idx_node), pointer, intent(inout) :: node + + character(len=28) :: name + type(psb_d_rb_idx_node), pointer :: l, lr + name='psb_rb_idx_tree_rotate_right' + + if (.not. associated(node%left)) return + + l => node%left + lr => l%right + node%left => lr + + if (associated(lr)) lr%parent => node + + if (associated(node%parent)) then + if (node%idx < node%parent%idx) then + node%parent%left => l + else + node%parent%right => l + end if + end if + + l%parent => node%parent + node%parent => l + + l%right => node +end subroutine psb_d_rb_idx_tree_rotate_right + +subroutine psb_d_rb_idx_tree_rotate_left(node) + use psb_d_rb_idx_tree_mod, psb_protect_name => psb_d_rb_idx_tree_rotate_left + implicit none + type(psb_d_rb_idx_node), pointer, intent(inout) :: node + + character(len=27) :: name + type(psb_d_rb_idx_node), pointer :: r, rl + name='psb_rb_idx_tree_rotate_left' + + if (.not. associated(node%right)) return + + r => node%right + rl => r%left + node%right => rl + + if (associated(rl)) rl%parent => node + + if (associated(node%parent)) then + if (node%idx < node%parent%idx) then + node%parent%left => r + else + node%parent%right => r + end if + end if + + r%parent => node%parent + node%parent => r + + r%left => node +end subroutine psb_d_rb_idx_tree_rotate_left + +subroutine psb_d_rb_idx_tree_scalar_sparse_row_mul(tree, scalar, mat, row_num) + use psb_d_rb_idx_tree_mod, psb_protect_name => psb_d_rb_idx_tree_scalar_sparse_row_mul + use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat + implicit none + type(psb_d_rb_idx_tree), intent(inout) :: tree + real(psb_dpk_), intent(in) :: scalar + type(psb_d_csr_sparse_mat), intent(in) :: mat + integer(psb_ipk_), intent(in) :: row_num + + character(len=37) :: name + integer(psb_ipk_) :: i + name='psb_rb_idx_tree_scalar_sparse_row_mul' + + do i = mat%irp(row_num), mat%irp(row_num + 1) - 1 + call tree%insert(mat%ja(i),scalar * mat%val(i)) + end do + +end subroutine psb_d_rb_idx_tree_scalar_sparse_row_mul + +subroutine psb_d_rb_idx_tree_merge(trees, mat) +#if defined(OPENMP) + use omp_lib +#endif + use psb_realloc_mod + use psb_d_rb_idx_tree_mod, psb_protect_name => psb_d_rb_idx_tree_merge + use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat + implicit none + type(psb_d_rb_idx_tree), allocatable, intent(inout) :: trees(:) + type(psb_d_csr_sparse_mat), intent(inout) :: mat + + character(len=21) :: name + integer(psb_ipk_) :: i, j, rows, info, nnz + type(psb_d_rb_idx_node), pointer :: current, previous + name='psb_rb_idx_tree_merge' + + rows = size(trees) + + mat%irp(1) = 1 + + do i=1, rows + mat%irp(i + 1) = mat%irp(i) + trees(i)%nnz + end do + + nnz = mat%irp(rows + 1) + call psb_realloc(nnz, mat%val, info) + call psb_realloc(nnz, mat%ja, info) + +#if defined(OPENMP) + !$omp parallel do schedule(static), private(current, previous, j) +#endif + do i = 1, size(trees) + j = 0 + current => trees(i)%root + do while(associated(current)) + ! go to the left-most node + do while(associated(current%left)) + current => current%left + end do + mat%val(j + mat%irp(i)) = current%val + mat%ja(j + mat%irp(i)) = current%idx + j = j + 1 + + previous => current + if (associated(current%right)) then + if (associated(current%parent)) then + current%parent%left => current%right + end if + current%right%parent => current%parent + current => current%right + else + current => current%parent + if (associated(current)) nullify(current%left) + end if + deallocate(previous) + end do + end do +#if defined(OPENMP) + !$omp end parallel do +#endif +end subroutine psb_d_rb_idx_tree_merge diff --git a/base/serial/impl/psb_s_coo_impl.F90 b/base/serial/impl/psb_s_coo_impl.F90 index 7be72cce5..402c608a6 100644 --- a/base/serial/impl/psb_s_coo_impl.F90 +++ b/base/serial/impl/psb_s_coo_impl.F90 @@ -2817,6 +2817,9 @@ subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_realloc_mod use psb_sort_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_csput_a +#if defined(OPENMP) + use omp_lib +#endif implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a @@ -2828,7 +2831,7 @@ subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) integer(psb_ipk_) :: err_act character(len=20) :: name='s_coo_csput_a_impl' logical, parameter :: debug=.false. - integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit + integer(psb_ipk_) :: nza, i,j,k, nzl, isza, nzaold, debug_level, debug_unit info = psb_success_ debug_unit = psb_get_debug_unit() @@ -2860,10 +2863,13 @@ subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) if (nz == 0) return - - nza = a%get_nzeros() - isza = a%get_size() if (a%is_bld()) then + ! Structure here is peculiar, because this function can be called + ! either within a parallel region, or outside. + ! Hence the call to set_nzeros done here. + !$omp critical + nza = a%get_nzeros() + isza = a%get_size() ! Build phase. Must handle reallocations in a sensible way. if (isza < (nza+nz)) then call a%reallocate(max(nza+nz,int(1.5*isza))) @@ -2871,16 +2877,20 @@ subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) isza = a%get_size() if (isza < (nza+nz)) then info = psb_err_alloc_dealloc_; call psb_errpush(info,name) - goto 9999 + else + nzaold = nza + nza = nza + nz + call a%set_nzeros(nza) end if - - call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& + !$omp end critical + if (info /= 0) goto 9999 + call psb_inner_ins(nz,ia,ja,val,nzaold,a%ia,a%ja,a%val,isza,& & imin,imax,jmin,jmax,info) - call a%set_nzeros(nza) call a%set_sorted(.false.) - - + else if (a%is_upd()) then + nza = a%get_nzeros() + isza = a%get_size() if (a%is_dev()) call a%sync() @@ -2949,7 +2959,6 @@ contains end if end do !$OMP END PARALLEL DO - nza = nza + nz #else do i=1, nz @@ -3478,6 +3487,602 @@ subroutine psb_s_coo_mv_from(a,b) end subroutine psb_s_coo_mv_from +! +! COO implementation of tril/triu +! +subroutine psb_s_coo_tril(a,l,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,u) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_tril + implicit none + + class(psb_s_coo_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_s_coo_sparse_mat), optional, intent(out) :: u + + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k + integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + character(len=20) :: name='tril' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + +#if defined(OPENMP) + block + integer(psb_ipk_), allocatable :: lrws(:),urws(:) + integer(psb_ipk_) :: lpnt, upnt, lnz, unz + call psb_realloc(mb,lrws,info) + !$omp workshare + lrws(:) = 0 + !$omp end workshare + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + !write(0,*) 'Invocation of COO%TRIL', present(u),nz + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + if (info == 0) call psb_realloc(mb,urws,info) + !$omp workshare + urws(:) = 0 + !$omp end workshare + !write(0,*) 'omp version of COO%TRIL/TRIU' + lnz = 0 + unz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws,urws) reduction(+: lnz,unz) + loop1: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic update + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + !$omp end atomic + lnz = lnz + 1 + else + !$omp atomic update + urws(i-imin_+1) = urws(i-imin_+1) +1 + !$omp end atomic + unz = unz + 1 + end if + end if + end do loop1 + !$omp end parallel do + + call psi_exscan(mb,lrws,info) + call psi_exscan(mb,urws,info) + !write(0,*) lrws(:), urws(:) + !$omp parallel do private(i,j,k,lpnt,upnt) shared(imin_,imax_,a) + loop2: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic capture + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + lpnt = lrws(i-imin_+1) + !$omp end atomic + l%ia(lpnt) = a%ia(k) + l%ja(lpnt) = a%ja(k) + l%val(lpnt) = a%val(k) + else + !$omp atomic capture + urws(i-imin_+1) = urws(i-imin_+1) +1 + upnt = urws(i-imin_+1) + !$omp end atomic + u%ia(upnt) = a%ia(k) + u%ja(upnt) = a%ja(k) + u%val(upnt) = a%val(k) + end if + end if + end do loop2 + !$omp end parallel do + !write(0,*) 'End of copyout',lnz,unz + call l%set_nzeros(lnz) + call l%fix(info) + call u%set_nzeros(unz) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) then + !$omp workshare + u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + if ((diag_ >=-1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + lnz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws) reduction(+: lnz) + loop3: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic update + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + !$omp end atomic + lnz = lnz + 1 + end if + end if + end do loop3 + !$omp end parallel do + call psi_exscan(mb,lrws,info) + !$omp parallel do private(i,j,k,lpnt) shared(imin_,imax_,a) + loop4: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic capture + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + lpnt = lrws(i-imin_+1) + !$omp end atomic + l%ia(lpnt) = a%ia(k) + l%ja(lpnt) = a%ja(k) + l%val(lpnt) = a%val(k) + end if + end if + end do loop4 + !$omp end parallel do + call l%set_nzeros(lnz) + call l%fix(info) + end if + nzout = l%get_nzeros() + if (rscale_) then + !$omp workshare + l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if + end block + +#else + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, ia=>a%ia) + loop1: do k=1,nz + i = ia(k) + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + nzlin = nzlin + 1 + l%ia(nzlin) = i + l%ja(nzlin) = ja(k) + l%val(nzlin) = val(k) + else + nzuin = nzuin + 1 + u%ia(nzuin) = i + u%ja(nzuin) = ja(k) + u%val(nzuin) = val(k) + end if + end if + end do loop1 + end associate + + call l%set_nzeros(nzlin) + call u%set_nzeros(nzuin) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >=-1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + nzin = l%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, ia=>a%ia) + loop2: do k=1,nz + i = ia(k) + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + nzin = nzin + 1 + l%ia(nzin) = i + l%ja(nzin) = ja(k) + l%val(nzin) = val(k) + end if + end if + end do loop2 + end associate + call l%set_nzeros(nzin) + end if + call l%fix(info) + nzout = l%get_nzeros() + if (rscale_) & + & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if +#endif + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_coo_tril + +subroutine psb_s_coo_triu(a,u,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,l) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_triu + implicit none + + class(psb_s_coo_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_s_coo_sparse_mat), optional, intent(out) :: l + + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k + integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + character(len=20) :: name='triu' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + +#if defined(OPENMP) + block + integer(psb_ipk_), allocatable :: lrws(:),urws(:) + integer(psb_ipk_) :: lpnt, upnt, lnz, unz + call psb_realloc(mb,urws,info) + !$omp workshare + urws(:) = 0 + !$omp end workshare + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + !write(0,*) 'Invocation of COO%TRIL', present(u),nz + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + if (info == 0) call psb_realloc(mb,urws,info) + !$omp workshare + lrws(:) = 0 + !$omp end workshare + !write(0,*) 'omp version of COO%TRIL/TRIU' + lnz = 0 + unz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws,urws) reduction(+: lnz,unz) + loop1: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)>=diag_) then + !$omp atomic update + urws(i-imin_+1) = urws(i-imin_+1) +1 + !$omp end atomic + unz = unz + 1 + end if + end if + end do loop3 + !$omp end parallel do + call psi_exscan(mb,urws,info) + !$omp parallel do private(i,j,k,upnt) shared(imin_,imax_,a) + loop4: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)>=diag_) then + !$omp atomic capture + urws(i-imin_+1) = urws(i-imin_+1) +1 + upnt = urws(i-imin_+1) + !$omp end atomic + u%ia(upnt) = a%ia(k) + u%ja(upnt) = a%ja(k) + u%val(upnt) = a%val(k) + end if + end if + end do loop4 + !$omp end parallel do + call u%set_nzeros(unz) + call u%fix(info) + end if + nzout = u%get_nzeros() + if (rscale_) then + !$omp workshare + u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + + if ((diag_ >= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_upper(.true.) + end if + end block + + +#else + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, ia=>a%ia) + loop1: do k=1,nz + i = ia(k) + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)a%val, ja => a%ja, ia=>a%ia) + loop2: do k=1,nz + i = ia(k) + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)>=diag_) then + nzin = nzin + 1 + u%ia(nzin) = i + u%ja(nzin) = ja(k) + u%val(nzin) = val(k) + end if + end if + end do loop2 + end associate + call u%set_nzeros(nzin) + end if + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + + if ((diag_ >= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if +#endif + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_coo_triu + subroutine psb_s_fix_coo(a,info,idir) use psb_const_mod @@ -3561,7 +4166,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) character(len=20) :: name = 'psb_fixcoo' logical :: srt_inp, use_buffers #if defined(OPENMP) - integer(psb_ipk_) :: work,first_idx,last_idx,first_elem,last_elem,s,nthreads,ithread + integer(psb_ipk_) :: work,idxstart,idxend,first_elem,last_elem,s,nthreads,ithread integer(psb_ipk_) :: saved_elem,old_val,nxt_val,err,act_row,act_col,maxthreads integer(psb_ipk_), allocatable :: sum(:),kaux(:),idxaux(:) #endif @@ -3620,8 +4225,6 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ! Dirty trick: call ROWMAJOR with rows <-> columns call psb_s_fix_coo_inner_rowmajor(nc,nr,nzin,dupl,& & ja,ia,val,iaux,nzout,info) -!!$ call psb_s_fix_coo_inner_colmajor(nr,nc,nzin,dupl,& -!!$ & ia,ja,val,iaux,nzout,info) case default write(debug_unit,*) trim(name),': unknown direction ',idir_ info = psb_err_internal_error_ @@ -3660,12 +4263,13 @@ subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf integer(psb_ipk_), allocatable :: ias(:),jas(:), ix2(:) real(psb_spk_), allocatable :: vs(:) integer(psb_ipk_) :: nza, nzl,iret - integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii + integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii, i1, i2 integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name = 'psb_fixcoo' logical :: srt_inp, use_buffers + real(psb_dpk_) :: t0, t1 #if defined(OPENMP) - integer(psb_ipk_) :: work,first_idx,last_idx,first_elem,last_elem,s,nthreads,ithread + integer(psb_ipk_) :: work,idxstart,idxend,first_elem,last_elem,s,nthreads,ithread integer(psb_ipk_) :: saved_elem,old_val,nxt_val,err,act_row,act_col,maxthreads integer(psb_ipk_), allocatable :: sum(:),kaux(:),idxaux(:) #endif @@ -3747,9 +4351,9 @@ subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf ! Here, starting from 'iaux', we apply a fixing in order to obtain the starting ! index for each row. We do the same on 'kaux' !$OMP PARALLEL default(none) & - !$OMP shared(idxaux,ia,ja,val,ias,jas,vs,nthreads,sum,nr,nc,nzin,iaux,kaux,dupl,err) & - !$OMP private(s,i,j,k,ithread,first_idx,last_idx,work,nxt_val,old_val,saved_elem, & - !$OMP first_elem,last_elem,nzl,iret,act_row) + !$OMP shared(t0,t1,idxaux,ia,ja,val,ias,jas,vs,nthreads,sum,nr,nc,nzin,iaux,kaux,dupl,err) & + !$OMP private(s,i,j,k,ithread,idxstart,idxend,work,nxt_val,old_val,saved_elem, & + !$OMP first_elem,last_elem,nzl,iret,act_row,i1,i2) reduction(max: info) !$OMP SINGLE nthreads = omp_get_num_threads() @@ -3762,81 +4366,46 @@ subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf work = nr/nthreads if (ithread < MOD(nr,nthreads)) then work = work + 1 - first_idx = ithread*work + 1 + idxstart = ithread*work + 1 else - first_idx = ithread*work + MOD(nr,nthreads) + 1 + idxstart = ithread*work + MOD(nr,nthreads) + 1 end if - last_idx = first_idx + work - 1 - - !------------------------------------------- - ! ------------ iaux composition -------------- - ! 'iaux' will have the start index for each row - - s = 0 - do i=first_idx,last_idx - s = s + iaux(i) - end do - sum(ithread+2) = s + idxend = idxstart + work - 1 + !write(0,*) 'fix_coo_inner: trying with exscan' + call psi_exscan(nr+1,iaux,info,shift=ione) !$OMP BARRIER - !$OMP SINGLE - do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) - end do + !t0 = omp_get_wtime() !$OMP END SINGLE - - if (work > 0) then - saved_elem = iaux(first_idx) - end if - - if (ithread == 0) then - iaux(1) = 1 - end if - - !$OMP BARRIER - - if (work > 0) then - old_val = iaux(first_idx+1) - iaux(first_idx+1) = saved_elem + sum(ithread+1) - end if - - do i=first_idx+2,last_idx+1 - nxt_val = iaux(i) - iaux(i) = iaux(i-1) + old_val - old_val = nxt_val - end do - - ! -------------------------------------- - - !$OMP BARRIER - + ! ------------------ Sorting and buffers ------------------- ! Let's use an auxiliary buffer, 'idxaux', to get indices leaving ! unmodified 'iaux' - do j=first_idx,last_idx + do j=idxstart,idxend idxaux(j) = iaux(j) end do - ! Here we sort data inside the auxiliary buffers do i=1,nzin act_row = ia(i) - if ((act_row >= first_idx) .and. (act_row <= last_idx)) then + if ((act_row >= idxstart) .and. (act_row <= idxend)) then ias(idxaux(act_row)) = ia(i) jas(idxaux(act_row)) = ja(i) vs(idxaux(act_row)) = val(i) - idxaux(act_row) = idxaux(act_row) + 1 end if end do !$OMP BARRIER - + !$OMP SINGLE + !t1 = omp_get_wtime() + !write(0,*) ithread,'Srt&Cpy :',t1-t0 + !$OMP END SINGLE ! Let's sort column indices and values. After that we will store ! the number of unique values in 'kaux' - do j=first_idx,last_idx + do j=idxstart,idxend first_elem = iaux(j) last_elem = iaux(j+1) - 1 nzl = last_elem - first_elem + 1 @@ -3865,45 +4434,7 @@ subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf ! -------------------------------------------------- ! ---------------- kaux composition ---------------- - !$OMP SINGLE - sum(:) = 0 - sum(1) = 1 - !$OMP END SINGLE - - s = 0 - do i=first_idx,last_idx - s = s + kaux(i) - end do - sum(ithread+2) = s - - !$OMP BARRIER - - !$OMP SINGLE - do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) - end do - kaux(nr+1) = sum(nthreads+1) - !$OMP END SINGLE - - if (work > 0) then - saved_elem = kaux(first_idx) - end if - if (ithread == 0) then - kaux(1) = 1 - end if - - !$OMP BARRIER - - if (work > 0) then - old_val = kaux(first_idx+1) - kaux(first_idx+1) = saved_elem + sum(ithread+1) - end if - - do i=first_idx+2,last_idx+1 - nxt_val = kaux(i) - kaux(i) = kaux(i-1) + old_val - old_val = nxt_val - end do + call psi_exscan(nr+1,kaux,i,shift=ione) !$OMP BARRIER @@ -3911,7 +4442,7 @@ subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf select case(dupl) case(psb_dupl_ovwrt_) - !$OMP DO schedule(STATIC) + !$OMP DO schedule(dynamic,32) do j=1,nr first_elem = iaux(j) last_elem = iaux(j+1) - 1 @@ -3940,7 +4471,7 @@ subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf !$OMP END DO case(psb_dupl_add_) - !$OMP DO schedule(STATIC) + !$OMP DO schedule(dynamic,32) do j=1,nr first_elem = iaux(j) last_elem = iaux(j+1) - 1 @@ -3969,7 +4500,7 @@ subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf !$OMP END DO case(psb_dupl_err_) - !$OMP DO schedule(STATIC) + !$OMP DO schedule(dynamic,32) do j=1,nr first_elem = iaux(j) last_elem = iaux(j+1) - 1 @@ -4174,7 +4705,7 @@ subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf #if defined(OPENMP) !$OMP PARALLEL default(none) & !$OMP shared(nr,nc,nzin,iaux,ia,ja,val,nthreads) & - !$OMP private(i,j,first_idx,last_idx,nzl,act_row,iret,ithread, & + !$OMP private(i,j,idxstart,idxend,nzl,act_row,iret,ithread, & !$OMP work,first_elem,last_elem) !$OMP SINGLE @@ -4188,22 +4719,22 @@ subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf work = nr/nthreads if (ithread < MOD(nr,nthreads)) then work = work + 1 - first_idx = ithread*work + 1 + idxstart = ithread*work + 1 else - first_idx = ithread*work + MOD(nr,nthreads) + 1 + idxstart = ithread*work + MOD(nr,nthreads) + 1 end if - last_idx = first_idx + work - 1 + idxend = idxstart + work - 1 ! --------------------------------------------------- first_elem = 0 last_elem = -1 - act_row = first_idx + act_row = idxstart do j=1,nzin if (ia(j) < act_row) then cycle - else if ((ia(j) > last_idx) .or. (work < 1)) then + else if ((ia(j) > idxend) .or. (work < 1)) then exit else if (ia(j) > act_row) then nzl = last_elem - first_elem + 1 @@ -4333,684 +4864,14 @@ subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf end subroutine psb_s_fix_coo_inner_rowmajor -subroutine psb_s_fix_coo_inner_colmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,info) - use psb_const_mod + +subroutine psb_s_cp_coo_to_lcoo(a,b,info) use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_s_fix_coo_inner_colmajor - use psb_string_mod - use psb_ip_reord_mod - use psb_sort_mod -#if defined(OPENMP) - use omp_lib -#endif + use psb_s_base_mat_mod, psb_protect_name => psb_s_cp_coo_to_lcoo implicit none - - integer(psb_ipk_), intent(in) :: nr, nc, nzin, dupl - integer(psb_ipk_), intent(inout) :: ia(:), ja(:), iaux(:) - real(psb_spk_), intent(inout) :: val(:) - integer(psb_ipk_), intent(out) :: nzout, info - !locals - integer(psb_ipk_), allocatable :: ias(:),jas(:), ix2(:) - real(psb_spk_), allocatable :: vs(:) - integer(psb_ipk_) :: nza, nzl,iret - integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name = 'psb_fixcoo' - logical :: srt_inp, use_buffers -#if defined(OPENMP) - integer(psb_ipk_) :: work,first_idx,last_idx,first_elem,last_elem,s,nthreads,ithread - integer(psb_ipk_) :: saved_elem,old_val,nxt_val,err,act_row,act_col,maxthreads - integer(psb_ipk_), allocatable :: sum(:),kaux(:),idxaux(:) -#endif - info = psb_success_ - - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if (nc <= nzin) then - ! Avoid strange situations with large indices -#if defined(OPENMP) - allocate(ias(nzin),jas(nzin),vs(nzin), stat=info) -#else - allocate(ias(nzin),jas(nzin),vs(nzin),ix2(nzin+2), stat=info) -#endif - use_buffers = (info == 0) - else - use_buffers = .false. - end if - - if (use_buffers) then - iaux(:) = 0 -#if defined(OPENMP) - !$OMP PARALLEL DO default(none) schedule(STATIC) & - !$OMP shared(nzin,ja,nc,iaux) & - !$OMP private(i) & - !$OMP reduction(.and.:use_buffers) - do i=1,nzin - if ((ja(i) < 1).or.(ja(i) > nc)) then - use_buffers = .false. - ! Invalid indices are placed outside the considered range - ja(i) = nc+2 - else - !$OMP ATOMIC UPDATE - iaux(ja(i)) = iaux(ja(i)) + 1 - end if - end do - !$OMP END PARALLEL DO -#else - !srt_inp = .true. - do i=1,nzin - if ((ja(i) < 1).or.(ja(i) > nc)) then - use_buffers = .false. - !ja(i) = nc+2 - !srt_inp = .false. - exit - end if - - iaux(ja(i)) = iaux(ja(i)) + 1 - - !srt_inp = srt_inp .and.(ja(i-1)<=ja(i)) - end do -#endif - end if - - !use_buffers=use_buffers.and.srt_inp - - ! Check again use_buffers. We enter here if nzin >= nc and - ! all the indices are valid - if (use_buffers) then -#if defined(OPENMP) - allocate(kaux(MAX(nzin,nc)+2),idxaux(MAX((nr+2)*maxthreads,nc)),sum(maxthreads+1),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - kaux(:) = 0 - sum(:) = 0 - sum(1) = 1 - err = 0 - - ! Here, starting from 'iaux', we apply a fixing in order to obtain the starting - ! index for each column. We do the same on 'kaux' - !$OMP PARALLEL default(none) & - !$OMP shared(idxaux,ia,ja,val,ias,jas,vs,nthreads,sum,nr,nc,nzin,iaux,kaux,dupl,err) & - !$OMP private(s,i,j,k,ithread,first_idx,last_idx,work,nxt_val,old_val,saved_elem, & - !$OMP first_elem,last_elem,nzl,iret,act_col) - - !$OMP SINGLE - nthreads = omp_get_num_threads() - !$OMP END SINGLE - - ithread = omp_get_thread_num() - - ! -------- thread-specific workload -------- - - work = nc/nthreads - if (ithread < MOD(nc,nthreads)) then - work = work + 1 - first_idx = ithread*work + 1 - else - first_idx = ithread*work + MOD(nc,nthreads) + 1 - end if - - last_idx = first_idx + work - 1 - - !------------------------------------------- - ! ---------- iaux composition -------------- - - s = 0 - do i=first_idx,last_idx - s = s + iaux(i) - end do - sum(ithread+2) = s - - !$OMP BARRIER - - !$OMP SINGLE - do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) - end do - !$OMP END SINGLE - - if (work > 0) then - saved_elem = iaux(first_idx) - end if - if (ithread == 0) then - iaux(1) = 1 - end if - - !$OMP BARRIER - - if (work > 0) then - old_val = iaux(first_idx+1) - iaux(first_idx+1) = saved_elem + sum(ithread+1) - end if - - do i=first_idx+2,last_idx+1 - nxt_val = iaux(i) - iaux(i) = iaux(i-1) + old_val - old_val = nxt_val - end do - - ! -------------------------------------- - - !$OMP BARRIER - - ! ------------------ Sorting and buffers ------------------- - - ! Let's use an auxiliary buffer to get indices - do j=first_idx,last_idx - idxaux(j) = iaux(j) - end do - - ! Here we sort data inside the auxiliary buffers - do i=1,nzin - act_col = ja(i) - if (act_col >= first_idx .and. act_col <= last_idx) then - ias(idxaux(act_col)) = ia(i) - jas(idxaux(act_col)) = ja(i) - vs(idxaux(act_col)) = val(i) - - idxaux(act_col) = idxaux(act_col) + 1 - end if - end do - - !$OMP BARRIER - - ! Let's sort column indices and values. After that we will store - ! the number of unique values in 'kaux' - do j=first_idx,last_idx - first_elem = iaux(j) - last_elem = iaux(j+1) - 1 - nzl = last_elem - first_elem + 1 - - ! The column has elements? - if (nzl > 0) then - call psi_msort_up(nzl,ias(first_elem:last_elem), & - & idxaux((ithread*(nr+2))+1:(ithread*(nr+2))+nzl+2),iret) - - if (iret == 0) then - call psb_ip_reord(nzl,vs(first_elem:last_elem),& - & ias(first_elem:last_elem),jas(first_elem:last_elem), & - & idxaux((ithread*(nr+2))+1:(ithread*(nr+2))+nzl+2)) - end if - - ! Over each column we count the unique values - kaux(j) = 1 - do i=first_elem+1,last_elem - if (ias(i) == ias(i-1) .and. jas(i) == jas(i-1)) then - cycle - end if - kaux(j) = kaux(j) + 1 - end do - end if - end do - - ! -------------------------------------------------- - - ! ---------------- kaux composition ---------------- - - !$OMP SINGLE - sum(:) = 0 - sum(1) = 1 - !$OMP END SINGLE - - s = 0 - do i=first_idx,last_idx - s = s + kaux(i) - end do - sum(ithread+2) = s - - !$OMP BARRIER - - !$OMP SINGLE - do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) - end do - !$OMP END SINGLE - - if (work > 0) then - saved_elem = kaux(first_idx) - end if - if (ithread == 0) then - kaux(1) = 1 - end if - - !$OMP BARRIER - - if (work > 0) then - old_val = kaux(first_idx+1) - kaux(first_idx+1) = saved_elem + sum(ithread+1) - end if - - do i=first_idx+2,last_idx+1 - nxt_val = kaux(i) - kaux(i) = kaux(i-1) + old_val - old_val = nxt_val - end do - - !$OMP BARRIER - - ! ------------------------------------------------ - - select case(dupl) - case(psb_dupl_ovwrt_) - !$OMP DO schedule(STATIC) - do j=1,nc - first_elem = iaux(j) - last_elem = iaux(j+1) - 1 - - if (first_elem > last_elem) then - cycle - end if - - k = kaux(j) - - val(k) = vs(first_elem) - ia(k) = ias(first_elem) - ja(k) = jas(first_elem) - - do i=first_elem+1,last_elem - if ((ias(i) == ias(i-1)).and.(jas(i) == jas(i-1))) then - val(k) = vs(i) - else - k = k + 1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - endif - end do - end do - !$OMP END DO - - case(psb_dupl_add_) - !$OMP DO schedule(STATIC) - do j=1,nc - first_elem = iaux(j) - last_elem = iaux(j+1) - 1 - - if (first_elem > last_elem) then - cycle - end if - - k = kaux(j) - - val(k) = vs(first_elem) - ia(k) = ias(first_elem) - ja(k) = jas(first_elem) - - do i=first_elem+1,last_elem - if ((ias(i) == ias(i-1)).and.(jas(i) == jas(i-1))) then - val(k) = val(k) + vs(i) - else - k = k + 1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - endif - end do - end do - !$OMP END DO - - case(psb_dupl_err_) - !$OMP DO schedule(STATIC) - do j=1,nc - first_elem = iaux(j) - last_elem = iaux(j+1) - 1 - - if (first_elem > last_elem) then - cycle - end if - - k = kaux(j) - - val(k) = vs(first_elem) - ia(k) = ias(first_elem) - ja(k) = jas(first_elem) - - do i=first_elem+1,last_elem - if ((ias(i) == ias(i-1)).and.(jas(i) == jas(i-1))) then - err = 1 - else - k = k + 1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - end if - end do - end do - !$OMP END DO - - case default - !$OMP SINGLE - err = 2 - !$OMP END SINGLE - end select - - !$OMP END PARALLEL - - if (err == 1) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else if (err == 2) then - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl - info =-7 - return - end if - - nzout = kaux(nc+1) - 1 - - deallocate(sum,kaux,idxaux,stat=info) -#else - !if (.not.srt_inp) then - ip = iaux(1) - iaux(1) = 0 - do i=2, nc - is = iaux(i) - iaux(i) = ip - ip = ip + is - end do - iaux(nc+1) = ip - - do i=1,nzin - icl = ja(i) - ip = iaux(icl) + 1 - ias(ip) = ia(i) - jas(ip) = ja(i) - vs(ip) = val(i) - iaux(icl) = ip - end do - !end if - - select case(dupl) - case(psb_dupl_ovwrt_) - k = 0 - i = 1 - do j=1, nc - nzl = iaux(j)-i+1 - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ias(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,vs(i:imx),& - & ias(i:imx),jas(i:imx),ix2) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - end if - end do - - case(psb_dupl_add_) - k = 0 - i = 1 - do j=1, nc - nzl = iaux(j)-i+1 - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ias(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,vs(i:imx),& - & ias(i:imx),jas(i:imx),ix2) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = val(k) + vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - end if - end do - - case(psb_dupl_err_) - k = 0 - i = 1 - do j=1, nc - nzl = iaux(j)-i+1 - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ias(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,vs(i:imx),& - & ias(i:imx),jas(i:imx),ix2) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - end if - end do - - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl - info =-7 - return - end select - - nzout = k - - deallocate(ix2, stat=info) -#endif - - deallocate(ias,jas,vs, stat=info) - - else if (.not.use_buffers) then - - call psi_msort_up(nzin,ja(1:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(nzin,val,ia,ja,iaux) -#if defined(OPENMP) - !$OMP PARALLEL default(none) & - !$OMP shared(nr,nc,nzin,iaux,ia,ja,val,nthreads) & - !$OMP private(i,j,first_idx,last_idx,nzl,act_col, & - !$OMP iret,ithread,work,first_elem,last_elem) - - !$OMP SINGLE - nthreads = omp_get_num_threads() - !$OMP END SINGLE - - ithread = omp_get_thread_num() - - ! -------- thread-specific workload -------- - - work = nc/nthreads - if (ithread < MOD(nc,nthreads)) then - work = work + 1 - first_idx = ithread*work + 1 - else - first_idx = ithread*work + MOD(nc,nthreads) + 1 - end if - - last_idx = first_idx + work - 1 - - ! --------------------------------------------------- - - first_elem = 0 - last_elem = -1 - act_col = first_idx - do j=1,nzin - if (ja(j) < act_col) then - cycle - else if ((ja(j) > last_idx) .or. (work < 1)) then - exit - else if (ja(j) > act_col) then - nzl = last_elem - first_elem + 1 - - if (nzl > 0) then - call psi_msort_up(nzl,ia(first_elem:),iaux((ithread*(nr+2))+1:(ithread*(nr+2))+nzl+2),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(first_elem:last_elem),& - & ia(first_elem:last_elem),ja(first_elem:last_elem),& - & iaux((ithread*(nr+2))+1:(ithread*(nr+2))+nzl+2)) - end if - - act_col = act_col + 1 - first_elem = 0 - last_elem = -1 - else - if (first_elem == 0) then - first_elem = j - end if - - last_elem = j - end if - end do - !$OMP END PARALLEL -#else - i = 1 - j = i - do while (i <= nzin) - do while ((ja(j) == ja(i))) - j = j+1 - if (j > nzin) exit - enddo - nzl = j - i - call psi_msort_up(nzl,ia(i:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(i:i+nzl-1),& - & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) - i = j - enddo -#endif - - i = 1 - irw = ia(i) - icl = ja(i) - j = 1 - - - select case(dupl) - case(psb_dupl_ovwrt_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) < 1 .or. ia(j) > nr) .or. (ja(j) < 1 .or. ja(j) > nc)) cycle - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_add_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) < 1 .or. ia(j) > nr) .or. (ja(j) < 1 .or. ja(j) > nc)) cycle - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(i) + val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_err_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) < 1 .or. ia(j) > nr) .or. (ja(j) < 1 .or. ja(j) > nc)) cycle - if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl - info =-7 - end select - - nzout = i - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end second loop' - - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_s_fix_coo_inner_colmajor - - -subroutine psb_s_cp_coo_to_lcoo(a,b,info) - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_s_cp_coo_to_lcoo - implicit none - class(psb_s_coo_sparse_mat), intent(in) :: a - class(psb_ls_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + class(psb_s_coo_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_lpk_) :: nz @@ -5296,7 +5157,7 @@ function psb_ls_coo_maxval(a) result(res) #if defined(OPENMP) block integer(psb_ipk_) :: i - !$omp parallel do private(i) + !$omp parallel do private(i) reduction(max:res) do i=1, nnz res = max(res,abs(a%val(i))) end do @@ -5363,7 +5224,7 @@ function psb_ls_coo_csnmi(a) result(res) #if defined(OPENMP) block integer(psb_ipk_) :: i - !$omp parallel do private(i) + !$omp parallel do private(i) reduction(max:res) do i=1, m res = max(res,abs(vt(i))) end do @@ -5413,7 +5274,7 @@ function psb_ls_coo_csnm1(a) result(res) #if defined(OPENMP) block integer(psb_ipk_) :: i - !$omp parallel do private(i) + !$omp parallel do private(i) reduction(max:res) do i=1, n res = max(res,abs(vt(i))) end do @@ -8335,3 +8196,4 @@ subroutine psb_ls_cp_coo_from_icoo(a,b,info) return end subroutine psb_ls_cp_coo_from_icoo + diff --git a/base/serial/impl/psb_s_csc_impl.F90 b/base/serial/impl/psb_s_csc_impl.F90 index 3da31d166..a66b7dc09 100644 --- a/base/serial/impl/psb_s_csc_impl.F90 +++ b/base/serial/impl/psb_s_csc_impl.F90 @@ -2189,6 +2189,9 @@ subroutine psb_s_mv_csc_from_coo(a,b,info) use psb_error_mod use psb_s_base_mat_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_mv_csc_from_coo +#if defined(OPENMP) + use omp_lib +#endif implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a @@ -2223,18 +2226,33 @@ subroutine psb_s_mv_csc_from_coo(a,b,info) call psb_realloc(nc+1,a%icp,info) call b%free() +#if defined(OPENMP) + + !$OMP PARALLEL default(shared) + + !$OMP WORKSHARE a%icp(:) = 0 + !$OMP END WORKSHARE + + !$OMP DO schedule(STATIC) & + !$OMP private(k,i) do k=1,nza i = itemp(k) - a%icp(i) = a%icp(i) + 1 + !$OMP ATOMIC UPDATE + a%icp(i+1) = a%icp(i+1) + 1 + !$OMP END ATOMIC end do - ip = 1 - do i=1,nc - nrl = a%icp(i) - a%icp(i) = ip - ip = ip + nrl + !$OMP END DO + call psi_exscan(nc+1,a%icp,info,shift=ione) + !$OMP END PARALLEL +#else + a%icp(:) = 0 + do k=1,nza + i = itemp(k) + a%icp(i) = a%icp(i) + 1 end do - a%icp(nc+1) = ip + call psi_exscan(nc+1,a%icp,info,shift=ione) +#endif call a%set_host() @@ -2311,9 +2329,28 @@ subroutine psb_s_cp_csc_to_fmt(a,b,info) b%psb_s_base_sparse_mat = a%psb_s_base_sparse_mat nc = a%get_ncols() nz = a%get_nzeros() - if (info == 0) call psb_safe_cpy( a%icp(1:nc+1), b%icp , info) - if (info == 0) call psb_safe_cpy( a%ia(1:nz), b%ia , info) - if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + if (.false.) then + if (info == 0) call psb_safe_cpy( a%icp(1:nc+1), b%icp , info) + if (info == 0) call psb_safe_cpy( a%ia(1:nz), b%ia , info) + if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + else + ! Despite the implementation in safe_cpy, it seems better this way + call psb_realloc(nc+1,b%icp,info) + call psb_realloc(nz,b%ia,info) + call psb_realloc(nz,b%val,info) + !$omp parallel do private(i) schedule(static) + do i=1,nc+1 + b%icp(i)=a%icp(i) + end do + !$omp end parallel do + !$omp parallel do private(j) schedule(static) + do j=1,nz + b%ia(j) = a%ia(j) + b%val(j) = a%val(j) + end do + !$omp end parallel do + end if + call b%set_host() class default @@ -2425,9 +2462,27 @@ subroutine psb_s_cp_csc_from_fmt(a,b,info) a%psb_s_base_sparse_mat = b%psb_s_base_sparse_mat nc = b%get_ncols() nz = b%get_nzeros() - if (info == 0) call psb_safe_cpy( b%icp(1:nc+1), a%icp , info) - if (info == 0) call psb_safe_cpy( b%ia(1:nz), a%ia , info) - if (info == 0) call psb_safe_cpy( b%val(1:nz), a%val , info) + if (.false.) then + if (info == 0) call psb_safe_cpy( b%icp(1:nc+1), a%icp , info) + if (info == 0) call psb_safe_cpy( b%ia(1:nz), a%ia , info) + if (info == 0) call psb_safe_cpy( b%val(1:nz), a%val , info) + else + ! Despite the implementation in safe_cpy, it seems better this way + call psb_realloc(nc+1,a%icp,info) + call psb_realloc(nz,a%ia,info) + call psb_realloc(nz,a%val,info) + !$omp parallel do private(i) schedule(static) + do i=1,nc+1 + a%icp(i)=b%icp(i) + end do + !$omp end parallel do + !$omp parallel do private(j) schedule(static) + do j=1,nz + a%ia(j)=b%ia(j) + a%val(j)=b%val(j) + end do + !$omp end parallel do + end if call a%set_host() class default diff --git a/base/serial/impl/psb_s_csr_impl.F90 b/base/serial/impl/psb_s_csr_impl.F90 index 87cfff684..abce0086b 100644 --- a/base/serial/impl/psb_s_csr_impl.F90 +++ b/base/serial/impl/psb_s_csr_impl.F90 @@ -152,6 +152,7 @@ contains !$omp parallel do private(i,j, acc) schedule(static) do i=1,m acc = szero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -163,6 +164,7 @@ contains !$omp parallel do private(i,j, acc) do i=1,m acc = szero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -174,6 +176,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = szero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -189,6 +192,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = szero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -200,6 +204,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = szero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -211,6 +216,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = szero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -225,6 +231,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = szero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -236,6 +243,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = szero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -247,6 +255,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = szero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -261,6 +270,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = szero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -272,6 +282,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = szero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -283,6 +294,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = szero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -2277,7 +2289,155 @@ subroutine psb_s_csr_tril(a,l,info,& nb = jmax_ endif +#if defined(OPENMP) + block + integer(psb_ipk_), allocatable :: lrws(:),urws(:) + integer(psb_ipk_) :: lpnt, upnt, lnz, unz + call psb_realloc(mb,lrws,info) + !$omp workshare + lrws(:) = 0 + !$omp end workshare + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + !write(0,*) 'Invocation of COO%TRIL', present(u),nz + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + if (info == 0) call psb_realloc(mb,urws,info) + !$omp workshare + urws(:) = 0 + !$omp end workshare + !write(0,*) 'omp version of COO%TRIL/TRIU' + lnz = 0 + unz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws,urws) reduction(+: lnz,unz) + loop1: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic update + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + !$omp end atomic + lnz = lnz + 1 + else + !$omp atomic update + urws(i-imin_+1) = urws(i-imin_+1) +1 + !$omp end atomic + unz = unz + 1 + end if + end if + end do + end do loop1 + !$omp end parallel do + + call psi_exscan(mb,lrws,info) + call psi_exscan(mb,urws,info) + !write(0,*) lrws(:), urws(:) + !$omp parallel do private(i,j,k,lpnt,upnt) shared(imin_,imax_,a) + loop2: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic capture + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + lpnt = lrws(i-imin_+1) + !$omp end atomic + l%ia(lpnt) = i + l%ja(lpnt) = a%ja(k) + l%val(lpnt) = a%val(k) + else + !$omp atomic capture + urws(i-imin_+1) = urws(i-imin_+1) +1 + upnt = urws(i-imin_+1) + !$omp end atomic + u%ia(upnt) = i + u%ja(upnt) = a%ja(k) + u%val(upnt) = a%val(k) + end if + end if + end do + end do loop2 + !$omp end parallel do + !write(0,*) 'End of copyout',lnz,unz + call l%set_nzeros(lnz) + call l%fix(info) + call u%set_nzeros(unz) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) then + !$omp workshare + u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + if ((diag_ >=-1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + lnz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws) reduction(+: lnz) + loop3: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic update + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + !$omp end atomic + lnz = lnz + 1 + end if + end if + end do + end do loop3 + !$omp end parallel do + call psi_exscan(mb,lrws,info) + !$omp parallel do private(i,j,k,lpnt) shared(imin_,imax_,a) + loop4: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic capture + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + lpnt = lrws(i-imin_+1) + !$omp end atomic + l%ia(lpnt) = i + l%ja(lpnt) = a%ja(k) + l%val(lpnt) = a%val(k) + end if + end if + end do + end do loop4 + !$omp end parallel do + call l%set_nzeros(lnz) + call l%fix(info) + end if + nzout = l%get_nzeros() + if (rscale_) then + !$omp workshare + l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if + end block +#else nz = a%get_nzeros() call l%allocate(mb,nb,nz) @@ -2347,7 +2507,7 @@ subroutine psb_s_csr_tril(a,l,info,& call l%set_triangle(.true.) call l%set_lower(.true.) end if - +#endif if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2431,6 +2591,158 @@ subroutine psb_s_csr_triu(a,u,info,& endif +#if defined(OPENMP) + block + integer(psb_ipk_), allocatable :: lrws(:),urws(:) + integer(psb_ipk_) :: lpnt, upnt, lnz, unz + call psb_realloc(mb,urws,info) + !$omp workshare + urws(:) = 0 + !$omp end workshare + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + !write(0,*) 'Invocation of COO%TRIL', present(u),nz + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + if (info == 0) call psb_realloc(mb,urws,info) + !$omp workshare + lrws(:) = 0 + !$omp end workshare + !write(0,*) 'omp version of COO%TRIL/TRIU' + lnz = 0 + unz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws,urws) reduction(+: lnz,unz) + loop1: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)=diag_) then + !$omp atomic update + urws(i-imin_+1) = urws(i-imin_+1) +1 + !$omp end atomic + unz = unz + 1 + end if + end if + end do + end do loop3 + !$omp end parallel do + call psi_exscan(mb,urws,info) + !$omp parallel do private(i,j,k,upnt) shared(imin_,imax_,a) + loop4: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)>=diag_) then + !$omp atomic capture + urws(i-imin_+1) = urws(i-imin_+1) +1 + upnt = urws(i-imin_+1) + !$omp end atomic + u%ia(upnt) = i + u%ja(upnt) = a%ja(k) + u%val(upnt) = a%val(k) + end if + end if + end do + end do loop4 + !$omp end parallel do + call u%set_nzeros(unz) + call u%fix(info) + end if + nzout = u%get_nzeros() + if (rscale_) then + !$omp workshare + u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + + if ((diag_ >= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_upper(.true.) + end if + end block + + +#else + nz = a%get_nzeros() call u%allocate(mb,nb,nz) @@ -2499,7 +2811,7 @@ subroutine psb_s_csr_triu(a,u,info,& call u%set_triangle(.true.) call u%set_upper(.true.) end if - +#endif if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2844,6 +3156,9 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) use psb_realloc_mod use psb_s_base_mat_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_cp_csr_from_coo +#if defined(OPENMP) + use omp_lib +#endif implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a @@ -2860,12 +3175,6 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) character(len=20) :: name='s_cp_csr_from_coo' logical :: use_openmp = .false. - !$ integer(psb_ipk_), allocatable :: sum(:) - !$ integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s,j - !$ integer(psb_ipk_) :: nxt_val,old_val,saved_elem,maxthreads - !$ use_openmp = .true. - - info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2904,98 +3213,39 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) if (info == psb_success_) call psb_safe_ab_cpy(b%ja,a%ja,info) if (info == psb_success_) call psb_safe_ab_cpy(b%val,a%val,info) if (info == psb_success_) call psb_realloc(max(nr+1,nc+1),a%irp,info) - + endif + +#if defined(OPENMP) + + !$OMP PARALLEL default(shared) reduction(max:info) + + !$OMP WORKSHARE a%irp(:) = 0 - -!!$ if (use_openmp) then -!!$ !$ maxthreads = omp_get_max_threads() -!!$ !$ allocate(sum(maxthreads+1)) -!!$ !$ sum(:) = 0 -!!$ !$ sum(1) = 1 -!!$ -!!$ !$OMP PARALLEL default(none) & -!!$ !$OMP shared(nza,itemp,a,nthreads,sum,nr) & -!!$ !$OMP private(ithread,work,first_idx,last_idx,s,saved_elem,nxt_val,old_val) -!!$ -!!$ !$OMP DO schedule(STATIC) & -!!$ !$OMP private(k,i) -!!$ do k=1,nza -!!$ i = itemp(k) -!!$ a%irp(i) = a%irp(i) + 1 -!!$ end do -!!$ !$OMP END DO -!!$ -!!$ !$OMP SINGLE -!!$ !$ nthreads = omp_get_num_threads() -!!$ !$OMP END SINGLE -!!$ -!!$ !$ ithread = omp_get_thread_num() -!!$ -!!$ !$ work = nr/nthreads -!!$ !$ if (ithread < MOD(nr,nthreads)) then -!!$ !$ work = work + 1 -!!$ !$ first_idx = ithread*work + 1 -!!$ !$ else -!!$ !$ first_idx = ithread*work + MOD(nr,nthreads) + 1 -!!$ !$ end if -!!$ -!!$ !$ last_idx = first_idx + work - 1 -!!$ -!!$ !$ s = 0 -!!$ !$ do i=first_idx,last_idx -!!$ !$ s = s + a%irp(i) -!!$ !$ end do -!!$ !$ if (work > 0) then -!!$ !$ sum(ithread+2) = s -!!$ !$ end if -!!$ -!!$ !$OMP BARRIER -!!$ -!!$ !$OMP SINGLE -!!$ !$ do i=2,nthreads+1 -!!$ !$ sum(i) = sum(i) + sum(i-1) -!!$ !$ end do -!!$ !$OMP END SINGLE -!!$ -!!$ !$ if (work > 0) then -!!$ !$ saved_elem = a%irp(first_idx) -!!$ !$ end if -!!$ !$ if (ithread == 0) then -!!$ !$ a%irp(1) = 1 -!!$ !$ end if -!!$ -!!$ !$OMP BARRIER -!!$ -!!$ !$ if (work > 0) then -!!$ !$ old_val = a%irp(first_idx+1) -!!$ !$ a%irp(first_idx+1) = saved_elem + sum(ithread+1) -!!$ !$ end if -!!$ -!!$ !$ do i=first_idx+2,last_idx+1 -!!$ !$ nxt_val = a%irp(i) -!!$ !$ a%irp(i) = a%irp(i-1) + old_val -!!$ !$ old_val = nxt_val -!!$ !$ end do -!!$ -!!$ !$OMP END PARALLEL -!!$ else - - do k=1,nza - i = itemp(k) - a%irp(i) = a%irp(i) + 1 - end do - ip = 1 - do i=1,nr - ncl = a%irp(i) - a%irp(i) = ip - ip = ip + ncl - end do - a%irp(nr+1) = ip -!!$ end if - call a%set_host() + !$OMP END WORKSHARE + + !$OMP DO schedule(STATIC) & + !$OMP private(k,i) + do k=1,nza + i = itemp(k) + !$OMP ATOMIC UPDATE + a%irp(i) = a%irp(i) + 1 + !$OMP END ATOMIC + end do + !$OMP END DO + call psi_exscan(nr+1,a%irp,info,shift=ione) + !$OMP END PARALLEL +#else + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + call psi_exscan(nr+1,a%irp,info,shift=ione) +#endif + call a%set_host() end subroutine psb_s_cp_csr_from_coo @@ -3096,6 +3346,9 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) use psb_error_mod use psb_s_base_mat_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_mv_csr_from_coo +#if defined(OPENMP) + use omp_lib +#endif implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a @@ -3109,13 +3362,6 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='mv_from_coo' - logical :: use_openmp = .false. - - ! $ integer(psb_ipk_), allocatable :: sum(:) - ! $ integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s - ! $ integer(psb_ipk_) :: nxt_val,old_val,saved_elem - ! $ use_openmp = .true. - info = psb_success_ debug_unit = psb_get_debug_unit() @@ -3139,90 +3385,34 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) call psb_realloc(max(nr+1,nc+1),a%irp,info) call b%free() +#if defined(OPENMP) + !$OMP PARALLEL default(shared) reduction(max:info) + + !$OMP WORKSHARE a%irp(:) = 0 + !$OMP END WORKSHARE + + !$OMP DO schedule(STATIC) & + !$OMP private(k,i) + do k=1,nza + i = itemp(k) + !$OMP ATOMIC UPDATE + a%irp(i) = a%irp(i) + 1 + !$OMP END ATOMIC + end do + !$OMP END DO + call psi_exscan(nr+1,a%irp,info,shift=ione) + !$OMP END PARALLEL +#else + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + call psi_exscan(nr+1,a%irp,info,shift=ione) +#endif -!!$ if (use_openmp) then -!!$ !$OMP PARALLEL default(none) & -!!$ !$OMP shared(sum,nthreads,nr,a,itemp,nza) & -!!$ !$OMP private(ithread,work,first_idx,last_idx,s,saved_elem,nxt_val,old_val) -!!$ -!!$ !$OMP DO schedule(STATIC) & -!!$ !$OMP private(k,i) -!!$ do k=1,nza -!!$ i = itemp(k) -!!$ a%irp(i) = a%irp(i) + 1 -!!$ end do -!!$ !$OMP END DO -!!$ -!!$ !$OMP SINGLE -!!$ !$ nthreads = omp_get_num_threads() -!!$ !$ allocate(sum(nthreads+1)) -!!$ !$ sum(:) = 0 -!!$ !$ sum(1) = 1 -!!$ !$OMP END SINGLE -!!$ -!!$ !$ ithread = omp_get_thread_num() -!!$ -!!$ !$ work = nr/nthreads -!!$ !$ if (ithread < MOD(nr,nthreads)) then -!!$ !$ work = work + 1 -!!$ !$ first_idx = ithread*work + 1 -!!$ !$ else -!!$ !$ first_idx = ithread*work + MOD(nr,nthreads) + 1 -!!$ !$ end if -!!$ -!!$ !$ last_idx = first_idx + work - 1 -!!$ -!!$ !$ s = 0 -!!$ !$ do i=first_idx,last_idx -!!$ !$ s = s + a%irp(i) -!!$ !$ end do -!!$ !$ if (work > 0) then -!!$ !$ sum(ithread+2) = s -!!$ !$ end if -!!$ -!!$ !$OMP BARRIER -!!$ -!!$ !$OMP SINGLE -!!$ !$ do i=2,nthreads+1 -!!$ !$ sum(i) = sum(i) + sum(i-1) -!!$ !$ end do -!!$ !$OMP END SINGLE -!!$ -!!$ !$ if (work > 0) then -!!$ !$ saved_elem = a%irp(first_idx) -!!$ !$ end if -!!$ !$ if (ithread == 0) then -!!$ !$ a%irp(1) = 1 -!!$ !$ end if -!!$ -!!$ !$ if (work > 0) then -!!$ !$ old_val = a%irp(first_idx+1) -!!$ !$ a%irp(first_idx+1) = saved_elem + sum(ithread+1) -!!$ !$ end if -!!$ -!!$ !$ do i=first_idx+2,last_idx+1 -!!$ !$ nxt_val = a%irp(i) -!!$ !$ a%irp(i) = a%irp(i-1) + old_val -!!$ !$ old_val = nxt_val -!!$ !$ end do -!!$ -!!$ !$OMP END PARALLEL -!!$ else - do k=1,nza - i = itemp(k) - a%irp(i) = a%irp(i) + 1 - end do - ip = 1 - do i=1,nr - ncl = a%irp(i) - a%irp(i) = ip - ip = ip + ncl - end do - a%irp(nr+1) = ip -!!$ end if - call a%set_host() end subroutine psb_s_mv_csr_from_coo @@ -3300,9 +3490,28 @@ subroutine psb_s_cp_csr_to_fmt(a,b,info) b%psb_s_base_sparse_mat = a%psb_s_base_sparse_mat nr = a%get_nrows() nz = a%get_nzeros() - if (info == 0) call psb_safe_cpy( a%irp(1:nr+1), b%irp , info) - if (info == 0) call psb_safe_cpy( a%ja(1:nz), b%ja , info) - if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + if (.false.) then + if (info == 0) call psb_safe_cpy( a%irp(1:nr+1), b%irp , info) + if (info == 0) call psb_safe_cpy( a%ja(1:nz), b%ja , info) + if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + else + ! Despite the implementation in safe_cpy, it seems better this way + call psb_realloc(nr+1,b%irp,info) + call psb_realloc(nz,b%ja,info) + call psb_realloc(nz,b%val,info) + !$omp parallel do private(i) schedule(static) + do i=1,nr+1 + b%irp(i)=a%irp(i) + end do + !$omp end parallel do + !$omp parallel do private(j) schedule(static) + do j=1,nz + b%ja(j) = a%ja(j) + b%val(j) = a%val(j) + end do + !$omp end parallel do + end if + call b%set_host() class default @@ -3386,9 +3595,27 @@ subroutine psb_s_cp_csr_from_fmt(a,b,info) a%psb_s_base_sparse_mat = b%psb_s_base_sparse_mat nr = b%get_nrows() nz = b%get_nzeros() - if (info == 0) call psb_safe_cpy( b%irp(1:nr+1), a%irp , info) - if (info == 0) call psb_safe_cpy( b%ja(1:nz) , a%ja , info) - if (info == 0) call psb_safe_cpy( b%val(1:nz) , a%val , info) + if (.false.) then + if (info == 0) call psb_safe_cpy( b%irp(1:nr+1), a%irp , info) + if (info == 0) call psb_safe_cpy( b%ja(1:nz) , a%ja , info) + if (info == 0) call psb_safe_cpy( b%val(1:nz) , a%val , info) + else + ! Despite the implementation in safe_cpy, it seems better this way + call psb_realloc(nr+1,a%irp,info) + call psb_realloc(nz,a%ja,info) + call psb_realloc(nz,a%val,info) + !$omp parallel do private(i) schedule(static) + do i=1,nr+1 + a%irp(i)=b%irp(i) + end do + !$omp end parallel do + !$omp parallel do private(j) schedule(static) + do j=1,nz + a%ja(j)=b%ja(j) + a%val(j)=b%val(j) + end do + !$omp end parallel do + end if call a%set_host() class default @@ -3427,6 +3654,540 @@ subroutine psb_s_csr_clean_zeros(a, info) call a%set_host() end subroutine psb_s_csr_clean_zeros +#if defined(OPENMP) +subroutine psb_scsrspspmm(a,b,c,info) + use psb_s_mat_mod + use psb_serial_mod, psb_protect_name => psb_scsrspspmm + + implicit none + + class(psb_s_csr_sparse_mat), intent(in) :: a,b + type(psb_s_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: ma,na,mb,nb, nzc, nza, nzb + character(len=20) :: name + integer(psb_ipk_) :: err_act + name='psb_csrspspmm' + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + if (b%is_dev()) call b%sync() + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb + info = psb_err_invalid_matrix_sizes_ + call psb_errpush(info,name) + goto 9999 + endif + + select case(spspmm_impl) + case (spspmm_serial) + ! Estimate number of nonzeros on output. + nza = a%get_nzeros() + nzb = b%get_nzeros() + nzc = 2*(nza+nzb) + call c%allocate(ma,nb,nzc) + + call csr_spspmm(a,b,c,info) + case (spspmm_omp_gustavson) + call spmm_omp_gustavson(a,b,c,info) + case (spspmm_omp_gustavson_1d) + call spmm_omp_gustavson_1d(a,b,c,info) + case (spspmm_serial_rb_tree) + call spmm_serial_rb_tree(a,b,c,info) + case (spspmm_omp_rb_tree) + call spmm_omp_rb_tree(a,b,c,info) + case (spspmm_omp_two_pass) + call spmm_omp_two_pass(a,b,c,info) + case default + write(psb_err_unit,*) 'Unknown spspmm implementation' + ! push error + goto 9999 + end select + + call c%set_asb() + call c%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csr_spspmm(a,b,c,info) + implicit none + type(psb_s_csr_sparse_mat), intent(in) :: a,b + type(psb_s_csr_sparse_mat), intent(inout) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: ma,na,mb,nb + integer(psb_ipk_), allocatable :: irow(:), idxs(:) + real(psb_spk_), allocatable :: row(:) + integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, & + & nzc,nnzre, isz, ipb, irwsz, nrc, nze + real(psb_spk_) :: cfb + + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = min(size(c%val),size(c%ja)) + isz = max(ma,na,mb,nb) + call psb_realloc(isz,row,info) + if (info == 0) call psb_realloc(isz,idxs,info) + if (info == 0) call psb_realloc(isz,irow,info) + if (info /= 0) return + row = dzero + irow = 0 + nzc = 1 + do j = 1,ma + c%irp(j) = nzc + nrc = 0 + do k = a%irp(j), a%irp(j+1)-1 + irw = a%ja(k) + cfb = a%val(k) + irwsz = b%irp(irw+1)-b%irp(irw) + do i = b%irp(irw),b%irp(irw+1)-1 + icl = b%ja(i) + if (irow(icl) 0 ) then + if ((nzc+nrc)>nze) then + nze = max(ma*((nzc+j-1)/j),nzc+2*nrc) + call psb_realloc(nze,c%val,info) + if (info == 0) call psb_realloc(nze,c%ja,info) + if (info /= 0) return + end if + + call psb_qsort(idxs(1:nrc)) + do i=1, nrc + irw = idxs(i) + c%ja(nzc) = irw + c%val(nzc) = row(irw) + row(irw) = dzero + nzc = nzc + 1 + end do + end if + end do + + c%irp(ma+1) = nzc + end subroutine csr_spspmm + + ! gustavson's algorithm using perfect hashing + ! and OpenMP parallelisation + subroutine spmm_omp_gustavson(a,b,c,info) + use omp_lib + + implicit none + type(psb_s_csr_sparse_mat), intent(in) :: a,b + type(psb_s_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + real(psb_spk_), allocatable :: vals(:), acc(:) + integer(psb_ipk_) :: ma, nb + integer(psb_ipk_), allocatable :: col_inds(:), offsets(:) + integer(psb_ipk_) :: irw, jj, j, k, nnz, rwnz, thread_upperbound, start_idx, end_idx + + ma = a%get_nrows() + nb = b%get_ncols() + + call c%allocate(ma, nb) + c%irp(1) = 1 + + ! dense accumulator + ! https://sc18.supercomputing.org/proceedings/workshops/workshop_files/ws_lasalss115s2-file1.pdf + call psb_realloc(nb, acc, info) + + allocate(offsets(omp_get_max_threads())) + !$omp parallel private(vals,col_inds,nnz,rwnz,thread_upperbound,acc,start_idx,end_idx) & + !$omp shared(a,b,c,offsets) + thread_upperbound = 0 + start_idx = 0 + !$omp do schedule(static) private(irw, jj, j) + do irw = 1, ma + if (start_idx == 0) then + start_idx = irw + end if + end_idx = irw + do jj = a%irp(irw), a%irp(irw + 1) - 1 + j = a%ja(jj) + thread_upperbound = thread_upperbound + b%irp(j+1) - b%irp(j) + end do + end do + !$omp end do + + call psb_realloc(thread_upperbound, vals, info) + call psb_realloc(thread_upperbound, col_inds, info) + + ! possible bottleneck + acc = 0 + + nnz = 0 + !$omp do schedule(static) private(irw, jj, j, k) + do irw = 1, ma + rwnz = 0 + do jj = a%irp(irw), a%irp(irw + 1) - 1 + j = a%ja(jj) + do k = b%irp(j), b%irp(j + 1) - 1 + if (acc(b%ja(k)) == 0) then + nnz = nnz + 1 + rwnz = rwnz + 1 + col_inds(nnz) = b%ja(k) + end if + acc(b%ja(k)) = acc(b%ja(k)) + a%val(jj) * b%val(k) + end do + end do + call psb_qsort(col_inds(nnz - rwnz + 1:nnz)) + + do k = nnz - rwnz + 1, nnz + vals(k) = acc(col_inds(k)) + acc(col_inds(k)) = 0 + end do + c%irp(irw + 1) = rwnz + end do + !$omp end do + + offsets(omp_get_thread_num() + 1) = nnz + !$omp barrier + + ! possible bottleneck + !$omp single + do k = 1, omp_get_num_threads() - 1 + offsets(k + 1) = offsets(k + 1) + offsets(k) + end do + !$omp end single + + !$omp barrier + + if (omp_get_thread_num() /= 0) then + c%irp(start_idx) = offsets(omp_get_thread_num()) + 1 + end if + + do irw = start_idx, end_idx - 1 + c%irp(irw + 1) = c%irp(irw + 1) + c%irp(irw) + end do + + !$omp barrier + + !$omp single + c%irp(ma + 1) = c%irp(ma + 1) + c%irp(ma) + call psb_realloc(c%irp(ma + 1), c%val, info) + call psb_realloc(c%irp(ma + 1), c%ja, info) + !$omp end single + + c%val(c%irp(start_idx):c%irp(end_idx + 1) - 1) = vals(1:nnz) + c%ja(c%irp(start_idx):c%irp(end_idx + 1) - 1) = col_inds(1:nnz) + !$omp end parallel + end subroutine spmm_omp_gustavson + + subroutine spmm_omp_gustavson_1d(a,b,c,info) + use omp_lib + + implicit none + type(psb_s_csr_sparse_mat), intent(in) :: a,b + type(psb_s_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + real(psb_spk_), allocatable :: vals(:), acc(:) + integer(psb_ipk_) :: ma, nb + integer(psb_ipk_), allocatable :: col_inds(:), offsets(:) + integer(psb_ipk_) :: irw, jj, j, k, nnz, rwnz, thread_upperbound, & + start_idx, end_idx , blk, blk_size, rwstart,& + rwblk, rwblkrem, nblks + + ma = a%get_nrows() + nb = b%get_ncols() + + call c%allocate(ma, nb) + c%irp(1) = 1 + + ! dense accumulator + ! https://sc18.supercomputing.org/proceedings/workshops/workshop_files/ws_lasalss115s2-file1.pdf + call psb_realloc(nb, acc, info) + allocate(offsets(omp_get_max_threads())) + + nblks = 4 * omp_get_max_threads() + rwblk = (ma / nblks) + rwblkrem = modulo(ma, nblks) + !$omp parallel private(vals,col_inds,nnz,thread_upperbound,acc,start_idx,end_idx) shared(a,b,c,offsets) + thread_upperbound = 0 + start_idx = 0 + !$omp do schedule(static) private(irw, jj, j) + do irw = 1, ma + do jj = a%irp(irw), a%irp(irw + 1) - 1 + j = a%ja(jj) + thread_upperbound = thread_upperbound + b%irp(j+1) - b%irp(j) + end do + end do + !$omp end do + + call psb_realloc(thread_upperbound, vals, info) + call psb_realloc(thread_upperbound, col_inds, info) + + ! possible bottleneck + acc = 0 + + nnz = 0 + !$omp do schedule(static) private(irw,jj,j,k,rwnz,blk,blk_size,rwstart) + do blk = 0, nblks - 1 + if (blk < rwblkrem) then + blk_size = rwblk + 1 + rwstart = blk * rwblk + blk + 1 + else + blk_size = rwblk + rwstart = blk * rwblk & + + rwblkrem + 1 + end if + do irw = rwstart, rwstart + blk_size - 1 + if (start_idx == 0) then + start_idx = irw + end if + end_idx = irw + rwnz = 0 + do jj = a%irp(irw), a%irp(irw + 1) - 1 + j = a%ja(jj) + do k = b%irp(j), b%irp(j + 1) - 1 + if (acc(b%ja(k)) == 0) then + nnz = nnz + 1 + rwnz = rwnz + 1 + col_inds(nnz) = b%ja(k) + end if + acc(b%ja(k)) = acc(b%ja(k)) + a%val(jj) * b%val(k) + end do + end do + call psb_qsort(col_inds(nnz - rwnz + 1:nnz)) + + do k = nnz - rwnz + 1, nnz + vals(k) = acc(col_inds(k)) + acc(col_inds(k)) = 0 + end do + c%irp(irw + 1) = rwnz + end do + end do + !$omp end do + + offsets(omp_get_thread_num() + 1) = nnz + !$omp barrier + + ! possible bottleneck + !$omp single + do k = 1, omp_get_num_threads() - 1 + offsets(k + 1) = offsets(k + 1) + offsets(k) + end do + !$omp end single + + !$omp barrier + + if (omp_get_thread_num() /= 0) then + c%irp(start_idx) = offsets(omp_get_thread_num()) + 1 + end if + + do irw = start_idx, end_idx - 1 + c%irp(irw + 1) = c%irp(irw + 1) + c%irp(irw) + end do + + !$omp barrier + + !$omp single + c%irp(ma + 1) = c%irp(ma + 1) + c%irp(ma) + call psb_realloc(c%irp(ma + 1), c%val, info) + call psb_realloc(c%irp(ma + 1), c%ja, info) + !$omp end single + + c%val(c%irp(start_idx):c%irp(end_idx + 1) - 1) = vals(1:nnz) + c%ja(c%irp(start_idx):c%irp(end_idx + 1) - 1) = col_inds(1:nnz) + !$omp end parallel + end subroutine spmm_omp_gustavson_1d + + subroutine spmm_serial_rb_tree(a,b,c,info) + use psb_rb_idx_tree_mod + implicit none + type(psb_s_csr_sparse_mat), intent(in) :: a,b + type(psb_s_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: a_m, b_n + integer(psb_ipk_) :: row, col + type(psb_s_rb_idx_tree), allocatable :: row_accs(:) + + a_m = a%get_nrows() + b_n = b%get_ncols() + + allocate(row_accs(a_m)) + call c%allocate(a_m, b_n) + + do row = 1, a_m + row_accs(row)%nnz = 0 + nullify(row_accs(row)%root) + do col = a%irp(row), a%irp(row + 1) - 1 + call psb_rb_idx_tree_scalar_sparse_row_mul(row_accs(row), a%val(col), b, a%ja(col)) + end do + end do + call psb_rb_idx_tree_merge(row_accs, c) + + deallocate(row_accs) + + info = 0 + end subroutine spmm_serial_rb_tree + + subroutine spmm_omp_rb_tree(a,b,c,info) + use omp_lib + use psb_rb_idx_tree_mod + implicit none + type(psb_s_csr_sparse_mat), intent(in) :: a,b + type(psb_s_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: a_m, b_n + integer(psb_ipk_) :: row, col + type(psb_s_rb_idx_tree), allocatable :: row_accs(:) + real(8) :: tic, toc + + a_m = a%get_nrows() + b_n = b%get_ncols() + + call c%allocate(a_m, b_n) + + allocate(row_accs(a_m)) + call c%allocate(a_m, b_n) + + !$omp parallel do schedule(static) + do row = 1, a_m + row_accs(row)%nnz = 0 + nullify(row_accs(row)%root) + do col = a%irp(row), a%irp(row + 1) - 1 + call psb_rb_idx_tree_scalar_sparse_row_mul(row_accs(row), a%val(col), b, a%ja(col)) + end do + end do + !$omp end parallel do + + call psb_rb_idx_tree_merge(row_accs, c) + + deallocate(row_accs) + info = 0 + end subroutine spmm_omp_rb_tree + + subroutine compute_indices(a, b, c, info) + implicit none + type(psb_s_csr_sparse_mat), intent(in) :: a,b + type(psb_s_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + integer :: full_mat_bound + integer :: row, col, i, j, k, nnz + + full_mat_bound = 0 + !omp parallel do schedule(static) reduction(+:full_mat_bound) + do row = 1, a%get_nrows() + do col = a%irp(row), a%irp(row + 1) - 1 + j = a%ja(col) + full_mat_bound = full_mat_bound + b%irp(j+1) - b%irp(j) + end do + end do + !omp end parallel do + + call psb_realloc(a%get_nrows() + 1, c%irp, info) + call psb_realloc(full_mat_bound, c%ja, info) + c%ja = 0 + c%irp(1) = 1 + + nnz = 0 + + do row = 1, a%get_nrows() + do col = a%irp(row), a%irp(row + 1) - 1 + do i = b%irp(a%ja(col)), b%irp(a%ja(col) + 1) - 1 + k = 0 + do while(c%ja(c%irp(row) + k) /= 0 .and. c%ja(c%irp(row) + k) /= b%ja(i)) + k = k + 1 + end do + if (c%ja(c%irp(row) + k) == 0) then + c%ja(c%irp(row)+k) = b%ja(i) + nnz = nnz + 1 + end if + end do + end do + c%irp(row + 1) = nnz + 1 + call psb_qsort(c%ja(c%irp(row):c%irp(row + 1)-1)) + end do + + + call psb_realloc(nnz, c%ja, info) + call psb_realloc(nnz, c%val, info) + + c%val = 0 + end subroutine compute_indices + + subroutine direct_scalar_sparse_row_mul(out_mat, out_row_num, scalar, mat, trgt_row_num) + type(psb_s_csr_sparse_mat), intent(inout) :: out_mat + integer(psb_ipk_), intent(in) :: out_row_num + real(psb_spk_), intent(in) :: scalar + type(psb_s_csr_sparse_mat), intent(in) :: mat + integer(psb_ipk_), intent(in) :: trgt_row_num + + integer(psb_ipk_) :: i, k, row_start, row_end + + row_start = out_mat%irp(out_row_num) + row_end = out_mat%irp(out_row_num + 1) - 1 + + do i = mat%irp(trgt_row_num), mat%irp(trgt_row_num + 1) - 1 + do k = out_mat%irp(out_row_num), out_mat%irp(out_row_num + 1) - 1 + if (out_mat%ja(k) == mat%ja(i)) then + out_mat%val(k) = out_mat%val(k) + scalar * mat%val(i) + exit + end if + end do + end do + + end subroutine direct_scalar_sparse_row_mul + + subroutine spmm_omp_two_pass(a,b,c,info) + use omp_lib + + implicit none + type(psb_s_csr_sparse_mat), intent(in) :: a,b + type(psb_s_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: a_m, b_n, row, col + + a_m = a%get_nrows() + b_n = b%get_ncols() + + call c%allocate(a_m, b_n) + + call compute_indices(a, b, c, info) + + !$omp parallel do schedule(static) + do row = 1, a_m + do col = a%irp(row), a%irp(row + 1) - 1 + call direct_scalar_sparse_row_mul(c, row, a%val(col), b, a%ja(col)) + end do + end do + !$omp end parallel do + end subroutine spmm_omp_two_pass + +end subroutine psb_scsrspspmm + +#else + subroutine psb_scsrspspmm(a,b,c,info) use psb_s_mat_mod use psb_serial_mod, psb_protect_name => psb_scsrspspmm @@ -3810,7 +4571,6 @@ subroutine psb_s_cp_ecsr_from_fmt(a,b,info) end subroutine psb_s_cp_ecsr_from_fmt - ! ! ! ls version diff --git a/base/serial/impl/psb_s_rb_idx_tree_impl.F90 b/base/serial/impl/psb_s_rb_idx_tree_impl.F90 new file mode 100644 index 000000000..ae624f72a --- /dev/null +++ b/base/serial/impl/psb_s_rb_idx_tree_impl.F90 @@ -0,0 +1,329 @@ +! +! 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. +! +! +! +! package: psb_s_rb_idx_tree_impl +! +! Red black tree implementation ordered by index +! +! Each node contains and index and a double precision value +! +! The tree should always be well balanced +! +! inserting a node with an existing index will +! add up the new value to the old one +! Contributed by Dimitri Walther +! +subroutine psb_s_rb_idx_tree_insert(this, idx, val) + use psb_s_rb_idx_tree_mod, psb_protect_name => psb_s_rb_idx_tree_insert + implicit none + class(psb_s_rb_idx_tree), intent(inout) :: this + integer(psb_ipk_), intent(in) :: idx + real(psb_spk_), intent(in) :: val + + character(len=22) :: name + type(psb_s_rb_idx_node), pointer :: new_node + type(psb_s_rb_idx_node), pointer :: current, previous + name='psb_rb_idx_tree_insert' + + allocate(new_node) + new_node%idx = idx + new_node%val = val + nullify(new_node%left) + nullify(new_node%right) + nullify(new_node%parent) + new_node%is_red = .true. + + + if (.not. associated(this%root)) then + this%root => new_node + this%nnz = 1 + new_node%is_red = .false. + return + end if + + current => this%root + + do while (associated(current)) + previous => current + + if (idx == current%idx) then + current%val = current%val + val + deallocate(new_node) + return + else if (idx < current%idx) then + current => current%left + else + + current => current%right + end if + end do + + if (idx < previous%idx) then + new_node%parent => previous + previous%left => new_node + else + new_node%parent => previous + previous%right => new_node + end if + + call psb_s_rb_idx_tree_fix_insertion(this, new_node) + + this%nnz = this%nnz + 1 +end subroutine psb_s_rb_idx_tree_insert + +subroutine psb_s_rb_idx_tree_fix_insertion(this, node) + use psb_s_rb_idx_tree_mod, psb_protect_name => psb_s_rb_idx_tree_fix_insertion + implicit none + class(psb_s_rb_idx_tree), intent(inout) :: this + type(psb_s_rb_idx_node), pointer, intent(inout) :: node + + character(len=29) :: name + type(psb_s_rb_idx_node), pointer :: current, parent, grand_parent, uncle + name = 'psb_rb_idx_tree_fix_insertion' + + current => node + parent => current%parent + do while(associated(parent) .and. parent%is_red) + ! grand parent exist because root can't be red + grand_parent => parent%parent + if (parent%idx < grand_parent%idx) then + uncle => grand_parent%right + else + uncle => grand_parent%left + end if + + if (associated(uncle) .and. uncle%is_red) then + parent%is_red = .false. + uncle%is_red = .false. + grand_parent%is_red = .true. + current => grand_parent + parent => current%parent + + ! Left-Left case + else if (current%idx < parent%idx .and. & + parent%idx < grand_parent%idx) then + call psb_s_rb_idx_tree_rotate_right(grand_parent) + call psb_s_rb_idx_tree_swap_colors(parent, grand_parent) + + if (this%root%idx == grand_parent%idx) this%root => parent + + return + ! Left-Right case + else if (current%idx > parent%idx .and. & + parent%idx < grand_parent%idx) then + call psb_s_rb_idx_tree_rotate_left(parent) + call psb_s_rb_idx_tree_rotate_right(grand_parent) + call psb_s_rb_idx_tree_swap_colors(current, grand_parent) + + if (this%root%idx == grand_parent%idx) this%root => current + + return + ! Right-Right case + else if (current%idx > parent%idx .and. & + parent%idx > grand_parent%idx) then + call psb_s_rb_idx_tree_rotate_left(grand_parent) + call psb_s_rb_idx_tree_swap_colors(parent, grand_parent) + + if (this%root%idx == grand_parent%idx) this%root => parent + + return + ! Right-Left case + else + call psb_s_rb_idx_tree_rotate_right(parent) + call psb_s_rb_idx_tree_rotate_left(grand_parent) + call psb_s_rb_idx_tree_swap_colors(current, grand_parent) + + if (this%root%idx == grand_parent%idx) this%root => current + + return + end if + end do + + this%root%is_red = .false. +end subroutine psb_s_rb_idx_tree_fix_insertion + +subroutine psb_s_rb_idx_tree_swap_colors(n1, n2) + use psb_s_rb_idx_tree_mod, psb_protect_name => psb_s_rb_idx_tree_swap_colors + implicit none + type(psb_s_rb_idx_node), pointer, intent(inout) :: n1, n2 + + character(len=27) :: name + logical :: tmp + name='psb_rb_idx_tree_swap_colors' + + tmp = n1%is_red + n1%is_red = n2%is_red + n2%is_red = tmp +end subroutine psb_s_rb_idx_tree_swap_colors + +subroutine psb_s_rb_idx_tree_rotate_right(node) + use psb_s_rb_idx_tree_mod, psb_protect_name => psb_s_rb_idx_tree_rotate_right + implicit none + type(psb_s_rb_idx_node), pointer, intent(inout) :: node + + character(len=28) :: name + type(psb_s_rb_idx_node), pointer :: l, lr + name='psb_rb_idx_tree_rotate_right' + + if (.not. associated(node%left)) return + + l => node%left + lr => l%right + node%left => lr + + if (associated(lr)) lr%parent => node + + if (associated(node%parent)) then + if (node%idx < node%parent%idx) then + node%parent%left => l + else + node%parent%right => l + end if + end if + + l%parent => node%parent + node%parent => l + + l%right => node +end subroutine psb_s_rb_idx_tree_rotate_right + +subroutine psb_s_rb_idx_tree_rotate_left(node) + use psb_s_rb_idx_tree_mod, psb_protect_name => psb_s_rb_idx_tree_rotate_left + implicit none + type(psb_s_rb_idx_node), pointer, intent(inout) :: node + + character(len=27) :: name + type(psb_s_rb_idx_node), pointer :: r, rl + name='psb_rb_idx_tree_rotate_left' + + if (.not. associated(node%right)) return + + r => node%right + rl => r%left + node%right => rl + + if (associated(rl)) rl%parent => node + + if (associated(node%parent)) then + if (node%idx < node%parent%idx) then + node%parent%left => r + else + node%parent%right => r + end if + end if + + r%parent => node%parent + node%parent => r + + r%left => node +end subroutine psb_s_rb_idx_tree_rotate_left + +subroutine psb_s_rb_idx_tree_scalar_sparse_row_mul(tree, scalar, mat, row_num) + use psb_s_rb_idx_tree_mod, psb_protect_name => psb_s_rb_idx_tree_scalar_sparse_row_mul + use psb_s_csr_mat_mod, only : psb_s_csr_sparse_mat + implicit none + type(psb_s_rb_idx_tree), intent(inout) :: tree + real(psb_spk_), intent(in) :: scalar + type(psb_s_csr_sparse_mat), intent(in) :: mat + integer(psb_ipk_), intent(in) :: row_num + + character(len=37) :: name + integer(psb_ipk_) :: i + name='psb_rb_idx_tree_scalar_sparse_row_mul' + + do i = mat%irp(row_num), mat%irp(row_num + 1) - 1 + call tree%insert(mat%ja(i),scalar * mat%val(i)) + end do + +end subroutine psb_s_rb_idx_tree_scalar_sparse_row_mul + +subroutine psb_s_rb_idx_tree_merge(trees, mat) +#if defined(OPENMP) + use omp_lib +#endif + use psb_realloc_mod + use psb_s_rb_idx_tree_mod, psb_protect_name => psb_s_rb_idx_tree_merge + use psb_s_csr_mat_mod, only : psb_s_csr_sparse_mat + implicit none + type(psb_s_rb_idx_tree), allocatable, intent(inout) :: trees(:) + type(psb_s_csr_sparse_mat), intent(inout) :: mat + + character(len=21) :: name + integer(psb_ipk_) :: i, j, rows, info, nnz + type(psb_s_rb_idx_node), pointer :: current, previous + name='psb_rb_idx_tree_merge' + + rows = size(trees) + + mat%irp(1) = 1 + + do i=1, rows + mat%irp(i + 1) = mat%irp(i) + trees(i)%nnz + end do + + nnz = mat%irp(rows + 1) + call psb_realloc(nnz, mat%val, info) + call psb_realloc(nnz, mat%ja, info) + +#if defined(OPENMP) + !$omp parallel do schedule(static), private(current, previous, j) +#endif + do i = 1, size(trees) + j = 0 + current => trees(i)%root + do while(associated(current)) + ! go to the left-most node + do while(associated(current%left)) + current => current%left + end do + mat%val(j + mat%irp(i)) = current%val + mat%ja(j + mat%irp(i)) = current%idx + j = j + 1 + + previous => current + if (associated(current%right)) then + if (associated(current%parent)) then + current%parent%left => current%right + end if + current%right%parent => current%parent + current => current%right + else + current => current%parent + if (associated(current)) nullify(current%left) + end if + deallocate(previous) + end do + end do +#if defined(OPENMP) + !$omp end parallel do +#endif +end subroutine psb_s_rb_idx_tree_merge diff --git a/base/serial/impl/psb_z_coo_impl.F90 b/base/serial/impl/psb_z_coo_impl.F90 index d06e2739f..542f842e0 100644 --- a/base/serial/impl/psb_z_coo_impl.F90 +++ b/base/serial/impl/psb_z_coo_impl.F90 @@ -2817,6 +2817,9 @@ subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_realloc_mod use psb_sort_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_csput_a +#if defined(OPENMP) + use omp_lib +#endif implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a @@ -2828,7 +2831,7 @@ subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) integer(psb_ipk_) :: err_act character(len=20) :: name='z_coo_csput_a_impl' logical, parameter :: debug=.false. - integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit + integer(psb_ipk_) :: nza, i,j,k, nzl, isza, nzaold, debug_level, debug_unit info = psb_success_ debug_unit = psb_get_debug_unit() @@ -2860,10 +2863,13 @@ subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) if (nz == 0) return - - nza = a%get_nzeros() - isza = a%get_size() if (a%is_bld()) then + ! Structure here is peculiar, because this function can be called + ! either within a parallel region, or outside. + ! Hence the call to set_nzeros done here. + !$omp critical + nza = a%get_nzeros() + isza = a%get_size() ! Build phase. Must handle reallocations in a sensible way. if (isza < (nza+nz)) then call a%reallocate(max(nza+nz,int(1.5*isza))) @@ -2871,16 +2877,20 @@ subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) isza = a%get_size() if (isza < (nza+nz)) then info = psb_err_alloc_dealloc_; call psb_errpush(info,name) - goto 9999 + else + nzaold = nza + nza = nza + nz + call a%set_nzeros(nza) end if - - call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& + !$omp end critical + if (info /= 0) goto 9999 + call psb_inner_ins(nz,ia,ja,val,nzaold,a%ia,a%ja,a%val,isza,& & imin,imax,jmin,jmax,info) - call a%set_nzeros(nza) call a%set_sorted(.false.) - - + else if (a%is_upd()) then + nza = a%get_nzeros() + isza = a%get_size() if (a%is_dev()) call a%sync() @@ -2949,7 +2959,6 @@ contains end if end do !$OMP END PARALLEL DO - nza = nza + nz #else do i=1, nz @@ -3478,6 +3487,602 @@ subroutine psb_z_coo_mv_from(a,b) end subroutine psb_z_coo_mv_from +! +! COO implementation of tril/triu +! +subroutine psb_z_coo_tril(a,l,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,u) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_tril + implicit none + + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_z_coo_sparse_mat), optional, intent(out) :: u + + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k + integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + character(len=20) :: name='tril' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + +#if defined(OPENMP) + block + integer(psb_ipk_), allocatable :: lrws(:),urws(:) + integer(psb_ipk_) :: lpnt, upnt, lnz, unz + call psb_realloc(mb,lrws,info) + !$omp workshare + lrws(:) = 0 + !$omp end workshare + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + !write(0,*) 'Invocation of COO%TRIL', present(u),nz + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + if (info == 0) call psb_realloc(mb,urws,info) + !$omp workshare + urws(:) = 0 + !$omp end workshare + !write(0,*) 'omp version of COO%TRIL/TRIU' + lnz = 0 + unz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws,urws) reduction(+: lnz,unz) + loop1: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic update + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + !$omp end atomic + lnz = lnz + 1 + else + !$omp atomic update + urws(i-imin_+1) = urws(i-imin_+1) +1 + !$omp end atomic + unz = unz + 1 + end if + end if + end do loop1 + !$omp end parallel do + + call psi_exscan(mb,lrws,info) + call psi_exscan(mb,urws,info) + !write(0,*) lrws(:), urws(:) + !$omp parallel do private(i,j,k,lpnt,upnt) shared(imin_,imax_,a) + loop2: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic capture + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + lpnt = lrws(i-imin_+1) + !$omp end atomic + l%ia(lpnt) = a%ia(k) + l%ja(lpnt) = a%ja(k) + l%val(lpnt) = a%val(k) + else + !$omp atomic capture + urws(i-imin_+1) = urws(i-imin_+1) +1 + upnt = urws(i-imin_+1) + !$omp end atomic + u%ia(upnt) = a%ia(k) + u%ja(upnt) = a%ja(k) + u%val(upnt) = a%val(k) + end if + end if + end do loop2 + !$omp end parallel do + !write(0,*) 'End of copyout',lnz,unz + call l%set_nzeros(lnz) + call l%fix(info) + call u%set_nzeros(unz) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) then + !$omp workshare + u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + if ((diag_ >=-1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + lnz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws) reduction(+: lnz) + loop3: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic update + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + !$omp end atomic + lnz = lnz + 1 + end if + end if + end do loop3 + !$omp end parallel do + call psi_exscan(mb,lrws,info) + !$omp parallel do private(i,j,k,lpnt) shared(imin_,imax_,a) + loop4: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic capture + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + lpnt = lrws(i-imin_+1) + !$omp end atomic + l%ia(lpnt) = a%ia(k) + l%ja(lpnt) = a%ja(k) + l%val(lpnt) = a%val(k) + end if + end if + end do loop4 + !$omp end parallel do + call l%set_nzeros(lnz) + call l%fix(info) + end if + nzout = l%get_nzeros() + if (rscale_) then + !$omp workshare + l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if + end block + +#else + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, ia=>a%ia) + loop1: do k=1,nz + i = ia(k) + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + nzlin = nzlin + 1 + l%ia(nzlin) = i + l%ja(nzlin) = ja(k) + l%val(nzlin) = val(k) + else + nzuin = nzuin + 1 + u%ia(nzuin) = i + u%ja(nzuin) = ja(k) + u%val(nzuin) = val(k) + end if + end if + end do loop1 + end associate + + call l%set_nzeros(nzlin) + call u%set_nzeros(nzuin) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >=-1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + nzin = l%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, ia=>a%ia) + loop2: do k=1,nz + i = ia(k) + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + nzin = nzin + 1 + l%ia(nzin) = i + l%ja(nzin) = ja(k) + l%val(nzin) = val(k) + end if + end if + end do loop2 + end associate + call l%set_nzeros(nzin) + end if + call l%fix(info) + nzout = l%get_nzeros() + if (rscale_) & + & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if +#endif + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_coo_tril + +subroutine psb_z_coo_triu(a,u,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,l) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_triu + implicit none + + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_z_coo_sparse_mat), optional, intent(out) :: l + + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k + integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + character(len=20) :: name='triu' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + +#if defined(OPENMP) + block + integer(psb_ipk_), allocatable :: lrws(:),urws(:) + integer(psb_ipk_) :: lpnt, upnt, lnz, unz + call psb_realloc(mb,urws,info) + !$omp workshare + urws(:) = 0 + !$omp end workshare + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + !write(0,*) 'Invocation of COO%TRIL', present(u),nz + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + if (info == 0) call psb_realloc(mb,urws,info) + !$omp workshare + lrws(:) = 0 + !$omp end workshare + !write(0,*) 'omp version of COO%TRIL/TRIU' + lnz = 0 + unz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws,urws) reduction(+: lnz,unz) + loop1: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)>=diag_) then + !$omp atomic update + urws(i-imin_+1) = urws(i-imin_+1) +1 + !$omp end atomic + unz = unz + 1 + end if + end if + end do loop3 + !$omp end parallel do + call psi_exscan(mb,urws,info) + !$omp parallel do private(i,j,k,upnt) shared(imin_,imax_,a) + loop4: do k=1,nz + i = a%ia(k) + j = a%ja(k) + if ((i>=imin_).and.(i<=imax_).and.(jmin_<=j).and.(j<=jmax_)) then + if ((j-i)>=diag_) then + !$omp atomic capture + urws(i-imin_+1) = urws(i-imin_+1) +1 + upnt = urws(i-imin_+1) + !$omp end atomic + u%ia(upnt) = a%ia(k) + u%ja(upnt) = a%ja(k) + u%val(upnt) = a%val(k) + end if + end if + end do loop4 + !$omp end parallel do + call u%set_nzeros(unz) + call u%fix(info) + end if + nzout = u%get_nzeros() + if (rscale_) then + !$omp workshare + u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + + if ((diag_ >= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_upper(.true.) + end if + end block + + +#else + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, ia=>a%ia) + loop1: do k=1,nz + i = ia(k) + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)a%val, ja => a%ja, ia=>a%ia) + loop2: do k=1,nz + i = ia(k) + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)>=diag_) then + nzin = nzin + 1 + u%ia(nzin) = i + u%ja(nzin) = ja(k) + u%val(nzin) = val(k) + end if + end if + end do loop2 + end associate + call u%set_nzeros(nzin) + end if + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + + if ((diag_ >= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if +#endif + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_coo_triu + subroutine psb_z_fix_coo(a,info,idir) use psb_const_mod @@ -3561,7 +4166,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) character(len=20) :: name = 'psb_fixcoo' logical :: srt_inp, use_buffers #if defined(OPENMP) - integer(psb_ipk_) :: work,first_idx,last_idx,first_elem,last_elem,s,nthreads,ithread + integer(psb_ipk_) :: work,idxstart,idxend,first_elem,last_elem,s,nthreads,ithread integer(psb_ipk_) :: saved_elem,old_val,nxt_val,err,act_row,act_col,maxthreads integer(psb_ipk_), allocatable :: sum(:),kaux(:),idxaux(:) #endif @@ -3620,8 +4225,6 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ! Dirty trick: call ROWMAJOR with rows <-> columns call psb_z_fix_coo_inner_rowmajor(nc,nr,nzin,dupl,& & ja,ia,val,iaux,nzout,info) -!!$ call psb_z_fix_coo_inner_colmajor(nr,nc,nzin,dupl,& -!!$ & ia,ja,val,iaux,nzout,info) case default write(debug_unit,*) trim(name),': unknown direction ',idir_ info = psb_err_internal_error_ @@ -3660,12 +4263,13 @@ subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf integer(psb_ipk_), allocatable :: ias(:),jas(:), ix2(:) complex(psb_dpk_), allocatable :: vs(:) integer(psb_ipk_) :: nza, nzl,iret - integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii + integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii, i1, i2 integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name = 'psb_fixcoo' logical :: srt_inp, use_buffers + real(psb_dpk_) :: t0, t1 #if defined(OPENMP) - integer(psb_ipk_) :: work,first_idx,last_idx,first_elem,last_elem,s,nthreads,ithread + integer(psb_ipk_) :: work,idxstart,idxend,first_elem,last_elem,s,nthreads,ithread integer(psb_ipk_) :: saved_elem,old_val,nxt_val,err,act_row,act_col,maxthreads integer(psb_ipk_), allocatable :: sum(:),kaux(:),idxaux(:) #endif @@ -3747,9 +4351,9 @@ subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf ! Here, starting from 'iaux', we apply a fixing in order to obtain the starting ! index for each row. We do the same on 'kaux' !$OMP PARALLEL default(none) & - !$OMP shared(idxaux,ia,ja,val,ias,jas,vs,nthreads,sum,nr,nc,nzin,iaux,kaux,dupl,err) & - !$OMP private(s,i,j,k,ithread,first_idx,last_idx,work,nxt_val,old_val,saved_elem, & - !$OMP first_elem,last_elem,nzl,iret,act_row) + !$OMP shared(t0,t1,idxaux,ia,ja,val,ias,jas,vs,nthreads,sum,nr,nc,nzin,iaux,kaux,dupl,err) & + !$OMP private(s,i,j,k,ithread,idxstart,idxend,work,nxt_val,old_val,saved_elem, & + !$OMP first_elem,last_elem,nzl,iret,act_row,i1,i2) reduction(max: info) !$OMP SINGLE nthreads = omp_get_num_threads() @@ -3762,81 +4366,46 @@ subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf work = nr/nthreads if (ithread < MOD(nr,nthreads)) then work = work + 1 - first_idx = ithread*work + 1 + idxstart = ithread*work + 1 else - first_idx = ithread*work + MOD(nr,nthreads) + 1 + idxstart = ithread*work + MOD(nr,nthreads) + 1 end if - last_idx = first_idx + work - 1 - - !------------------------------------------- - ! ------------ iaux composition -------------- - ! 'iaux' will have the start index for each row - - s = 0 - do i=first_idx,last_idx - s = s + iaux(i) - end do - sum(ithread+2) = s + idxend = idxstart + work - 1 + !write(0,*) 'fix_coo_inner: trying with exscan' + call psi_exscan(nr+1,iaux,info,shift=ione) !$OMP BARRIER - !$OMP SINGLE - do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) - end do + !t0 = omp_get_wtime() !$OMP END SINGLE - - if (work > 0) then - saved_elem = iaux(first_idx) - end if - - if (ithread == 0) then - iaux(1) = 1 - end if - - !$OMP BARRIER - - if (work > 0) then - old_val = iaux(first_idx+1) - iaux(first_idx+1) = saved_elem + sum(ithread+1) - end if - - do i=first_idx+2,last_idx+1 - nxt_val = iaux(i) - iaux(i) = iaux(i-1) + old_val - old_val = nxt_val - end do - - ! -------------------------------------- - - !$OMP BARRIER - + ! ------------------ Sorting and buffers ------------------- ! Let's use an auxiliary buffer, 'idxaux', to get indices leaving ! unmodified 'iaux' - do j=first_idx,last_idx + do j=idxstart,idxend idxaux(j) = iaux(j) end do - ! Here we sort data inside the auxiliary buffers do i=1,nzin act_row = ia(i) - if ((act_row >= first_idx) .and. (act_row <= last_idx)) then + if ((act_row >= idxstart) .and. (act_row <= idxend)) then ias(idxaux(act_row)) = ia(i) jas(idxaux(act_row)) = ja(i) vs(idxaux(act_row)) = val(i) - idxaux(act_row) = idxaux(act_row) + 1 end if end do !$OMP BARRIER - + !$OMP SINGLE + !t1 = omp_get_wtime() + !write(0,*) ithread,'Srt&Cpy :',t1-t0 + !$OMP END SINGLE ! Let's sort column indices and values. After that we will store ! the number of unique values in 'kaux' - do j=first_idx,last_idx + do j=idxstart,idxend first_elem = iaux(j) last_elem = iaux(j+1) - 1 nzl = last_elem - first_elem + 1 @@ -3865,45 +4434,7 @@ subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf ! -------------------------------------------------- ! ---------------- kaux composition ---------------- - !$OMP SINGLE - sum(:) = 0 - sum(1) = 1 - !$OMP END SINGLE - - s = 0 - do i=first_idx,last_idx - s = s + kaux(i) - end do - sum(ithread+2) = s - - !$OMP BARRIER - - !$OMP SINGLE - do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) - end do - kaux(nr+1) = sum(nthreads+1) - !$OMP END SINGLE - - if (work > 0) then - saved_elem = kaux(first_idx) - end if - if (ithread == 0) then - kaux(1) = 1 - end if - - !$OMP BARRIER - - if (work > 0) then - old_val = kaux(first_idx+1) - kaux(first_idx+1) = saved_elem + sum(ithread+1) - end if - - do i=first_idx+2,last_idx+1 - nxt_val = kaux(i) - kaux(i) = kaux(i-1) + old_val - old_val = nxt_val - end do + call psi_exscan(nr+1,kaux,i,shift=ione) !$OMP BARRIER @@ -3911,7 +4442,7 @@ subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf select case(dupl) case(psb_dupl_ovwrt_) - !$OMP DO schedule(STATIC) + !$OMP DO schedule(dynamic,32) do j=1,nr first_elem = iaux(j) last_elem = iaux(j+1) - 1 @@ -3940,7 +4471,7 @@ subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf !$OMP END DO case(psb_dupl_add_) - !$OMP DO schedule(STATIC) + !$OMP DO schedule(dynamic,32) do j=1,nr first_elem = iaux(j) last_elem = iaux(j+1) - 1 @@ -3969,7 +4500,7 @@ subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf !$OMP END DO case(psb_dupl_err_) - !$OMP DO schedule(STATIC) + !$OMP DO schedule(dynamic,32) do j=1,nr first_elem = iaux(j) last_elem = iaux(j+1) - 1 @@ -4174,7 +4705,7 @@ subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf #if defined(OPENMP) !$OMP PARALLEL default(none) & !$OMP shared(nr,nc,nzin,iaux,ia,ja,val,nthreads) & - !$OMP private(i,j,first_idx,last_idx,nzl,act_row,iret,ithread, & + !$OMP private(i,j,idxstart,idxend,nzl,act_row,iret,ithread, & !$OMP work,first_elem,last_elem) !$OMP SINGLE @@ -4188,22 +4719,22 @@ subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf work = nr/nthreads if (ithread < MOD(nr,nthreads)) then work = work + 1 - first_idx = ithread*work + 1 + idxstart = ithread*work + 1 else - first_idx = ithread*work + MOD(nr,nthreads) + 1 + idxstart = ithread*work + MOD(nr,nthreads) + 1 end if - last_idx = first_idx + work - 1 + idxend = idxstart + work - 1 ! --------------------------------------------------- first_elem = 0 last_elem = -1 - act_row = first_idx + act_row = idxstart do j=1,nzin if (ia(j) < act_row) then cycle - else if ((ia(j) > last_idx) .or. (work < 1)) then + else if ((ia(j) > idxend) .or. (work < 1)) then exit else if (ia(j) > act_row) then nzl = last_elem - first_elem + 1 @@ -4333,684 +4864,14 @@ subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf end subroutine psb_z_fix_coo_inner_rowmajor -subroutine psb_z_fix_coo_inner_colmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,info) - use psb_const_mod + +subroutine psb_z_cp_coo_to_lcoo(a,b,info) use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_z_fix_coo_inner_colmajor - use psb_string_mod - use psb_ip_reord_mod - use psb_sort_mod -#if defined(OPENMP) - use omp_lib -#endif + use psb_z_base_mat_mod, psb_protect_name => psb_z_cp_coo_to_lcoo implicit none - - integer(psb_ipk_), intent(in) :: nr, nc, nzin, dupl - integer(psb_ipk_), intent(inout) :: ia(:), ja(:), iaux(:) - complex(psb_dpk_), intent(inout) :: val(:) - integer(psb_ipk_), intent(out) :: nzout, info - !locals - integer(psb_ipk_), allocatable :: ias(:),jas(:), ix2(:) - complex(psb_dpk_), allocatable :: vs(:) - integer(psb_ipk_) :: nza, nzl,iret - integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name = 'psb_fixcoo' - logical :: srt_inp, use_buffers -#if defined(OPENMP) - integer(psb_ipk_) :: work,first_idx,last_idx,first_elem,last_elem,s,nthreads,ithread - integer(psb_ipk_) :: saved_elem,old_val,nxt_val,err,act_row,act_col,maxthreads - integer(psb_ipk_), allocatable :: sum(:),kaux(:),idxaux(:) -#endif - info = psb_success_ - - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if (nc <= nzin) then - ! Avoid strange situations with large indices -#if defined(OPENMP) - allocate(ias(nzin),jas(nzin),vs(nzin), stat=info) -#else - allocate(ias(nzin),jas(nzin),vs(nzin),ix2(nzin+2), stat=info) -#endif - use_buffers = (info == 0) - else - use_buffers = .false. - end if - - if (use_buffers) then - iaux(:) = 0 -#if defined(OPENMP) - !$OMP PARALLEL DO default(none) schedule(STATIC) & - !$OMP shared(nzin,ja,nc,iaux) & - !$OMP private(i) & - !$OMP reduction(.and.:use_buffers) - do i=1,nzin - if ((ja(i) < 1).or.(ja(i) > nc)) then - use_buffers = .false. - ! Invalid indices are placed outside the considered range - ja(i) = nc+2 - else - !$OMP ATOMIC UPDATE - iaux(ja(i)) = iaux(ja(i)) + 1 - end if - end do - !$OMP END PARALLEL DO -#else - !srt_inp = .true. - do i=1,nzin - if ((ja(i) < 1).or.(ja(i) > nc)) then - use_buffers = .false. - !ja(i) = nc+2 - !srt_inp = .false. - exit - end if - - iaux(ja(i)) = iaux(ja(i)) + 1 - - !srt_inp = srt_inp .and.(ja(i-1)<=ja(i)) - end do -#endif - end if - - !use_buffers=use_buffers.and.srt_inp - - ! Check again use_buffers. We enter here if nzin >= nc and - ! all the indices are valid - if (use_buffers) then -#if defined(OPENMP) - allocate(kaux(MAX(nzin,nc)+2),idxaux(MAX((nr+2)*maxthreads,nc)),sum(maxthreads+1),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - kaux(:) = 0 - sum(:) = 0 - sum(1) = 1 - err = 0 - - ! Here, starting from 'iaux', we apply a fixing in order to obtain the starting - ! index for each column. We do the same on 'kaux' - !$OMP PARALLEL default(none) & - !$OMP shared(idxaux,ia,ja,val,ias,jas,vs,nthreads,sum,nr,nc,nzin,iaux,kaux,dupl,err) & - !$OMP private(s,i,j,k,ithread,first_idx,last_idx,work,nxt_val,old_val,saved_elem, & - !$OMP first_elem,last_elem,nzl,iret,act_col) - - !$OMP SINGLE - nthreads = omp_get_num_threads() - !$OMP END SINGLE - - ithread = omp_get_thread_num() - - ! -------- thread-specific workload -------- - - work = nc/nthreads - if (ithread < MOD(nc,nthreads)) then - work = work + 1 - first_idx = ithread*work + 1 - else - first_idx = ithread*work + MOD(nc,nthreads) + 1 - end if - - last_idx = first_idx + work - 1 - - !------------------------------------------- - ! ---------- iaux composition -------------- - - s = 0 - do i=first_idx,last_idx - s = s + iaux(i) - end do - sum(ithread+2) = s - - !$OMP BARRIER - - !$OMP SINGLE - do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) - end do - !$OMP END SINGLE - - if (work > 0) then - saved_elem = iaux(first_idx) - end if - if (ithread == 0) then - iaux(1) = 1 - end if - - !$OMP BARRIER - - if (work > 0) then - old_val = iaux(first_idx+1) - iaux(first_idx+1) = saved_elem + sum(ithread+1) - end if - - do i=first_idx+2,last_idx+1 - nxt_val = iaux(i) - iaux(i) = iaux(i-1) + old_val - old_val = nxt_val - end do - - ! -------------------------------------- - - !$OMP BARRIER - - ! ------------------ Sorting and buffers ------------------- - - ! Let's use an auxiliary buffer to get indices - do j=first_idx,last_idx - idxaux(j) = iaux(j) - end do - - ! Here we sort data inside the auxiliary buffers - do i=1,nzin - act_col = ja(i) - if (act_col >= first_idx .and. act_col <= last_idx) then - ias(idxaux(act_col)) = ia(i) - jas(idxaux(act_col)) = ja(i) - vs(idxaux(act_col)) = val(i) - - idxaux(act_col) = idxaux(act_col) + 1 - end if - end do - - !$OMP BARRIER - - ! Let's sort column indices and values. After that we will store - ! the number of unique values in 'kaux' - do j=first_idx,last_idx - first_elem = iaux(j) - last_elem = iaux(j+1) - 1 - nzl = last_elem - first_elem + 1 - - ! The column has elements? - if (nzl > 0) then - call psi_msort_up(nzl,ias(first_elem:last_elem), & - & idxaux((ithread*(nr+2))+1:(ithread*(nr+2))+nzl+2),iret) - - if (iret == 0) then - call psb_ip_reord(nzl,vs(first_elem:last_elem),& - & ias(first_elem:last_elem),jas(first_elem:last_elem), & - & idxaux((ithread*(nr+2))+1:(ithread*(nr+2))+nzl+2)) - end if - - ! Over each column we count the unique values - kaux(j) = 1 - do i=first_elem+1,last_elem - if (ias(i) == ias(i-1) .and. jas(i) == jas(i-1)) then - cycle - end if - kaux(j) = kaux(j) + 1 - end do - end if - end do - - ! -------------------------------------------------- - - ! ---------------- kaux composition ---------------- - - !$OMP SINGLE - sum(:) = 0 - sum(1) = 1 - !$OMP END SINGLE - - s = 0 - do i=first_idx,last_idx - s = s + kaux(i) - end do - sum(ithread+2) = s - - !$OMP BARRIER - - !$OMP SINGLE - do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) - end do - !$OMP END SINGLE - - if (work > 0) then - saved_elem = kaux(first_idx) - end if - if (ithread == 0) then - kaux(1) = 1 - end if - - !$OMP BARRIER - - if (work > 0) then - old_val = kaux(first_idx+1) - kaux(first_idx+1) = saved_elem + sum(ithread+1) - end if - - do i=first_idx+2,last_idx+1 - nxt_val = kaux(i) - kaux(i) = kaux(i-1) + old_val - old_val = nxt_val - end do - - !$OMP BARRIER - - ! ------------------------------------------------ - - select case(dupl) - case(psb_dupl_ovwrt_) - !$OMP DO schedule(STATIC) - do j=1,nc - first_elem = iaux(j) - last_elem = iaux(j+1) - 1 - - if (first_elem > last_elem) then - cycle - end if - - k = kaux(j) - - val(k) = vs(first_elem) - ia(k) = ias(first_elem) - ja(k) = jas(first_elem) - - do i=first_elem+1,last_elem - if ((ias(i) == ias(i-1)).and.(jas(i) == jas(i-1))) then - val(k) = vs(i) - else - k = k + 1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - endif - end do - end do - !$OMP END DO - - case(psb_dupl_add_) - !$OMP DO schedule(STATIC) - do j=1,nc - first_elem = iaux(j) - last_elem = iaux(j+1) - 1 - - if (first_elem > last_elem) then - cycle - end if - - k = kaux(j) - - val(k) = vs(first_elem) - ia(k) = ias(first_elem) - ja(k) = jas(first_elem) - - do i=first_elem+1,last_elem - if ((ias(i) == ias(i-1)).and.(jas(i) == jas(i-1))) then - val(k) = val(k) + vs(i) - else - k = k + 1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - endif - end do - end do - !$OMP END DO - - case(psb_dupl_err_) - !$OMP DO schedule(STATIC) - do j=1,nc - first_elem = iaux(j) - last_elem = iaux(j+1) - 1 - - if (first_elem > last_elem) then - cycle - end if - - k = kaux(j) - - val(k) = vs(first_elem) - ia(k) = ias(first_elem) - ja(k) = jas(first_elem) - - do i=first_elem+1,last_elem - if ((ias(i) == ias(i-1)).and.(jas(i) == jas(i-1))) then - err = 1 - else - k = k + 1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - end if - end do - end do - !$OMP END DO - - case default - !$OMP SINGLE - err = 2 - !$OMP END SINGLE - end select - - !$OMP END PARALLEL - - if (err == 1) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else if (err == 2) then - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl - info =-7 - return - end if - - nzout = kaux(nc+1) - 1 - - deallocate(sum,kaux,idxaux,stat=info) -#else - !if (.not.srt_inp) then - ip = iaux(1) - iaux(1) = 0 - do i=2, nc - is = iaux(i) - iaux(i) = ip - ip = ip + is - end do - iaux(nc+1) = ip - - do i=1,nzin - icl = ja(i) - ip = iaux(icl) + 1 - ias(ip) = ia(i) - jas(ip) = ja(i) - vs(ip) = val(i) - iaux(icl) = ip - end do - !end if - - select case(dupl) - case(psb_dupl_ovwrt_) - k = 0 - i = 1 - do j=1, nc - nzl = iaux(j)-i+1 - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ias(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,vs(i:imx),& - & ias(i:imx),jas(i:imx),ix2) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - end if - end do - - case(psb_dupl_add_) - k = 0 - i = 1 - do j=1, nc - nzl = iaux(j)-i+1 - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ias(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,vs(i:imx),& - & ias(i:imx),jas(i:imx),ix2) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = val(k) + vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - end if - end do - - case(psb_dupl_err_) - k = 0 - i = 1 - do j=1, nc - nzl = iaux(j)-i+1 - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ias(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,vs(i:imx),& - & ias(i:imx),jas(i:imx),ix2) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - end if - end do - - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl - info =-7 - return - end select - - nzout = k - - deallocate(ix2, stat=info) -#endif - - deallocate(ias,jas,vs, stat=info) - - else if (.not.use_buffers) then - - call psi_msort_up(nzin,ja(1:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(nzin,val,ia,ja,iaux) -#if defined(OPENMP) - !$OMP PARALLEL default(none) & - !$OMP shared(nr,nc,nzin,iaux,ia,ja,val,nthreads) & - !$OMP private(i,j,first_idx,last_idx,nzl,act_col, & - !$OMP iret,ithread,work,first_elem,last_elem) - - !$OMP SINGLE - nthreads = omp_get_num_threads() - !$OMP END SINGLE - - ithread = omp_get_thread_num() - - ! -------- thread-specific workload -------- - - work = nc/nthreads - if (ithread < MOD(nc,nthreads)) then - work = work + 1 - first_idx = ithread*work + 1 - else - first_idx = ithread*work + MOD(nc,nthreads) + 1 - end if - - last_idx = first_idx + work - 1 - - ! --------------------------------------------------- - - first_elem = 0 - last_elem = -1 - act_col = first_idx - do j=1,nzin - if (ja(j) < act_col) then - cycle - else if ((ja(j) > last_idx) .or. (work < 1)) then - exit - else if (ja(j) > act_col) then - nzl = last_elem - first_elem + 1 - - if (nzl > 0) then - call psi_msort_up(nzl,ia(first_elem:),iaux((ithread*(nr+2))+1:(ithread*(nr+2))+nzl+2),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(first_elem:last_elem),& - & ia(first_elem:last_elem),ja(first_elem:last_elem),& - & iaux((ithread*(nr+2))+1:(ithread*(nr+2))+nzl+2)) - end if - - act_col = act_col + 1 - first_elem = 0 - last_elem = -1 - else - if (first_elem == 0) then - first_elem = j - end if - - last_elem = j - end if - end do - !$OMP END PARALLEL -#else - i = 1 - j = i - do while (i <= nzin) - do while ((ja(j) == ja(i))) - j = j+1 - if (j > nzin) exit - enddo - nzl = j - i - call psi_msort_up(nzl,ia(i:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(i:i+nzl-1),& - & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) - i = j - enddo -#endif - - i = 1 - irw = ia(i) - icl = ja(i) - j = 1 - - - select case(dupl) - case(psb_dupl_ovwrt_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) < 1 .or. ia(j) > nr) .or. (ja(j) < 1 .or. ja(j) > nc)) cycle - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_add_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) < 1 .or. ia(j) > nr) .or. (ja(j) < 1 .or. ja(j) > nc)) cycle - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(i) + val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_err_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) < 1 .or. ia(j) > nr) .or. (ja(j) < 1 .or. ja(j) > nc)) cycle - if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl - info =-7 - end select - - nzout = i - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end second loop' - - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_z_fix_coo_inner_colmajor - - -subroutine psb_z_cp_coo_to_lcoo(a,b,info) - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_z_cp_coo_to_lcoo - implicit none - class(psb_z_coo_sparse_mat), intent(in) :: a - class(psb_lz_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_lpk_) :: nz @@ -5296,7 +5157,7 @@ function psb_lz_coo_maxval(a) result(res) #if defined(OPENMP) block integer(psb_ipk_) :: i - !$omp parallel do private(i) + !$omp parallel do private(i) reduction(max:res) do i=1, nnz res = max(res,abs(a%val(i))) end do @@ -5363,7 +5224,7 @@ function psb_lz_coo_csnmi(a) result(res) #if defined(OPENMP) block integer(psb_ipk_) :: i - !$omp parallel do private(i) + !$omp parallel do private(i) reduction(max:res) do i=1, m res = max(res,abs(vt(i))) end do @@ -5413,7 +5274,7 @@ function psb_lz_coo_csnm1(a) result(res) #if defined(OPENMP) block integer(psb_ipk_) :: i - !$omp parallel do private(i) + !$omp parallel do private(i) reduction(max:res) do i=1, n res = max(res,abs(vt(i))) end do @@ -8335,3 +8196,4 @@ subroutine psb_lz_cp_coo_from_icoo(a,b,info) return end subroutine psb_lz_cp_coo_from_icoo + diff --git a/base/serial/impl/psb_z_csc_impl.F90 b/base/serial/impl/psb_z_csc_impl.F90 index 8af661fa5..e5516bd97 100644 --- a/base/serial/impl/psb_z_csc_impl.F90 +++ b/base/serial/impl/psb_z_csc_impl.F90 @@ -2189,6 +2189,9 @@ subroutine psb_z_mv_csc_from_coo(a,b,info) use psb_error_mod use psb_z_base_mat_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_mv_csc_from_coo +#if defined(OPENMP) + use omp_lib +#endif implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a @@ -2223,18 +2226,33 @@ subroutine psb_z_mv_csc_from_coo(a,b,info) call psb_realloc(nc+1,a%icp,info) call b%free() +#if defined(OPENMP) + + !$OMP PARALLEL default(shared) + + !$OMP WORKSHARE a%icp(:) = 0 + !$OMP END WORKSHARE + + !$OMP DO schedule(STATIC) & + !$OMP private(k,i) do k=1,nza i = itemp(k) - a%icp(i) = a%icp(i) + 1 + !$OMP ATOMIC UPDATE + a%icp(i+1) = a%icp(i+1) + 1 + !$OMP END ATOMIC end do - ip = 1 - do i=1,nc - nrl = a%icp(i) - a%icp(i) = ip - ip = ip + nrl + !$OMP END DO + call psi_exscan(nc+1,a%icp,info,shift=ione) + !$OMP END PARALLEL +#else + a%icp(:) = 0 + do k=1,nza + i = itemp(k) + a%icp(i) = a%icp(i) + 1 end do - a%icp(nc+1) = ip + call psi_exscan(nc+1,a%icp,info,shift=ione) +#endif call a%set_host() @@ -2311,9 +2329,28 @@ subroutine psb_z_cp_csc_to_fmt(a,b,info) b%psb_z_base_sparse_mat = a%psb_z_base_sparse_mat nc = a%get_ncols() nz = a%get_nzeros() - if (info == 0) call psb_safe_cpy( a%icp(1:nc+1), b%icp , info) - if (info == 0) call psb_safe_cpy( a%ia(1:nz), b%ia , info) - if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + if (.false.) then + if (info == 0) call psb_safe_cpy( a%icp(1:nc+1), b%icp , info) + if (info == 0) call psb_safe_cpy( a%ia(1:nz), b%ia , info) + if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + else + ! Despite the implementation in safe_cpy, it seems better this way + call psb_realloc(nc+1,b%icp,info) + call psb_realloc(nz,b%ia,info) + call psb_realloc(nz,b%val,info) + !$omp parallel do private(i) schedule(static) + do i=1,nc+1 + b%icp(i)=a%icp(i) + end do + !$omp end parallel do + !$omp parallel do private(j) schedule(static) + do j=1,nz + b%ia(j) = a%ia(j) + b%val(j) = a%val(j) + end do + !$omp end parallel do + end if + call b%set_host() class default @@ -2425,9 +2462,27 @@ subroutine psb_z_cp_csc_from_fmt(a,b,info) a%psb_z_base_sparse_mat = b%psb_z_base_sparse_mat nc = b%get_ncols() nz = b%get_nzeros() - if (info == 0) call psb_safe_cpy( b%icp(1:nc+1), a%icp , info) - if (info == 0) call psb_safe_cpy( b%ia(1:nz), a%ia , info) - if (info == 0) call psb_safe_cpy( b%val(1:nz), a%val , info) + if (.false.) then + if (info == 0) call psb_safe_cpy( b%icp(1:nc+1), a%icp , info) + if (info == 0) call psb_safe_cpy( b%ia(1:nz), a%ia , info) + if (info == 0) call psb_safe_cpy( b%val(1:nz), a%val , info) + else + ! Despite the implementation in safe_cpy, it seems better this way + call psb_realloc(nc+1,a%icp,info) + call psb_realloc(nz,a%ia,info) + call psb_realloc(nz,a%val,info) + !$omp parallel do private(i) schedule(static) + do i=1,nc+1 + a%icp(i)=b%icp(i) + end do + !$omp end parallel do + !$omp parallel do private(j) schedule(static) + do j=1,nz + a%ia(j)=b%ia(j) + a%val(j)=b%val(j) + end do + !$omp end parallel do + end if call a%set_host() class default diff --git a/base/serial/impl/psb_z_csr_impl.F90 b/base/serial/impl/psb_z_csr_impl.F90 index a4a2dd5a2..b550e8f15 100644 --- a/base/serial/impl/psb_z_csr_impl.F90 +++ b/base/serial/impl/psb_z_csr_impl.F90 @@ -152,6 +152,7 @@ contains !$omp parallel do private(i,j, acc) schedule(static) do i=1,m acc = zzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -163,6 +164,7 @@ contains !$omp parallel do private(i,j, acc) do i=1,m acc = zzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -174,6 +176,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = zzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -189,6 +192,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = zzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -200,6 +204,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = zzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -211,6 +216,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = zzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -225,6 +231,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = zzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -236,6 +243,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = zzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -247,6 +255,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = zzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -261,6 +270,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = zzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -272,6 +282,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = zzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -283,6 +294,7 @@ contains !$omp parallel do private(i,j,acc) do i=1,m acc = zzero + !$omp simd do j=irp(i), irp(i+1)-1 acc = acc + val(j) * x(ja(j)) enddo @@ -2277,7 +2289,155 @@ subroutine psb_z_csr_tril(a,l,info,& nb = jmax_ endif +#if defined(OPENMP) + block + integer(psb_ipk_), allocatable :: lrws(:),urws(:) + integer(psb_ipk_) :: lpnt, upnt, lnz, unz + call psb_realloc(mb,lrws,info) + !$omp workshare + lrws(:) = 0 + !$omp end workshare + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + !write(0,*) 'Invocation of COO%TRIL', present(u),nz + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + if (info == 0) call psb_realloc(mb,urws,info) + !$omp workshare + urws(:) = 0 + !$omp end workshare + !write(0,*) 'omp version of COO%TRIL/TRIU' + lnz = 0 + unz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws,urws) reduction(+: lnz,unz) + loop1: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic update + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + !$omp end atomic + lnz = lnz + 1 + else + !$omp atomic update + urws(i-imin_+1) = urws(i-imin_+1) +1 + !$omp end atomic + unz = unz + 1 + end if + end if + end do + end do loop1 + !$omp end parallel do + + call psi_exscan(mb,lrws,info) + call psi_exscan(mb,urws,info) + !write(0,*) lrws(:), urws(:) + !$omp parallel do private(i,j,k,lpnt,upnt) shared(imin_,imax_,a) + loop2: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic capture + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + lpnt = lrws(i-imin_+1) + !$omp end atomic + l%ia(lpnt) = i + l%ja(lpnt) = a%ja(k) + l%val(lpnt) = a%val(k) + else + !$omp atomic capture + urws(i-imin_+1) = urws(i-imin_+1) +1 + upnt = urws(i-imin_+1) + !$omp end atomic + u%ia(upnt) = i + u%ja(upnt) = a%ja(k) + u%val(upnt) = a%val(k) + end if + end if + end do + end do loop2 + !$omp end parallel do + !write(0,*) 'End of copyout',lnz,unz + call l%set_nzeros(lnz) + call l%fix(info) + call u%set_nzeros(unz) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) then + !$omp workshare + u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + if ((diag_ >=-1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + lnz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws) reduction(+: lnz) + loop3: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic update + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + !$omp end atomic + lnz = lnz + 1 + end if + end if + end do + end do loop3 + !$omp end parallel do + call psi_exscan(mb,lrws,info) + !$omp parallel do private(i,j,k,lpnt) shared(imin_,imax_,a) + loop4: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)<=diag_) then + !$omp atomic capture + lrws(i-imin_+1) = lrws(i-imin_+1) +1 + lpnt = lrws(i-imin_+1) + !$omp end atomic + l%ia(lpnt) = i + l%ja(lpnt) = a%ja(k) + l%val(lpnt) = a%val(k) + end if + end if + end do + end do loop4 + !$omp end parallel do + call l%set_nzeros(lnz) + call l%fix(info) + end if + nzout = l%get_nzeros() + if (rscale_) then + !$omp workshare + l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if + end block +#else nz = a%get_nzeros() call l%allocate(mb,nb,nz) @@ -2347,7 +2507,7 @@ subroutine psb_z_csr_tril(a,l,info,& call l%set_triangle(.true.) call l%set_lower(.true.) end if - +#endif if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2431,6 +2591,158 @@ subroutine psb_z_csr_triu(a,u,info,& endif +#if defined(OPENMP) + block + integer(psb_ipk_), allocatable :: lrws(:),urws(:) + integer(psb_ipk_) :: lpnt, upnt, lnz, unz + call psb_realloc(mb,urws,info) + !$omp workshare + urws(:) = 0 + !$omp end workshare + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + !write(0,*) 'Invocation of COO%TRIL', present(u),nz + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + if (info == 0) call psb_realloc(mb,urws,info) + !$omp workshare + lrws(:) = 0 + !$omp end workshare + !write(0,*) 'omp version of COO%TRIL/TRIU' + lnz = 0 + unz = 0 + !$omp parallel do private(i,j,k) shared(imin_,imax_,a,lrws,urws) reduction(+: lnz,unz) + loop1: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)=diag_) then + !$omp atomic update + urws(i-imin_+1) = urws(i-imin_+1) +1 + !$omp end atomic + unz = unz + 1 + end if + end if + end do + end do loop3 + !$omp end parallel do + call psi_exscan(mb,urws,info) + !$omp parallel do private(i,j,k,upnt) shared(imin_,imax_,a) + loop4: do i=imin_,imax_ + do k = a%irp(i),a%irp(i+1)-1 + j = a%ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((j-i)>=diag_) then + !$omp atomic capture + urws(i-imin_+1) = urws(i-imin_+1) +1 + upnt = urws(i-imin_+1) + !$omp end atomic + u%ia(upnt) = i + u%ja(upnt) = a%ja(k) + u%val(upnt) = a%val(k) + end if + end if + end do + end do loop4 + !$omp end parallel do + call u%set_nzeros(unz) + call u%fix(info) + end if + nzout = u%get_nzeros() + if (rscale_) then + !$omp workshare + u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + !$omp end workshare + end if + if (cscale_) then + !$omp workshare + u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + !$omp end workshare + end if + + if ((diag_ >= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_upper(.true.) + end if + end block + + +#else + nz = a%get_nzeros() call u%allocate(mb,nb,nz) @@ -2499,7 +2811,7 @@ subroutine psb_z_csr_triu(a,u,info,& call u%set_triangle(.true.) call u%set_upper(.true.) end if - +#endif if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2844,6 +3156,9 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) use psb_realloc_mod use psb_z_base_mat_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_cp_csr_from_coo +#if defined(OPENMP) + use omp_lib +#endif implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a @@ -2860,12 +3175,6 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) character(len=20) :: name='z_cp_csr_from_coo' logical :: use_openmp = .false. - !$ integer(psb_ipk_), allocatable :: sum(:) - !$ integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s,j - !$ integer(psb_ipk_) :: nxt_val,old_val,saved_elem,maxthreads - !$ use_openmp = .true. - - info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2904,98 +3213,39 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) if (info == psb_success_) call psb_safe_ab_cpy(b%ja,a%ja,info) if (info == psb_success_) call psb_safe_ab_cpy(b%val,a%val,info) if (info == psb_success_) call psb_realloc(max(nr+1,nc+1),a%irp,info) - + endif + +#if defined(OPENMP) + + !$OMP PARALLEL default(shared) reduction(max:info) + + !$OMP WORKSHARE a%irp(:) = 0 - -!!$ if (use_openmp) then -!!$ !$ maxthreads = omp_get_max_threads() -!!$ !$ allocate(sum(maxthreads+1)) -!!$ !$ sum(:) = 0 -!!$ !$ sum(1) = 1 -!!$ -!!$ !$OMP PARALLEL default(none) & -!!$ !$OMP shared(nza,itemp,a,nthreads,sum,nr) & -!!$ !$OMP private(ithread,work,first_idx,last_idx,s,saved_elem,nxt_val,old_val) -!!$ -!!$ !$OMP DO schedule(STATIC) & -!!$ !$OMP private(k,i) -!!$ do k=1,nza -!!$ i = itemp(k) -!!$ a%irp(i) = a%irp(i) + 1 -!!$ end do -!!$ !$OMP END DO -!!$ -!!$ !$OMP SINGLE -!!$ !$ nthreads = omp_get_num_threads() -!!$ !$OMP END SINGLE -!!$ -!!$ !$ ithread = omp_get_thread_num() -!!$ -!!$ !$ work = nr/nthreads -!!$ !$ if (ithread < MOD(nr,nthreads)) then -!!$ !$ work = work + 1 -!!$ !$ first_idx = ithread*work + 1 -!!$ !$ else -!!$ !$ first_idx = ithread*work + MOD(nr,nthreads) + 1 -!!$ !$ end if -!!$ -!!$ !$ last_idx = first_idx + work - 1 -!!$ -!!$ !$ s = 0 -!!$ !$ do i=first_idx,last_idx -!!$ !$ s = s + a%irp(i) -!!$ !$ end do -!!$ !$ if (work > 0) then -!!$ !$ sum(ithread+2) = s -!!$ !$ end if -!!$ -!!$ !$OMP BARRIER -!!$ -!!$ !$OMP SINGLE -!!$ !$ do i=2,nthreads+1 -!!$ !$ sum(i) = sum(i) + sum(i-1) -!!$ !$ end do -!!$ !$OMP END SINGLE -!!$ -!!$ !$ if (work > 0) then -!!$ !$ saved_elem = a%irp(first_idx) -!!$ !$ end if -!!$ !$ if (ithread == 0) then -!!$ !$ a%irp(1) = 1 -!!$ !$ end if -!!$ -!!$ !$OMP BARRIER -!!$ -!!$ !$ if (work > 0) then -!!$ !$ old_val = a%irp(first_idx+1) -!!$ !$ a%irp(first_idx+1) = saved_elem + sum(ithread+1) -!!$ !$ end if -!!$ -!!$ !$ do i=first_idx+2,last_idx+1 -!!$ !$ nxt_val = a%irp(i) -!!$ !$ a%irp(i) = a%irp(i-1) + old_val -!!$ !$ old_val = nxt_val -!!$ !$ end do -!!$ -!!$ !$OMP END PARALLEL -!!$ else - - do k=1,nza - i = itemp(k) - a%irp(i) = a%irp(i) + 1 - end do - ip = 1 - do i=1,nr - ncl = a%irp(i) - a%irp(i) = ip - ip = ip + ncl - end do - a%irp(nr+1) = ip -!!$ end if - call a%set_host() + !$OMP END WORKSHARE + + !$OMP DO schedule(STATIC) & + !$OMP private(k,i) + do k=1,nza + i = itemp(k) + !$OMP ATOMIC UPDATE + a%irp(i) = a%irp(i) + 1 + !$OMP END ATOMIC + end do + !$OMP END DO + call psi_exscan(nr+1,a%irp,info,shift=ione) + !$OMP END PARALLEL +#else + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + call psi_exscan(nr+1,a%irp,info,shift=ione) +#endif + call a%set_host() end subroutine psb_z_cp_csr_from_coo @@ -3096,6 +3346,9 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) use psb_error_mod use psb_z_base_mat_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_mv_csr_from_coo +#if defined(OPENMP) + use omp_lib +#endif implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a @@ -3109,13 +3362,6 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='mv_from_coo' - logical :: use_openmp = .false. - - ! $ integer(psb_ipk_), allocatable :: sum(:) - ! $ integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s - ! $ integer(psb_ipk_) :: nxt_val,old_val,saved_elem - ! $ use_openmp = .true. - info = psb_success_ debug_unit = psb_get_debug_unit() @@ -3139,90 +3385,34 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) call psb_realloc(max(nr+1,nc+1),a%irp,info) call b%free() +#if defined(OPENMP) + !$OMP PARALLEL default(shared) reduction(max:info) + + !$OMP WORKSHARE a%irp(:) = 0 + !$OMP END WORKSHARE + + !$OMP DO schedule(STATIC) & + !$OMP private(k,i) + do k=1,nza + i = itemp(k) + !$OMP ATOMIC UPDATE + a%irp(i) = a%irp(i) + 1 + !$OMP END ATOMIC + end do + !$OMP END DO + call psi_exscan(nr+1,a%irp,info,shift=ione) + !$OMP END PARALLEL +#else + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + call psi_exscan(nr+1,a%irp,info,shift=ione) +#endif -!!$ if (use_openmp) then -!!$ !$OMP PARALLEL default(none) & -!!$ !$OMP shared(sum,nthreads,nr,a,itemp,nza) & -!!$ !$OMP private(ithread,work,first_idx,last_idx,s,saved_elem,nxt_val,old_val) -!!$ -!!$ !$OMP DO schedule(STATIC) & -!!$ !$OMP private(k,i) -!!$ do k=1,nza -!!$ i = itemp(k) -!!$ a%irp(i) = a%irp(i) + 1 -!!$ end do -!!$ !$OMP END DO -!!$ -!!$ !$OMP SINGLE -!!$ !$ nthreads = omp_get_num_threads() -!!$ !$ allocate(sum(nthreads+1)) -!!$ !$ sum(:) = 0 -!!$ !$ sum(1) = 1 -!!$ !$OMP END SINGLE -!!$ -!!$ !$ ithread = omp_get_thread_num() -!!$ -!!$ !$ work = nr/nthreads -!!$ !$ if (ithread < MOD(nr,nthreads)) then -!!$ !$ work = work + 1 -!!$ !$ first_idx = ithread*work + 1 -!!$ !$ else -!!$ !$ first_idx = ithread*work + MOD(nr,nthreads) + 1 -!!$ !$ end if -!!$ -!!$ !$ last_idx = first_idx + work - 1 -!!$ -!!$ !$ s = 0 -!!$ !$ do i=first_idx,last_idx -!!$ !$ s = s + a%irp(i) -!!$ !$ end do -!!$ !$ if (work > 0) then -!!$ !$ sum(ithread+2) = s -!!$ !$ end if -!!$ -!!$ !$OMP BARRIER -!!$ -!!$ !$OMP SINGLE -!!$ !$ do i=2,nthreads+1 -!!$ !$ sum(i) = sum(i) + sum(i-1) -!!$ !$ end do -!!$ !$OMP END SINGLE -!!$ -!!$ !$ if (work > 0) then -!!$ !$ saved_elem = a%irp(first_idx) -!!$ !$ end if -!!$ !$ if (ithread == 0) then -!!$ !$ a%irp(1) = 1 -!!$ !$ end if -!!$ -!!$ !$ if (work > 0) then -!!$ !$ old_val = a%irp(first_idx+1) -!!$ !$ a%irp(first_idx+1) = saved_elem + sum(ithread+1) -!!$ !$ end if -!!$ -!!$ !$ do i=first_idx+2,last_idx+1 -!!$ !$ nxt_val = a%irp(i) -!!$ !$ a%irp(i) = a%irp(i-1) + old_val -!!$ !$ old_val = nxt_val -!!$ !$ end do -!!$ -!!$ !$OMP END PARALLEL -!!$ else - do k=1,nza - i = itemp(k) - a%irp(i) = a%irp(i) + 1 - end do - ip = 1 - do i=1,nr - ncl = a%irp(i) - a%irp(i) = ip - ip = ip + ncl - end do - a%irp(nr+1) = ip -!!$ end if - call a%set_host() end subroutine psb_z_mv_csr_from_coo @@ -3300,9 +3490,28 @@ subroutine psb_z_cp_csr_to_fmt(a,b,info) b%psb_z_base_sparse_mat = a%psb_z_base_sparse_mat nr = a%get_nrows() nz = a%get_nzeros() - if (info == 0) call psb_safe_cpy( a%irp(1:nr+1), b%irp , info) - if (info == 0) call psb_safe_cpy( a%ja(1:nz), b%ja , info) - if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + if (.false.) then + if (info == 0) call psb_safe_cpy( a%irp(1:nr+1), b%irp , info) + if (info == 0) call psb_safe_cpy( a%ja(1:nz), b%ja , info) + if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + else + ! Despite the implementation in safe_cpy, it seems better this way + call psb_realloc(nr+1,b%irp,info) + call psb_realloc(nz,b%ja,info) + call psb_realloc(nz,b%val,info) + !$omp parallel do private(i) schedule(static) + do i=1,nr+1 + b%irp(i)=a%irp(i) + end do + !$omp end parallel do + !$omp parallel do private(j) schedule(static) + do j=1,nz + b%ja(j) = a%ja(j) + b%val(j) = a%val(j) + end do + !$omp end parallel do + end if + call b%set_host() class default @@ -3386,9 +3595,27 @@ subroutine psb_z_cp_csr_from_fmt(a,b,info) a%psb_z_base_sparse_mat = b%psb_z_base_sparse_mat nr = b%get_nrows() nz = b%get_nzeros() - if (info == 0) call psb_safe_cpy( b%irp(1:nr+1), a%irp , info) - if (info == 0) call psb_safe_cpy( b%ja(1:nz) , a%ja , info) - if (info == 0) call psb_safe_cpy( b%val(1:nz) , a%val , info) + if (.false.) then + if (info == 0) call psb_safe_cpy( b%irp(1:nr+1), a%irp , info) + if (info == 0) call psb_safe_cpy( b%ja(1:nz) , a%ja , info) + if (info == 0) call psb_safe_cpy( b%val(1:nz) , a%val , info) + else + ! Despite the implementation in safe_cpy, it seems better this way + call psb_realloc(nr+1,a%irp,info) + call psb_realloc(nz,a%ja,info) + call psb_realloc(nz,a%val,info) + !$omp parallel do private(i) schedule(static) + do i=1,nr+1 + a%irp(i)=b%irp(i) + end do + !$omp end parallel do + !$omp parallel do private(j) schedule(static) + do j=1,nz + a%ja(j)=b%ja(j) + a%val(j)=b%val(j) + end do + !$omp end parallel do + end if call a%set_host() class default @@ -3427,6 +3654,540 @@ subroutine psb_z_csr_clean_zeros(a, info) call a%set_host() end subroutine psb_z_csr_clean_zeros +#if defined(OPENMP) +subroutine psb_zcsrspspmm(a,b,c,info) + use psb_z_mat_mod + use psb_serial_mod, psb_protect_name => psb_zcsrspspmm + + implicit none + + class(psb_z_csr_sparse_mat), intent(in) :: a,b + type(psb_z_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: ma,na,mb,nb, nzc, nza, nzb + character(len=20) :: name + integer(psb_ipk_) :: err_act + name='psb_csrspspmm' + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + if (b%is_dev()) call b%sync() + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb + info = psb_err_invalid_matrix_sizes_ + call psb_errpush(info,name) + goto 9999 + endif + + select case(spspmm_impl) + case (spspmm_serial) + ! Estimate number of nonzeros on output. + nza = a%get_nzeros() + nzb = b%get_nzeros() + nzc = 2*(nza+nzb) + call c%allocate(ma,nb,nzc) + + call csr_spspmm(a,b,c,info) + case (spspmm_omp_gustavson) + call spmm_omp_gustavson(a,b,c,info) + case (spspmm_omp_gustavson_1d) + call spmm_omp_gustavson_1d(a,b,c,info) + case (spspmm_serial_rb_tree) + call spmm_serial_rb_tree(a,b,c,info) + case (spspmm_omp_rb_tree) + call spmm_omp_rb_tree(a,b,c,info) + case (spspmm_omp_two_pass) + call spmm_omp_two_pass(a,b,c,info) + case default + write(psb_err_unit,*) 'Unknown spspmm implementation' + ! push error + goto 9999 + end select + + call c%set_asb() + call c%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csr_spspmm(a,b,c,info) + implicit none + type(psb_z_csr_sparse_mat), intent(in) :: a,b + type(psb_z_csr_sparse_mat), intent(inout) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: ma,na,mb,nb + integer(psb_ipk_), allocatable :: irow(:), idxs(:) + complex(psb_dpk_), allocatable :: row(:) + integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, & + & nzc,nnzre, isz, ipb, irwsz, nrc, nze + complex(psb_dpk_) :: cfb + + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = min(size(c%val),size(c%ja)) + isz = max(ma,na,mb,nb) + call psb_realloc(isz,row,info) + if (info == 0) call psb_realloc(isz,idxs,info) + if (info == 0) call psb_realloc(isz,irow,info) + if (info /= 0) return + row = dzero + irow = 0 + nzc = 1 + do j = 1,ma + c%irp(j) = nzc + nrc = 0 + do k = a%irp(j), a%irp(j+1)-1 + irw = a%ja(k) + cfb = a%val(k) + irwsz = b%irp(irw+1)-b%irp(irw) + do i = b%irp(irw),b%irp(irw+1)-1 + icl = b%ja(i) + if (irow(icl) 0 ) then + if ((nzc+nrc)>nze) then + nze = max(ma*((nzc+j-1)/j),nzc+2*nrc) + call psb_realloc(nze,c%val,info) + if (info == 0) call psb_realloc(nze,c%ja,info) + if (info /= 0) return + end if + + call psb_qsort(idxs(1:nrc)) + do i=1, nrc + irw = idxs(i) + c%ja(nzc) = irw + c%val(nzc) = row(irw) + row(irw) = dzero + nzc = nzc + 1 + end do + end if + end do + + c%irp(ma+1) = nzc + end subroutine csr_spspmm + + ! gustavson's algorithm using perfect hashing + ! and OpenMP parallelisation + subroutine spmm_omp_gustavson(a,b,c,info) + use omp_lib + + implicit none + type(psb_z_csr_sparse_mat), intent(in) :: a,b + type(psb_z_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + complex(psb_dpk_), allocatable :: vals(:), acc(:) + integer(psb_ipk_) :: ma, nb + integer(psb_ipk_), allocatable :: col_inds(:), offsets(:) + integer(psb_ipk_) :: irw, jj, j, k, nnz, rwnz, thread_upperbound, start_idx, end_idx + + ma = a%get_nrows() + nb = b%get_ncols() + + call c%allocate(ma, nb) + c%irp(1) = 1 + + ! dense accumulator + ! https://sc18.supercomputing.org/proceedings/workshops/workshop_files/ws_lasalss115s2-file1.pdf + call psb_realloc(nb, acc, info) + + allocate(offsets(omp_get_max_threads())) + !$omp parallel private(vals,col_inds,nnz,rwnz,thread_upperbound,acc,start_idx,end_idx) & + !$omp shared(a,b,c,offsets) + thread_upperbound = 0 + start_idx = 0 + !$omp do schedule(static) private(irw, jj, j) + do irw = 1, ma + if (start_idx == 0) then + start_idx = irw + end if + end_idx = irw + do jj = a%irp(irw), a%irp(irw + 1) - 1 + j = a%ja(jj) + thread_upperbound = thread_upperbound + b%irp(j+1) - b%irp(j) + end do + end do + !$omp end do + + call psb_realloc(thread_upperbound, vals, info) + call psb_realloc(thread_upperbound, col_inds, info) + + ! possible bottleneck + acc = 0 + + nnz = 0 + !$omp do schedule(static) private(irw, jj, j, k) + do irw = 1, ma + rwnz = 0 + do jj = a%irp(irw), a%irp(irw + 1) - 1 + j = a%ja(jj) + do k = b%irp(j), b%irp(j + 1) - 1 + if (acc(b%ja(k)) == 0) then + nnz = nnz + 1 + rwnz = rwnz + 1 + col_inds(nnz) = b%ja(k) + end if + acc(b%ja(k)) = acc(b%ja(k)) + a%val(jj) * b%val(k) + end do + end do + call psb_qsort(col_inds(nnz - rwnz + 1:nnz)) + + do k = nnz - rwnz + 1, nnz + vals(k) = acc(col_inds(k)) + acc(col_inds(k)) = 0 + end do + c%irp(irw + 1) = rwnz + end do + !$omp end do + + offsets(omp_get_thread_num() + 1) = nnz + !$omp barrier + + ! possible bottleneck + !$omp single + do k = 1, omp_get_num_threads() - 1 + offsets(k + 1) = offsets(k + 1) + offsets(k) + end do + !$omp end single + + !$omp barrier + + if (omp_get_thread_num() /= 0) then + c%irp(start_idx) = offsets(omp_get_thread_num()) + 1 + end if + + do irw = start_idx, end_idx - 1 + c%irp(irw + 1) = c%irp(irw + 1) + c%irp(irw) + end do + + !$omp barrier + + !$omp single + c%irp(ma + 1) = c%irp(ma + 1) + c%irp(ma) + call psb_realloc(c%irp(ma + 1), c%val, info) + call psb_realloc(c%irp(ma + 1), c%ja, info) + !$omp end single + + c%val(c%irp(start_idx):c%irp(end_idx + 1) - 1) = vals(1:nnz) + c%ja(c%irp(start_idx):c%irp(end_idx + 1) - 1) = col_inds(1:nnz) + !$omp end parallel + end subroutine spmm_omp_gustavson + + subroutine spmm_omp_gustavson_1d(a,b,c,info) + use omp_lib + + implicit none + type(psb_z_csr_sparse_mat), intent(in) :: a,b + type(psb_z_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + complex(psb_dpk_), allocatable :: vals(:), acc(:) + integer(psb_ipk_) :: ma, nb + integer(psb_ipk_), allocatable :: col_inds(:), offsets(:) + integer(psb_ipk_) :: irw, jj, j, k, nnz, rwnz, thread_upperbound, & + start_idx, end_idx , blk, blk_size, rwstart,& + rwblk, rwblkrem, nblks + + ma = a%get_nrows() + nb = b%get_ncols() + + call c%allocate(ma, nb) + c%irp(1) = 1 + + ! dense accumulator + ! https://sc18.supercomputing.org/proceedings/workshops/workshop_files/ws_lasalss115s2-file1.pdf + call psb_realloc(nb, acc, info) + allocate(offsets(omp_get_max_threads())) + + nblks = 4 * omp_get_max_threads() + rwblk = (ma / nblks) + rwblkrem = modulo(ma, nblks) + !$omp parallel private(vals,col_inds,nnz,thread_upperbound,acc,start_idx,end_idx) shared(a,b,c,offsets) + thread_upperbound = 0 + start_idx = 0 + !$omp do schedule(static) private(irw, jj, j) + do irw = 1, ma + do jj = a%irp(irw), a%irp(irw + 1) - 1 + j = a%ja(jj) + thread_upperbound = thread_upperbound + b%irp(j+1) - b%irp(j) + end do + end do + !$omp end do + + call psb_realloc(thread_upperbound, vals, info) + call psb_realloc(thread_upperbound, col_inds, info) + + ! possible bottleneck + acc = 0 + + nnz = 0 + !$omp do schedule(static) private(irw,jj,j,k,rwnz,blk,blk_size,rwstart) + do blk = 0, nblks - 1 + if (blk < rwblkrem) then + blk_size = rwblk + 1 + rwstart = blk * rwblk + blk + 1 + else + blk_size = rwblk + rwstart = blk * rwblk & + + rwblkrem + 1 + end if + do irw = rwstart, rwstart + blk_size - 1 + if (start_idx == 0) then + start_idx = irw + end if + end_idx = irw + rwnz = 0 + do jj = a%irp(irw), a%irp(irw + 1) - 1 + j = a%ja(jj) + do k = b%irp(j), b%irp(j + 1) - 1 + if (acc(b%ja(k)) == 0) then + nnz = nnz + 1 + rwnz = rwnz + 1 + col_inds(nnz) = b%ja(k) + end if + acc(b%ja(k)) = acc(b%ja(k)) + a%val(jj) * b%val(k) + end do + end do + call psb_qsort(col_inds(nnz - rwnz + 1:nnz)) + + do k = nnz - rwnz + 1, nnz + vals(k) = acc(col_inds(k)) + acc(col_inds(k)) = 0 + end do + c%irp(irw + 1) = rwnz + end do + end do + !$omp end do + + offsets(omp_get_thread_num() + 1) = nnz + !$omp barrier + + ! possible bottleneck + !$omp single + do k = 1, omp_get_num_threads() - 1 + offsets(k + 1) = offsets(k + 1) + offsets(k) + end do + !$omp end single + + !$omp barrier + + if (omp_get_thread_num() /= 0) then + c%irp(start_idx) = offsets(omp_get_thread_num()) + 1 + end if + + do irw = start_idx, end_idx - 1 + c%irp(irw + 1) = c%irp(irw + 1) + c%irp(irw) + end do + + !$omp barrier + + !$omp single + c%irp(ma + 1) = c%irp(ma + 1) + c%irp(ma) + call psb_realloc(c%irp(ma + 1), c%val, info) + call psb_realloc(c%irp(ma + 1), c%ja, info) + !$omp end single + + c%val(c%irp(start_idx):c%irp(end_idx + 1) - 1) = vals(1:nnz) + c%ja(c%irp(start_idx):c%irp(end_idx + 1) - 1) = col_inds(1:nnz) + !$omp end parallel + end subroutine spmm_omp_gustavson_1d + + subroutine spmm_serial_rb_tree(a,b,c,info) + use psb_rb_idx_tree_mod + implicit none + type(psb_z_csr_sparse_mat), intent(in) :: a,b + type(psb_z_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: a_m, b_n + integer(psb_ipk_) :: row, col + type(psb_z_rb_idx_tree), allocatable :: row_accs(:) + + a_m = a%get_nrows() + b_n = b%get_ncols() + + allocate(row_accs(a_m)) + call c%allocate(a_m, b_n) + + do row = 1, a_m + row_accs(row)%nnz = 0 + nullify(row_accs(row)%root) + do col = a%irp(row), a%irp(row + 1) - 1 + call psb_rb_idx_tree_scalar_sparse_row_mul(row_accs(row), a%val(col), b, a%ja(col)) + end do + end do + call psb_rb_idx_tree_merge(row_accs, c) + + deallocate(row_accs) + + info = 0 + end subroutine spmm_serial_rb_tree + + subroutine spmm_omp_rb_tree(a,b,c,info) + use omp_lib + use psb_rb_idx_tree_mod + implicit none + type(psb_z_csr_sparse_mat), intent(in) :: a,b + type(psb_z_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: a_m, b_n + integer(psb_ipk_) :: row, col + type(psb_z_rb_idx_tree), allocatable :: row_accs(:) + real(8) :: tic, toc + + a_m = a%get_nrows() + b_n = b%get_ncols() + + call c%allocate(a_m, b_n) + + allocate(row_accs(a_m)) + call c%allocate(a_m, b_n) + + !$omp parallel do schedule(static) + do row = 1, a_m + row_accs(row)%nnz = 0 + nullify(row_accs(row)%root) + do col = a%irp(row), a%irp(row + 1) - 1 + call psb_rb_idx_tree_scalar_sparse_row_mul(row_accs(row), a%val(col), b, a%ja(col)) + end do + end do + !$omp end parallel do + + call psb_rb_idx_tree_merge(row_accs, c) + + deallocate(row_accs) + info = 0 + end subroutine spmm_omp_rb_tree + + subroutine compute_indices(a, b, c, info) + implicit none + type(psb_z_csr_sparse_mat), intent(in) :: a,b + type(psb_z_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + integer :: full_mat_bound + integer :: row, col, i, j, k, nnz + + full_mat_bound = 0 + !omp parallel do schedule(static) reduction(+:full_mat_bound) + do row = 1, a%get_nrows() + do col = a%irp(row), a%irp(row + 1) - 1 + j = a%ja(col) + full_mat_bound = full_mat_bound + b%irp(j+1) - b%irp(j) + end do + end do + !omp end parallel do + + call psb_realloc(a%get_nrows() + 1, c%irp, info) + call psb_realloc(full_mat_bound, c%ja, info) + c%ja = 0 + c%irp(1) = 1 + + nnz = 0 + + do row = 1, a%get_nrows() + do col = a%irp(row), a%irp(row + 1) - 1 + do i = b%irp(a%ja(col)), b%irp(a%ja(col) + 1) - 1 + k = 0 + do while(c%ja(c%irp(row) + k) /= 0 .and. c%ja(c%irp(row) + k) /= b%ja(i)) + k = k + 1 + end do + if (c%ja(c%irp(row) + k) == 0) then + c%ja(c%irp(row)+k) = b%ja(i) + nnz = nnz + 1 + end if + end do + end do + c%irp(row + 1) = nnz + 1 + call psb_qsort(c%ja(c%irp(row):c%irp(row + 1)-1)) + end do + + + call psb_realloc(nnz, c%ja, info) + call psb_realloc(nnz, c%val, info) + + c%val = 0 + end subroutine compute_indices + + subroutine direct_scalar_sparse_row_mul(out_mat, out_row_num, scalar, mat, trgt_row_num) + type(psb_z_csr_sparse_mat), intent(inout) :: out_mat + integer(psb_ipk_), intent(in) :: out_row_num + complex(psb_dpk_), intent(in) :: scalar + type(psb_z_csr_sparse_mat), intent(in) :: mat + integer(psb_ipk_), intent(in) :: trgt_row_num + + integer(psb_ipk_) :: i, k, row_start, row_end + + row_start = out_mat%irp(out_row_num) + row_end = out_mat%irp(out_row_num + 1) - 1 + + do i = mat%irp(trgt_row_num), mat%irp(trgt_row_num + 1) - 1 + do k = out_mat%irp(out_row_num), out_mat%irp(out_row_num + 1) - 1 + if (out_mat%ja(k) == mat%ja(i)) then + out_mat%val(k) = out_mat%val(k) + scalar * mat%val(i) + exit + end if + end do + end do + + end subroutine direct_scalar_sparse_row_mul + + subroutine spmm_omp_two_pass(a,b,c,info) + use omp_lib + + implicit none + type(psb_z_csr_sparse_mat), intent(in) :: a,b + type(psb_z_csr_sparse_mat), intent(out):: c + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: a_m, b_n, row, col + + a_m = a%get_nrows() + b_n = b%get_ncols() + + call c%allocate(a_m, b_n) + + call compute_indices(a, b, c, info) + + !$omp parallel do schedule(static) + do row = 1, a_m + do col = a%irp(row), a%irp(row + 1) - 1 + call direct_scalar_sparse_row_mul(c, row, a%val(col), b, a%ja(col)) + end do + end do + !$omp end parallel do + end subroutine spmm_omp_two_pass + +end subroutine psb_zcsrspspmm + +#else + subroutine psb_zcsrspspmm(a,b,c,info) use psb_z_mat_mod use psb_serial_mod, psb_protect_name => psb_zcsrspspmm @@ -3810,7 +4571,6 @@ subroutine psb_z_cp_ecsr_from_fmt(a,b,info) end subroutine psb_z_cp_ecsr_from_fmt - ! ! ! lz version diff --git a/base/serial/impl/psb_z_rb_idx_tree_impl.F90 b/base/serial/impl/psb_z_rb_idx_tree_impl.F90 new file mode 100644 index 000000000..88ab214ba --- /dev/null +++ b/base/serial/impl/psb_z_rb_idx_tree_impl.F90 @@ -0,0 +1,329 @@ +! +! 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. +! +! +! +! package: psb_z_rb_idx_tree_impl +! +! Red black tree implementation ordered by index +! +! Each node contains and index and a double precision value +! +! The tree should always be well balanced +! +! inserting a node with an existing index will +! add up the new value to the old one +! Contributed by Dimitri Walther +! +subroutine psb_z_rb_idx_tree_insert(this, idx, val) + use psb_z_rb_idx_tree_mod, psb_protect_name => psb_z_rb_idx_tree_insert + implicit none + class(psb_z_rb_idx_tree), intent(inout) :: this + integer(psb_ipk_), intent(in) :: idx + complex(psb_dpk_), intent(in) :: val + + character(len=22) :: name + type(psb_z_rb_idx_node), pointer :: new_node + type(psb_z_rb_idx_node), pointer :: current, previous + name='psb_rb_idx_tree_insert' + + allocate(new_node) + new_node%idx = idx + new_node%val = val + nullify(new_node%left) + nullify(new_node%right) + nullify(new_node%parent) + new_node%is_red = .true. + + + if (.not. associated(this%root)) then + this%root => new_node + this%nnz = 1 + new_node%is_red = .false. + return + end if + + current => this%root + + do while (associated(current)) + previous => current + + if (idx == current%idx) then + current%val = current%val + val + deallocate(new_node) + return + else if (idx < current%idx) then + current => current%left + else + + current => current%right + end if + end do + + if (idx < previous%idx) then + new_node%parent => previous + previous%left => new_node + else + new_node%parent => previous + previous%right => new_node + end if + + call psb_z_rb_idx_tree_fix_insertion(this, new_node) + + this%nnz = this%nnz + 1 +end subroutine psb_z_rb_idx_tree_insert + +subroutine psb_z_rb_idx_tree_fix_insertion(this, node) + use psb_z_rb_idx_tree_mod, psb_protect_name => psb_z_rb_idx_tree_fix_insertion + implicit none + class(psb_z_rb_idx_tree), intent(inout) :: this + type(psb_z_rb_idx_node), pointer, intent(inout) :: node + + character(len=29) :: name + type(psb_z_rb_idx_node), pointer :: current, parent, grand_parent, uncle + name = 'psb_rb_idx_tree_fix_insertion' + + current => node + parent => current%parent + do while(associated(parent) .and. parent%is_red) + ! grand parent exist because root can't be red + grand_parent => parent%parent + if (parent%idx < grand_parent%idx) then + uncle => grand_parent%right + else + uncle => grand_parent%left + end if + + if (associated(uncle) .and. uncle%is_red) then + parent%is_red = .false. + uncle%is_red = .false. + grand_parent%is_red = .true. + current => grand_parent + parent => current%parent + + ! Left-Left case + else if (current%idx < parent%idx .and. & + parent%idx < grand_parent%idx) then + call psb_z_rb_idx_tree_rotate_right(grand_parent) + call psb_z_rb_idx_tree_swap_colors(parent, grand_parent) + + if (this%root%idx == grand_parent%idx) this%root => parent + + return + ! Left-Right case + else if (current%idx > parent%idx .and. & + parent%idx < grand_parent%idx) then + call psb_z_rb_idx_tree_rotate_left(parent) + call psb_z_rb_idx_tree_rotate_right(grand_parent) + call psb_z_rb_idx_tree_swap_colors(current, grand_parent) + + if (this%root%idx == grand_parent%idx) this%root => current + + return + ! Right-Right case + else if (current%idx > parent%idx .and. & + parent%idx > grand_parent%idx) then + call psb_z_rb_idx_tree_rotate_left(grand_parent) + call psb_z_rb_idx_tree_swap_colors(parent, grand_parent) + + if (this%root%idx == grand_parent%idx) this%root => parent + + return + ! Right-Left case + else + call psb_z_rb_idx_tree_rotate_right(parent) + call psb_z_rb_idx_tree_rotate_left(grand_parent) + call psb_z_rb_idx_tree_swap_colors(current, grand_parent) + + if (this%root%idx == grand_parent%idx) this%root => current + + return + end if + end do + + this%root%is_red = .false. +end subroutine psb_z_rb_idx_tree_fix_insertion + +subroutine psb_z_rb_idx_tree_swap_colors(n1, n2) + use psb_z_rb_idx_tree_mod, psb_protect_name => psb_z_rb_idx_tree_swap_colors + implicit none + type(psb_z_rb_idx_node), pointer, intent(inout) :: n1, n2 + + character(len=27) :: name + logical :: tmp + name='psb_rb_idx_tree_swap_colors' + + tmp = n1%is_red + n1%is_red = n2%is_red + n2%is_red = tmp +end subroutine psb_z_rb_idx_tree_swap_colors + +subroutine psb_z_rb_idx_tree_rotate_right(node) + use psb_z_rb_idx_tree_mod, psb_protect_name => psb_z_rb_idx_tree_rotate_right + implicit none + type(psb_z_rb_idx_node), pointer, intent(inout) :: node + + character(len=28) :: name + type(psb_z_rb_idx_node), pointer :: l, lr + name='psb_rb_idx_tree_rotate_right' + + if (.not. associated(node%left)) return + + l => node%left + lr => l%right + node%left => lr + + if (associated(lr)) lr%parent => node + + if (associated(node%parent)) then + if (node%idx < node%parent%idx) then + node%parent%left => l + else + node%parent%right => l + end if + end if + + l%parent => node%parent + node%parent => l + + l%right => node +end subroutine psb_z_rb_idx_tree_rotate_right + +subroutine psb_z_rb_idx_tree_rotate_left(node) + use psb_z_rb_idx_tree_mod, psb_protect_name => psb_z_rb_idx_tree_rotate_left + implicit none + type(psb_z_rb_idx_node), pointer, intent(inout) :: node + + character(len=27) :: name + type(psb_z_rb_idx_node), pointer :: r, rl + name='psb_rb_idx_tree_rotate_left' + + if (.not. associated(node%right)) return + + r => node%right + rl => r%left + node%right => rl + + if (associated(rl)) rl%parent => node + + if (associated(node%parent)) then + if (node%idx < node%parent%idx) then + node%parent%left => r + else + node%parent%right => r + end if + end if + + r%parent => node%parent + node%parent => r + + r%left => node +end subroutine psb_z_rb_idx_tree_rotate_left + +subroutine psb_z_rb_idx_tree_scalar_sparse_row_mul(tree, scalar, mat, row_num) + use psb_z_rb_idx_tree_mod, psb_protect_name => psb_z_rb_idx_tree_scalar_sparse_row_mul + use psb_z_csr_mat_mod, only : psb_z_csr_sparse_mat + implicit none + type(psb_z_rb_idx_tree), intent(inout) :: tree + complex(psb_dpk_), intent(in) :: scalar + type(psb_z_csr_sparse_mat), intent(in) :: mat + integer(psb_ipk_), intent(in) :: row_num + + character(len=37) :: name + integer(psb_ipk_) :: i + name='psb_rb_idx_tree_scalar_sparse_row_mul' + + do i = mat%irp(row_num), mat%irp(row_num + 1) - 1 + call tree%insert(mat%ja(i),scalar * mat%val(i)) + end do + +end subroutine psb_z_rb_idx_tree_scalar_sparse_row_mul + +subroutine psb_z_rb_idx_tree_merge(trees, mat) +#if defined(OPENMP) + use omp_lib +#endif + use psb_realloc_mod + use psb_z_rb_idx_tree_mod, psb_protect_name => psb_z_rb_idx_tree_merge + use psb_z_csr_mat_mod, only : psb_z_csr_sparse_mat + implicit none + type(psb_z_rb_idx_tree), allocatable, intent(inout) :: trees(:) + type(psb_z_csr_sparse_mat), intent(inout) :: mat + + character(len=21) :: name + integer(psb_ipk_) :: i, j, rows, info, nnz + type(psb_z_rb_idx_node), pointer :: current, previous + name='psb_rb_idx_tree_merge' + + rows = size(trees) + + mat%irp(1) = 1 + + do i=1, rows + mat%irp(i + 1) = mat%irp(i) + trees(i)%nnz + end do + + nnz = mat%irp(rows + 1) + call psb_realloc(nnz, mat%val, info) + call psb_realloc(nnz, mat%ja, info) + +#if defined(OPENMP) + !$omp parallel do schedule(static), private(current, previous, j) +#endif + do i = 1, size(trees) + j = 0 + current => trees(i)%root + do while(associated(current)) + ! go to the left-most node + do while(associated(current%left)) + current => current%left + end do + mat%val(j + mat%irp(i)) = current%val + mat%ja(j + mat%irp(i)) = current%idx + j = j + 1 + + previous => current + if (associated(current%right)) then + if (associated(current%parent)) then + current%parent%left => current%right + end if + current%right%parent => current%parent + current => current%right + else + current => current%parent + if (associated(current)) nullify(current%left) + end if + deallocate(previous) + end do + end do +#if defined(OPENMP) + !$omp end parallel do +#endif +end subroutine psb_z_rb_idx_tree_merge diff --git a/base/serial/psi_c_serial_impl.F90 b/base/serial/psi_c_serial_impl.F90 index 1da2ce6ee..a3898349b 100644 --- a/base/serial/psi_c_serial_impl.F90 +++ b/base/serial/psi_c_serial_impl.F90 @@ -29,6 +29,107 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +subroutine psi_c_exscanv(n,x,info,shift) + use psi_c_serial_mod, psb_protect_name => psi_c_exscanv + use psb_const_mod + use psb_error_mod +#if defined(OPENMP) + use omp_lib +#endif + implicit none + integer(psb_ipk_), intent(in) :: n + complex(psb_spk_), intent (inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_), intent(in), optional :: shift + + complex(psb_spk_) :: shift_, tp, ts + integer(psb_ipk_) :: i + logical is_nested, is_parallel + + if (present(shift)) then + shift_ = shift + else + shift_ = czero + end if + +#if defined(OPENMP) + is_parallel = omp_in_parallel() + if (is_parallel) then + call inner_c_exscan() + else + !$OMP PARALLEL default(shared) + call inner_c_exscan() + !$OMP END PARALLEL + end if +#else + tp = shift_ + do i=1,n + ts = x(i) + x(i) = tp + tp = tp + ts + end do + +#endif +#if defined(OPENMP) +contains + subroutine inner_c_exscan() + ! Note: all these variables are private, but SUMB should *really* be + ! a pointer. The semantics of COPYPRIVATE is that the POINTER is copied + ! so effectively we are recovering a SHARED SUMB which is what + ! we need in this case. If it was an ALLOCATABLE, then it would be the contents + ! that would get copied, and the SHARED effect would no longer be there. + ! Simple parallel version of EXSCAN + integer(psb_ipk_) :: i,ithread,nthreads,idxstart,idxend,wrk + complex(psb_spk_), pointer :: sumb(:) + complex(psb_spk_) :: tp, ts + + nthreads = omp_get_num_threads() + ithread = omp_get_thread_num() + !$OMP SINGLE + allocate(sumb(nthreads+1)) + sumb(:) = 0 + !$OMP END SINGLE COPYPRIVATE(sumb) + + wrk = (n)/nthreads + if (ithread < MOD((n),nthreads)) then + wrk = wrk + 1 + idxstart = ithread*wrk + 1 + else + idxstart = ithread*wrk + MOD((n),nthreads) + 1 + end if + + idxend = min(idxstart + wrk - 1,n ) + tp = czero + if (idxstart<=idxend) then + do i=idxstart,idxend + ts = x(i) + x(i) = tp + tp = tp + ts + end do + end if + sumb(ithread+2) = tp + !$OMP BARRIER + + !$OMP SINGLE + do i=2,nthreads+1 + sumb(i) = sumb(i) + sumb(i-1) + end do + !$OMP END SINGLE + + !$OMP BARRIER + + !$OMP DO SCHEDULE(STATIC) + do i=1,n + x(i) = x(i) + sumb(ithread+1) + shift_ + end do + !$OMP END DO + !$OMP SINGLE + deallocate(sumb) + !$OMP END SINGLE + end subroutine inner_c_exscan +#endif +end subroutine psi_c_exscanv + subroutine psb_m_cgelp(trans,iperm,x,info) use psb_serial_mod, psb_protect_name => psb_m_cgelp use psb_const_mod diff --git a/base/serial/psi_d_serial_impl.F90 b/base/serial/psi_d_serial_impl.F90 index 8c65b3492..1b5b14424 100644 --- a/base/serial/psi_d_serial_impl.F90 +++ b/base/serial/psi_d_serial_impl.F90 @@ -29,6 +29,107 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +subroutine psi_d_exscanv(n,x,info,shift) + use psi_d_serial_mod, psb_protect_name => psi_d_exscanv + use psb_const_mod + use psb_error_mod +#if defined(OPENMP) + use omp_lib +#endif + implicit none + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_), intent (inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), intent(in), optional :: shift + + real(psb_dpk_) :: shift_, tp, ts + integer(psb_ipk_) :: i + logical is_nested, is_parallel + + if (present(shift)) then + shift_ = shift + else + shift_ = dzero + end if + +#if defined(OPENMP) + is_parallel = omp_in_parallel() + if (is_parallel) then + call inner_d_exscan() + else + !$OMP PARALLEL default(shared) + call inner_d_exscan() + !$OMP END PARALLEL + end if +#else + tp = shift_ + do i=1,n + ts = x(i) + x(i) = tp + tp = tp + ts + end do + +#endif +#if defined(OPENMP) +contains + subroutine inner_d_exscan() + ! Note: all these variables are private, but SUMB should *really* be + ! a pointer. The semantics of COPYPRIVATE is that the POINTER is copied + ! so effectively we are recovering a SHARED SUMB which is what + ! we need in this case. If it was an ALLOCATABLE, then it would be the contents + ! that would get copied, and the SHARED effect would no longer be there. + ! Simple parallel version of EXSCAN + integer(psb_ipk_) :: i,ithread,nthreads,idxstart,idxend,wrk + real(psb_dpk_), pointer :: sumb(:) + real(psb_dpk_) :: tp, ts + + nthreads = omp_get_num_threads() + ithread = omp_get_thread_num() + !$OMP SINGLE + allocate(sumb(nthreads+1)) + sumb(:) = 0 + !$OMP END SINGLE COPYPRIVATE(sumb) + + wrk = (n)/nthreads + if (ithread < MOD((n),nthreads)) then + wrk = wrk + 1 + idxstart = ithread*wrk + 1 + else + idxstart = ithread*wrk + MOD((n),nthreads) + 1 + end if + + idxend = min(idxstart + wrk - 1,n ) + tp = dzero + if (idxstart<=idxend) then + do i=idxstart,idxend + ts = x(i) + x(i) = tp + tp = tp + ts + end do + end if + sumb(ithread+2) = tp + !$OMP BARRIER + + !$OMP SINGLE + do i=2,nthreads+1 + sumb(i) = sumb(i) + sumb(i-1) + end do + !$OMP END SINGLE + + !$OMP BARRIER + + !$OMP DO SCHEDULE(STATIC) + do i=1,n + x(i) = x(i) + sumb(ithread+1) + shift_ + end do + !$OMP END DO + !$OMP SINGLE + deallocate(sumb) + !$OMP END SINGLE + end subroutine inner_d_exscan +#endif +end subroutine psi_d_exscanv + subroutine psb_m_dgelp(trans,iperm,x,info) use psb_serial_mod, psb_protect_name => psb_m_dgelp use psb_const_mod diff --git a/base/serial/psi_e_serial_impl.F90 b/base/serial/psi_e_serial_impl.F90 index 988bad525..9cdcdf0e4 100644 --- a/base/serial/psi_e_serial_impl.F90 +++ b/base/serial/psi_e_serial_impl.F90 @@ -29,6 +29,107 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +subroutine psi_e_exscanv(n,x,info,shift) + use psi_e_serial_mod, psb_protect_name => psi_e_exscanv + use psb_const_mod + use psb_error_mod +#if defined(OPENMP) + use omp_lib +#endif + implicit none + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_), intent (inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_), intent(in), optional :: shift + + integer(psb_epk_) :: shift_, tp, ts + integer(psb_ipk_) :: i + logical is_nested, is_parallel + + if (present(shift)) then + shift_ = shift + else + shift_ = ezero + end if + +#if defined(OPENMP) + is_parallel = omp_in_parallel() + if (is_parallel) then + call inner_e_exscan() + else + !$OMP PARALLEL default(shared) + call inner_e_exscan() + !$OMP END PARALLEL + end if +#else + tp = shift_ + do i=1,n + ts = x(i) + x(i) = tp + tp = tp + ts + end do + +#endif +#if defined(OPENMP) +contains + subroutine inner_e_exscan() + ! Note: all these variables are private, but SUMB should *really* be + ! a pointer. The semantics of COPYPRIVATE is that the POINTER is copied + ! so effectively we are recovering a SHARED SUMB which is what + ! we need in this case. If it was an ALLOCATABLE, then it would be the contents + ! that would get copied, and the SHARED effect would no longer be there. + ! Simple parallel version of EXSCAN + integer(psb_ipk_) :: i,ithread,nthreads,idxstart,idxend,wrk + integer(psb_epk_), pointer :: sumb(:) + integer(psb_epk_) :: tp, ts + + nthreads = omp_get_num_threads() + ithread = omp_get_thread_num() + !$OMP SINGLE + allocate(sumb(nthreads+1)) + sumb(:) = 0 + !$OMP END SINGLE COPYPRIVATE(sumb) + + wrk = (n)/nthreads + if (ithread < MOD((n),nthreads)) then + wrk = wrk + 1 + idxstart = ithread*wrk + 1 + else + idxstart = ithread*wrk + MOD((n),nthreads) + 1 + end if + + idxend = min(idxstart + wrk - 1,n ) + tp = ezero + if (idxstart<=idxend) then + do i=idxstart,idxend + ts = x(i) + x(i) = tp + tp = tp + ts + end do + end if + sumb(ithread+2) = tp + !$OMP BARRIER + + !$OMP SINGLE + do i=2,nthreads+1 + sumb(i) = sumb(i) + sumb(i-1) + end do + !$OMP END SINGLE + + !$OMP BARRIER + + !$OMP DO SCHEDULE(STATIC) + do i=1,n + x(i) = x(i) + sumb(ithread+1) + shift_ + end do + !$OMP END DO + !$OMP SINGLE + deallocate(sumb) + !$OMP END SINGLE + end subroutine inner_e_exscan +#endif +end subroutine psi_e_exscanv + subroutine psb_m_egelp(trans,iperm,x,info) use psb_serial_mod, psb_protect_name => psb_m_egelp use psb_const_mod @@ -441,9 +542,9 @@ subroutine psi_eaxpby(m,n,alpha, x, beta, y, info) integer(psb_epk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: lx, ly + integer(psb_ipk_) :: lx, ly, i integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err + character(len=20) :: name, ch_err name='psb_geaxpby' info=psb_success_ @@ -502,7 +603,8 @@ subroutine psi_eaxpbyv(m,alpha, x, beta, y, info) integer(psb_ipk_) :: err_act integer(psb_ipk_) :: lx, ly integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err + integer(psb_ipk_) :: i + character(len=20) :: name, ch_err name='psb_geaxpby' info=psb_success_ @@ -532,7 +634,106 @@ subroutine psi_eaxpbyv(m,alpha, x, beta, y, info) goto 9999 end if - if (m>0) call eaxpby(m,ione,alpha,x,lx,beta,y,ly,info) +! if (m>0) call eaxpby(m,ione,alpha,x,lx,beta,y,ly,info) + + if (alpha.eq.ezero) then + if (beta.eq.ezero) then + !$omp parallel do private(i) + do i=1,m + y(i) = ezero + enddo + else if (beta.eq.eone) then + ! + ! Do nothing! + ! + + else if (beta.eq.-eone) then + !$omp parallel do private(i) + do i=1,m + y(i) = - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + y(i) = beta*y(i) + enddo + endif + + else if (alpha.eq.eone) then + + if (beta.eq.ezero) then + !$omp parallel do private(i) + do i=1,m + y(i) = x(i) + enddo + else if (beta.eq.eone) then + !$omp parallel do private(i) + do i=1,m + y(i) = x(i) + y(i) + enddo + + else if (beta.eq.-eone) then + !$omp parallel do private(i) + do i=1,m + y(i) = x(i) - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + y(i) = x(i) + beta*y(i) + enddo + endif + + else if (alpha.eq.-eone) then + + if (beta.eq.ezero) then + !$omp parallel do private(i) + do i=1,m + y(i) = -x(i) + enddo + else if (beta.eq.eone) then + !$omp parallel do private(i) + do i=1,m + y(i) = -x(i) + y(i) + enddo + else if (beta.eq.-eone) then + !$omp parallel do private(i) + do i=1,m + y(i) = -x(i) - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + y(i) = -x(i) + beta*y(i) + enddo + endif + + else + + if (beta.eq.ezero) then + !$omp parallel do private(i) + do i=1,m + y(i) = alpha*x(i) + enddo + else if (beta.eq.eone) then + !$omp parallel do private(i) + do i=1,m + y(i) = alpha*x(i) + y(i) + enddo + else if (beta.eq.-eone) then + !$omp parallel do private(i) + do i=1,m + y(i) = alpha*x(i) - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + y(i) = alpha*x(i) + beta*y(i) + enddo + endif + + endif + call psb_erractionrestore(err_act) return @@ -555,7 +756,7 @@ subroutine psi_eaxpbyv2(m,alpha, x, beta, y, z, info) integer(psb_epk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: lx, ly, lz + integer(psb_ipk_) :: lx, ly, lz, i integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -594,7 +795,105 @@ subroutine psi_eaxpbyv2(m,alpha, x, beta, y, z, info) goto 9999 end if - if (m>0) call eaxpbyv2(m,ione,alpha,x,lx,beta,y,ly,z,lz,info) + if (alpha.eq.ezero) then + if (beta.eq.ezero) then + !$omp parallel do private(i) + do i=1,m + Z(i) = ezero + enddo + else if (beta.eq.eone) then + ! + ! Do nothing! + ! + + else if (beta.eq.-eone) then + !$omp parallel do private(i) + do i=1,m + Z(i) = - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + Z(i) = beta*y(i) + enddo + endif + + else if (alpha.eq.eone) then + + if (beta.eq.ezero) then + !$omp parallel do private(i) + do i=1,m + Z(i) = x(i) + enddo + else if (beta.eq.eone) then + !$omp parallel do private(i) + do i=1,m + Z(i) = x(i) + y(i) + enddo + + else if (beta.eq.-eone) then + !$omp parallel do private(i) + do i=1,m + Z(i) = x(i) - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + Z(i) = x(i) + beta*y(i) + enddo + endif + + else if (alpha.eq.-eone) then + + if (beta.eq.ezero) then + !$omp parallel do private(i) + do i=1,m + Z(i) = -x(i) + enddo + else if (beta.eq.eone) then + !$omp parallel do private(i) + do i=1,m + Z(i) = -x(i) + y(i) + enddo + + else if (beta.eq.-eone) then + !$omp parallel do private(i) + do i=1,m + Z(i) = -x(i) - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + Z(i) = -x(i) + beta*y(i) + enddo + endif + + else + + if (beta.eq.ezero) then + !$omp parallel do private(i) + do i=1,m + Z(i) = alpha*x(i) + enddo + else if (beta.eq.eone) then + !$omp parallel do private(i) + do i=1,m + Z(i) = alpha*x(i) + y(i) + enddo + + else if (beta.eq.-eone) then + !$omp parallel do private(i) + do i=1,m + Z(i) = alpha*x(i) - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + Z(i) = alpha*x(i) + beta*y(i) + enddo + endif + + endif call psb_erractionrestore(err_act) return @@ -942,6 +1241,7 @@ subroutine eaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) if (alpha.eq.ezero) then if (beta.eq.ezero) then do j=1, n + !$omp parallel do private(i) do i=1,m y(i,j) = ezero enddo @@ -953,12 +1253,14 @@ subroutine eaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) else if (beta.eq.-eone) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = beta*y(i,j) enddo @@ -969,12 +1271,14 @@ subroutine eaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) if (beta.eq.ezero) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = x(i,j) enddo enddo else if (beta.eq.eone) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = x(i,j) + y(i,j) enddo @@ -982,12 +1286,14 @@ subroutine eaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) else if (beta.eq.-eone) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = x(i,j) - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = x(i,j) + beta*y(i,j) enddo @@ -998,12 +1304,14 @@ subroutine eaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) if (beta.eq.ezero) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = -x(i,j) enddo enddo else if (beta.eq.eone) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = -x(i,j) + y(i,j) enddo @@ -1011,12 +1319,14 @@ subroutine eaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) else if (beta.eq.-eone) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = -x(i,j) - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = -x(i,j) + beta*y(i,j) enddo @@ -1027,12 +1337,14 @@ subroutine eaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) if (beta.eq.ezero) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = alpha*x(i,j) enddo enddo else if (beta.eq.eone) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = alpha*x(i,j) + y(i,j) enddo @@ -1040,12 +1352,14 @@ subroutine eaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) else if (beta.eq.-eone) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = alpha*x(i,j) - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = alpha*x(i,j) + beta*y(i,j) enddo @@ -1131,12 +1445,14 @@ subroutine eaxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) else if (beta.eq.-eone) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = beta*y(i,j) enddo @@ -1147,12 +1463,14 @@ subroutine eaxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) if (beta.eq.ezero) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = x(i,j) enddo enddo else if (beta.eq.eone) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = x(i,j) + y(i,j) enddo @@ -1160,12 +1478,14 @@ subroutine eaxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) else if (beta.eq.-eone) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = x(i,j) - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = x(i,j) + beta*y(i,j) enddo @@ -1176,12 +1496,14 @@ subroutine eaxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) if (beta.eq.ezero) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = -x(i,j) enddo enddo else if (beta.eq.eone) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = -x(i,j) + y(i,j) enddo @@ -1189,12 +1511,14 @@ subroutine eaxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) else if (beta.eq.-eone) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = -x(i,j) - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = -x(i,j) + beta*y(i,j) enddo @@ -1205,12 +1529,14 @@ subroutine eaxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) if (beta.eq.ezero) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = alpha*x(i,j) enddo enddo else if (beta.eq.eone) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = alpha*x(i,j) + y(i,j) enddo @@ -1218,12 +1544,14 @@ subroutine eaxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) else if (beta.eq.-eone) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = alpha*x(i,j) - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = alpha*x(i,j) + beta*y(i,j) enddo diff --git a/base/serial/psi_i2_serial_impl.F90 b/base/serial/psi_i2_serial_impl.F90 index 83b078f0c..d25617a90 100644 --- a/base/serial/psi_i2_serial_impl.F90 +++ b/base/serial/psi_i2_serial_impl.F90 @@ -29,6 +29,107 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +subroutine psi_i2_exscanv(n,x,info,shift) + use psi_i2_serial_mod, psb_protect_name => psi_i2_exscanv + use psb_const_mod + use psb_error_mod +#if defined(OPENMP) + use omp_lib +#endif + implicit none + integer(psb_ipk_), intent(in) :: n + integer(psb_i2pk_), intent (inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_), intent(in), optional :: shift + + integer(psb_i2pk_) :: shift_, tp, ts + integer(psb_ipk_) :: i + logical is_nested, is_parallel + + if (present(shift)) then + shift_ = shift + else + shift_ = i2zero + end if + +#if defined(OPENMP) + is_parallel = omp_in_parallel() + if (is_parallel) then + call inner_i2_exscan() + else + !$OMP PARALLEL default(shared) + call inner_i2_exscan() + !$OMP END PARALLEL + end if +#else + tp = shift_ + do i=1,n + ts = x(i) + x(i) = tp + tp = tp + ts + end do + +#endif +#if defined(OPENMP) +contains + subroutine inner_i2_exscan() + ! Note: all these variables are private, but SUMB should *really* be + ! a pointer. The semantics of COPYPRIVATE is that the POINTER is copied + ! so effectively we are recovering a SHARED SUMB which is what + ! we need in this case. If it was an ALLOCATABLE, then it would be the contents + ! that would get copied, and the SHARED effect would no longer be there. + ! Simple parallel version of EXSCAN + integer(psb_ipk_) :: i,ithread,nthreads,idxstart,idxend,wrk + integer(psb_i2pk_), pointer :: sumb(:) + integer(psb_i2pk_) :: tp, ts + + nthreads = omp_get_num_threads() + ithread = omp_get_thread_num() + !$OMP SINGLE + allocate(sumb(nthreads+1)) + sumb(:) = 0 + !$OMP END SINGLE COPYPRIVATE(sumb) + + wrk = (n)/nthreads + if (ithread < MOD((n),nthreads)) then + wrk = wrk + 1 + idxstart = ithread*wrk + 1 + else + idxstart = ithread*wrk + MOD((n),nthreads) + 1 + end if + + idxend = min(idxstart + wrk - 1,n ) + tp = i2zero + if (idxstart<=idxend) then + do i=idxstart,idxend + ts = x(i) + x(i) = tp + tp = tp + ts + end do + end if + sumb(ithread+2) = tp + !$OMP BARRIER + + !$OMP SINGLE + do i=2,nthreads+1 + sumb(i) = sumb(i) + sumb(i-1) + end do + !$OMP END SINGLE + + !$OMP BARRIER + + !$OMP DO SCHEDULE(STATIC) + do i=1,n + x(i) = x(i) + sumb(ithread+1) + shift_ + end do + !$OMP END DO + !$OMP SINGLE + deallocate(sumb) + !$OMP END SINGLE + end subroutine inner_i2_exscan +#endif +end subroutine psi_i2_exscanv + subroutine psb_m_i2gelp(trans,iperm,x,info) use psb_serial_mod, psb_protect_name => psb_m_i2gelp use psb_const_mod @@ -441,9 +542,9 @@ subroutine psi_i2axpby(m,n,alpha, x, beta, y, info) integer(psb_i2pk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: lx, ly + integer(psb_ipk_) :: lx, ly, i integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err + character(len=20) :: name, ch_err name='psb_geaxpby' info=psb_success_ @@ -502,7 +603,8 @@ subroutine psi_i2axpbyv(m,alpha, x, beta, y, info) integer(psb_ipk_) :: err_act integer(psb_ipk_) :: lx, ly integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err + integer(psb_ipk_) :: i + character(len=20) :: name, ch_err name='psb_geaxpby' info=psb_success_ @@ -532,7 +634,106 @@ subroutine psi_i2axpbyv(m,alpha, x, beta, y, info) goto 9999 end if - if (m>0) call i2axpby(m,ione,alpha,x,lx,beta,y,ly,info) +! if (m>0) call i2axpby(m,ione,alpha,x,lx,beta,y,ly,info) + + if (alpha.eq.i2zero) then + if (beta.eq.i2zero) then + !$omp parallel do private(i) + do i=1,m + y(i) = i2zero + enddo + else if (beta.eq.i2one) then + ! + ! Do nothing! + ! + + else if (beta.eq.-i2one) then + !$omp parallel do private(i) + do i=1,m + y(i) = - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + y(i) = beta*y(i) + enddo + endif + + else if (alpha.eq.i2one) then + + if (beta.eq.i2zero) then + !$omp parallel do private(i) + do i=1,m + y(i) = x(i) + enddo + else if (beta.eq.i2one) then + !$omp parallel do private(i) + do i=1,m + y(i) = x(i) + y(i) + enddo + + else if (beta.eq.-i2one) then + !$omp parallel do private(i) + do i=1,m + y(i) = x(i) - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + y(i) = x(i) + beta*y(i) + enddo + endif + + else if (alpha.eq.-i2one) then + + if (beta.eq.i2zero) then + !$omp parallel do private(i) + do i=1,m + y(i) = -x(i) + enddo + else if (beta.eq.i2one) then + !$omp parallel do private(i) + do i=1,m + y(i) = -x(i) + y(i) + enddo + else if (beta.eq.-i2one) then + !$omp parallel do private(i) + do i=1,m + y(i) = -x(i) - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + y(i) = -x(i) + beta*y(i) + enddo + endif + + else + + if (beta.eq.i2zero) then + !$omp parallel do private(i) + do i=1,m + y(i) = alpha*x(i) + enddo + else if (beta.eq.i2one) then + !$omp parallel do private(i) + do i=1,m + y(i) = alpha*x(i) + y(i) + enddo + else if (beta.eq.-i2one) then + !$omp parallel do private(i) + do i=1,m + y(i) = alpha*x(i) - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + y(i) = alpha*x(i) + beta*y(i) + enddo + endif + + endif + call psb_erractionrestore(err_act) return @@ -555,7 +756,7 @@ subroutine psi_i2axpbyv2(m,alpha, x, beta, y, z, info) integer(psb_i2pk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: lx, ly, lz + integer(psb_ipk_) :: lx, ly, lz, i integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -594,7 +795,105 @@ subroutine psi_i2axpbyv2(m,alpha, x, beta, y, z, info) goto 9999 end if - if (m>0) call i2axpbyv2(m,ione,alpha,x,lx,beta,y,ly,z,lz,info) + if (alpha.eq.i2zero) then + if (beta.eq.i2zero) then + !$omp parallel do private(i) + do i=1,m + Z(i) = i2zero + enddo + else if (beta.eq.i2one) then + ! + ! Do nothing! + ! + + else if (beta.eq.-i2one) then + !$omp parallel do private(i) + do i=1,m + Z(i) = - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + Z(i) = beta*y(i) + enddo + endif + + else if (alpha.eq.i2one) then + + if (beta.eq.i2zero) then + !$omp parallel do private(i) + do i=1,m + Z(i) = x(i) + enddo + else if (beta.eq.i2one) then + !$omp parallel do private(i) + do i=1,m + Z(i) = x(i) + y(i) + enddo + + else if (beta.eq.-i2one) then + !$omp parallel do private(i) + do i=1,m + Z(i) = x(i) - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + Z(i) = x(i) + beta*y(i) + enddo + endif + + else if (alpha.eq.-i2one) then + + if (beta.eq.i2zero) then + !$omp parallel do private(i) + do i=1,m + Z(i) = -x(i) + enddo + else if (beta.eq.i2one) then + !$omp parallel do private(i) + do i=1,m + Z(i) = -x(i) + y(i) + enddo + + else if (beta.eq.-i2one) then + !$omp parallel do private(i) + do i=1,m + Z(i) = -x(i) - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + Z(i) = -x(i) + beta*y(i) + enddo + endif + + else + + if (beta.eq.i2zero) then + !$omp parallel do private(i) + do i=1,m + Z(i) = alpha*x(i) + enddo + else if (beta.eq.i2one) then + !$omp parallel do private(i) + do i=1,m + Z(i) = alpha*x(i) + y(i) + enddo + + else if (beta.eq.-i2one) then + !$omp parallel do private(i) + do i=1,m + Z(i) = alpha*x(i) - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + Z(i) = alpha*x(i) + beta*y(i) + enddo + endif + + endif call psb_erractionrestore(err_act) return @@ -942,6 +1241,7 @@ subroutine i2axpby(m, n, alpha, X, lldx, beta, Y, lldy, info) if (alpha.eq.i2zero) then if (beta.eq.i2zero) then do j=1, n + !$omp parallel do private(i) do i=1,m y(i,j) = i2zero enddo @@ -953,12 +1253,14 @@ subroutine i2axpby(m, n, alpha, X, lldx, beta, Y, lldy, info) else if (beta.eq.-i2one) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = beta*y(i,j) enddo @@ -969,12 +1271,14 @@ subroutine i2axpby(m, n, alpha, X, lldx, beta, Y, lldy, info) if (beta.eq.i2zero) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = x(i,j) enddo enddo else if (beta.eq.i2one) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = x(i,j) + y(i,j) enddo @@ -982,12 +1286,14 @@ subroutine i2axpby(m, n, alpha, X, lldx, beta, Y, lldy, info) else if (beta.eq.-i2one) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = x(i,j) - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = x(i,j) + beta*y(i,j) enddo @@ -998,12 +1304,14 @@ subroutine i2axpby(m, n, alpha, X, lldx, beta, Y, lldy, info) if (beta.eq.i2zero) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = -x(i,j) enddo enddo else if (beta.eq.i2one) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = -x(i,j) + y(i,j) enddo @@ -1011,12 +1319,14 @@ subroutine i2axpby(m, n, alpha, X, lldx, beta, Y, lldy, info) else if (beta.eq.-i2one) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = -x(i,j) - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = -x(i,j) + beta*y(i,j) enddo @@ -1027,12 +1337,14 @@ subroutine i2axpby(m, n, alpha, X, lldx, beta, Y, lldy, info) if (beta.eq.i2zero) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = alpha*x(i,j) enddo enddo else if (beta.eq.i2one) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = alpha*x(i,j) + y(i,j) enddo @@ -1040,12 +1352,14 @@ subroutine i2axpby(m, n, alpha, X, lldx, beta, Y, lldy, info) else if (beta.eq.-i2one) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = alpha*x(i,j) - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = alpha*x(i,j) + beta*y(i,j) enddo @@ -1131,12 +1445,14 @@ subroutine i2axpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) else if (beta.eq.-i2one) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = beta*y(i,j) enddo @@ -1147,12 +1463,14 @@ subroutine i2axpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) if (beta.eq.i2zero) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = x(i,j) enddo enddo else if (beta.eq.i2one) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = x(i,j) + y(i,j) enddo @@ -1160,12 +1478,14 @@ subroutine i2axpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) else if (beta.eq.-i2one) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = x(i,j) - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = x(i,j) + beta*y(i,j) enddo @@ -1176,12 +1496,14 @@ subroutine i2axpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) if (beta.eq.i2zero) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = -x(i,j) enddo enddo else if (beta.eq.i2one) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = -x(i,j) + y(i,j) enddo @@ -1189,12 +1511,14 @@ subroutine i2axpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) else if (beta.eq.-i2one) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = -x(i,j) - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = -x(i,j) + beta*y(i,j) enddo @@ -1205,12 +1529,14 @@ subroutine i2axpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) if (beta.eq.i2zero) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = alpha*x(i,j) enddo enddo else if (beta.eq.i2one) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = alpha*x(i,j) + y(i,j) enddo @@ -1218,12 +1544,14 @@ subroutine i2axpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) else if (beta.eq.-i2one) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = alpha*x(i,j) - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = alpha*x(i,j) + beta*y(i,j) enddo diff --git a/base/serial/psi_m_serial_impl.F90 b/base/serial/psi_m_serial_impl.F90 index 950e23589..05c8e60fa 100644 --- a/base/serial/psi_m_serial_impl.F90 +++ b/base/serial/psi_m_serial_impl.F90 @@ -29,6 +29,107 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +subroutine psi_m_exscanv(n,x,info,shift) + use psi_m_serial_mod, psb_protect_name => psi_m_exscanv + use psb_const_mod + use psb_error_mod +#if defined(OPENMP) + use omp_lib +#endif + implicit none + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent (inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_), intent(in), optional :: shift + + integer(psb_mpk_) :: shift_, tp, ts + integer(psb_ipk_) :: i + logical is_nested, is_parallel + + if (present(shift)) then + shift_ = shift + else + shift_ = mzero + end if + +#if defined(OPENMP) + is_parallel = omp_in_parallel() + if (is_parallel) then + call inner_m_exscan() + else + !$OMP PARALLEL default(shared) + call inner_m_exscan() + !$OMP END PARALLEL + end if +#else + tp = shift_ + do i=1,n + ts = x(i) + x(i) = tp + tp = tp + ts + end do + +#endif +#if defined(OPENMP) +contains + subroutine inner_m_exscan() + ! Note: all these variables are private, but SUMB should *really* be + ! a pointer. The semantics of COPYPRIVATE is that the POINTER is copied + ! so effectively we are recovering a SHARED SUMB which is what + ! we need in this case. If it was an ALLOCATABLE, then it would be the contents + ! that would get copied, and the SHARED effect would no longer be there. + ! Simple parallel version of EXSCAN + integer(psb_ipk_) :: i,ithread,nthreads,idxstart,idxend,wrk + integer(psb_mpk_), pointer :: sumb(:) + integer(psb_mpk_) :: tp, ts + + nthreads = omp_get_num_threads() + ithread = omp_get_thread_num() + !$OMP SINGLE + allocate(sumb(nthreads+1)) + sumb(:) = 0 + !$OMP END SINGLE COPYPRIVATE(sumb) + + wrk = (n)/nthreads + if (ithread < MOD((n),nthreads)) then + wrk = wrk + 1 + idxstart = ithread*wrk + 1 + else + idxstart = ithread*wrk + MOD((n),nthreads) + 1 + end if + + idxend = min(idxstart + wrk - 1,n ) + tp = mzero + if (idxstart<=idxend) then + do i=idxstart,idxend + ts = x(i) + x(i) = tp + tp = tp + ts + end do + end if + sumb(ithread+2) = tp + !$OMP BARRIER + + !$OMP SINGLE + do i=2,nthreads+1 + sumb(i) = sumb(i) + sumb(i-1) + end do + !$OMP END SINGLE + + !$OMP BARRIER + + !$OMP DO SCHEDULE(STATIC) + do i=1,n + x(i) = x(i) + sumb(ithread+1) + shift_ + end do + !$OMP END DO + !$OMP SINGLE + deallocate(sumb) + !$OMP END SINGLE + end subroutine inner_m_exscan +#endif +end subroutine psi_m_exscanv + subroutine psb_m_mgelp(trans,iperm,x,info) use psb_serial_mod, psb_protect_name => psb_m_mgelp use psb_const_mod @@ -441,9 +542,9 @@ subroutine psi_maxpby(m,n,alpha, x, beta, y, info) integer(psb_mpk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: lx, ly + integer(psb_ipk_) :: lx, ly, i integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err + character(len=20) :: name, ch_err name='psb_geaxpby' info=psb_success_ @@ -502,7 +603,8 @@ subroutine psi_maxpbyv(m,alpha, x, beta, y, info) integer(psb_ipk_) :: err_act integer(psb_ipk_) :: lx, ly integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err + integer(psb_ipk_) :: i + character(len=20) :: name, ch_err name='psb_geaxpby' info=psb_success_ @@ -532,7 +634,106 @@ subroutine psi_maxpbyv(m,alpha, x, beta, y, info) goto 9999 end if - if (m>0) call maxpby(m,ione,alpha,x,lx,beta,y,ly,info) +! if (m>0) call maxpby(m,ione,alpha,x,lx,beta,y,ly,info) + + if (alpha.eq.mzero) then + if (beta.eq.mzero) then + !$omp parallel do private(i) + do i=1,m + y(i) = mzero + enddo + else if (beta.eq.mone) then + ! + ! Do nothing! + ! + + else if (beta.eq.-mone) then + !$omp parallel do private(i) + do i=1,m + y(i) = - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + y(i) = beta*y(i) + enddo + endif + + else if (alpha.eq.mone) then + + if (beta.eq.mzero) then + !$omp parallel do private(i) + do i=1,m + y(i) = x(i) + enddo + else if (beta.eq.mone) then + !$omp parallel do private(i) + do i=1,m + y(i) = x(i) + y(i) + enddo + + else if (beta.eq.-mone) then + !$omp parallel do private(i) + do i=1,m + y(i) = x(i) - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + y(i) = x(i) + beta*y(i) + enddo + endif + + else if (alpha.eq.-mone) then + + if (beta.eq.mzero) then + !$omp parallel do private(i) + do i=1,m + y(i) = -x(i) + enddo + else if (beta.eq.mone) then + !$omp parallel do private(i) + do i=1,m + y(i) = -x(i) + y(i) + enddo + else if (beta.eq.-mone) then + !$omp parallel do private(i) + do i=1,m + y(i) = -x(i) - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + y(i) = -x(i) + beta*y(i) + enddo + endif + + else + + if (beta.eq.mzero) then + !$omp parallel do private(i) + do i=1,m + y(i) = alpha*x(i) + enddo + else if (beta.eq.mone) then + !$omp parallel do private(i) + do i=1,m + y(i) = alpha*x(i) + y(i) + enddo + else if (beta.eq.-mone) then + !$omp parallel do private(i) + do i=1,m + y(i) = alpha*x(i) - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + y(i) = alpha*x(i) + beta*y(i) + enddo + endif + + endif + call psb_erractionrestore(err_act) return @@ -555,7 +756,7 @@ subroutine psi_maxpbyv2(m,alpha, x, beta, y, z, info) integer(psb_mpk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: lx, ly, lz + integer(psb_ipk_) :: lx, ly, lz, i integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -594,7 +795,105 @@ subroutine psi_maxpbyv2(m,alpha, x, beta, y, z, info) goto 9999 end if - if (m>0) call maxpbyv2(m,ione,alpha,x,lx,beta,y,ly,z,lz,info) + if (alpha.eq.mzero) then + if (beta.eq.mzero) then + !$omp parallel do private(i) + do i=1,m + Z(i) = mzero + enddo + else if (beta.eq.mone) then + ! + ! Do nothing! + ! + + else if (beta.eq.-mone) then + !$omp parallel do private(i) + do i=1,m + Z(i) = - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + Z(i) = beta*y(i) + enddo + endif + + else if (alpha.eq.mone) then + + if (beta.eq.mzero) then + !$omp parallel do private(i) + do i=1,m + Z(i) = x(i) + enddo + else if (beta.eq.mone) then + !$omp parallel do private(i) + do i=1,m + Z(i) = x(i) + y(i) + enddo + + else if (beta.eq.-mone) then + !$omp parallel do private(i) + do i=1,m + Z(i) = x(i) - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + Z(i) = x(i) + beta*y(i) + enddo + endif + + else if (alpha.eq.-mone) then + + if (beta.eq.mzero) then + !$omp parallel do private(i) + do i=1,m + Z(i) = -x(i) + enddo + else if (beta.eq.mone) then + !$omp parallel do private(i) + do i=1,m + Z(i) = -x(i) + y(i) + enddo + + else if (beta.eq.-mone) then + !$omp parallel do private(i) + do i=1,m + Z(i) = -x(i) - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + Z(i) = -x(i) + beta*y(i) + enddo + endif + + else + + if (beta.eq.mzero) then + !$omp parallel do private(i) + do i=1,m + Z(i) = alpha*x(i) + enddo + else if (beta.eq.mone) then + !$omp parallel do private(i) + do i=1,m + Z(i) = alpha*x(i) + y(i) + enddo + + else if (beta.eq.-mone) then + !$omp parallel do private(i) + do i=1,m + Z(i) = alpha*x(i) - y(i) + enddo + else + !$omp parallel do private(i) + do i=1,m + Z(i) = alpha*x(i) + beta*y(i) + enddo + endif + + endif call psb_erractionrestore(err_act) return @@ -942,6 +1241,7 @@ subroutine maxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) if (alpha.eq.mzero) then if (beta.eq.mzero) then do j=1, n + !$omp parallel do private(i) do i=1,m y(i,j) = mzero enddo @@ -953,12 +1253,14 @@ subroutine maxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) else if (beta.eq.-mone) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = beta*y(i,j) enddo @@ -969,12 +1271,14 @@ subroutine maxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) if (beta.eq.mzero) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = x(i,j) enddo enddo else if (beta.eq.mone) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = x(i,j) + y(i,j) enddo @@ -982,12 +1286,14 @@ subroutine maxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) else if (beta.eq.-mone) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = x(i,j) - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = x(i,j) + beta*y(i,j) enddo @@ -998,12 +1304,14 @@ subroutine maxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) if (beta.eq.mzero) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = -x(i,j) enddo enddo else if (beta.eq.mone) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = -x(i,j) + y(i,j) enddo @@ -1011,12 +1319,14 @@ subroutine maxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) else if (beta.eq.-mone) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = -x(i,j) - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = -x(i,j) + beta*y(i,j) enddo @@ -1027,12 +1337,14 @@ subroutine maxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) if (beta.eq.mzero) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = alpha*x(i,j) enddo enddo else if (beta.eq.mone) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = alpha*x(i,j) + y(i,j) enddo @@ -1040,12 +1352,14 @@ subroutine maxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) else if (beta.eq.-mone) then do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = alpha*x(i,j) - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m y(i,j) = alpha*x(i,j) + beta*y(i,j) enddo @@ -1131,12 +1445,14 @@ subroutine maxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) else if (beta.eq.-mone) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = beta*y(i,j) enddo @@ -1147,12 +1463,14 @@ subroutine maxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) if (beta.eq.mzero) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = x(i,j) enddo enddo else if (beta.eq.mone) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = x(i,j) + y(i,j) enddo @@ -1160,12 +1478,14 @@ subroutine maxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) else if (beta.eq.-mone) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = x(i,j) - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = x(i,j) + beta*y(i,j) enddo @@ -1176,12 +1496,14 @@ subroutine maxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) if (beta.eq.mzero) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = -x(i,j) enddo enddo else if (beta.eq.mone) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = -x(i,j) + y(i,j) enddo @@ -1189,12 +1511,14 @@ subroutine maxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) else if (beta.eq.-mone) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = -x(i,j) - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = -x(i,j) + beta*y(i,j) enddo @@ -1205,12 +1529,14 @@ subroutine maxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) if (beta.eq.mzero) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = alpha*x(i,j) enddo enddo else if (beta.eq.mone) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = alpha*x(i,j) + y(i,j) enddo @@ -1218,12 +1544,14 @@ subroutine maxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) else if (beta.eq.-mone) then do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = alpha*x(i,j) - y(i,j) enddo enddo else do j=1,n + !$omp parallel do private(i) do i=1,m Z(i,j) = alpha*x(i,j) + beta*y(i,j) enddo diff --git a/base/serial/psi_s_serial_impl.F90 b/base/serial/psi_s_serial_impl.F90 index 6c8e21e20..26a57e687 100644 --- a/base/serial/psi_s_serial_impl.F90 +++ b/base/serial/psi_s_serial_impl.F90 @@ -29,6 +29,107 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +subroutine psi_s_exscanv(n,x,info,shift) + use psi_s_serial_mod, psb_protect_name => psi_s_exscanv + use psb_const_mod + use psb_error_mod +#if defined(OPENMP) + use omp_lib +#endif + implicit none + integer(psb_ipk_), intent(in) :: n + real(psb_spk_), intent (inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + real(psb_spk_), intent(in), optional :: shift + + real(psb_spk_) :: shift_, tp, ts + integer(psb_ipk_) :: i + logical is_nested, is_parallel + + if (present(shift)) then + shift_ = shift + else + shift_ = szero + end if + +#if defined(OPENMP) + is_parallel = omp_in_parallel() + if (is_parallel) then + call inner_s_exscan() + else + !$OMP PARALLEL default(shared) + call inner_s_exscan() + !$OMP END PARALLEL + end if +#else + tp = shift_ + do i=1,n + ts = x(i) + x(i) = tp + tp = tp + ts + end do + +#endif +#if defined(OPENMP) +contains + subroutine inner_s_exscan() + ! Note: all these variables are private, but SUMB should *really* be + ! a pointer. The semantics of COPYPRIVATE is that the POINTER is copied + ! so effectively we are recovering a SHARED SUMB which is what + ! we need in this case. If it was an ALLOCATABLE, then it would be the contents + ! that would get copied, and the SHARED effect would no longer be there. + ! Simple parallel version of EXSCAN + integer(psb_ipk_) :: i,ithread,nthreads,idxstart,idxend,wrk + real(psb_spk_), pointer :: sumb(:) + real(psb_spk_) :: tp, ts + + nthreads = omp_get_num_threads() + ithread = omp_get_thread_num() + !$OMP SINGLE + allocate(sumb(nthreads+1)) + sumb(:) = 0 + !$OMP END SINGLE COPYPRIVATE(sumb) + + wrk = (n)/nthreads + if (ithread < MOD((n),nthreads)) then + wrk = wrk + 1 + idxstart = ithread*wrk + 1 + else + idxstart = ithread*wrk + MOD((n),nthreads) + 1 + end if + + idxend = min(idxstart + wrk - 1,n ) + tp = szero + if (idxstart<=idxend) then + do i=idxstart,idxend + ts = x(i) + x(i) = tp + tp = tp + ts + end do + end if + sumb(ithread+2) = tp + !$OMP BARRIER + + !$OMP SINGLE + do i=2,nthreads+1 + sumb(i) = sumb(i) + sumb(i-1) + end do + !$OMP END SINGLE + + !$OMP BARRIER + + !$OMP DO SCHEDULE(STATIC) + do i=1,n + x(i) = x(i) + sumb(ithread+1) + shift_ + end do + !$OMP END DO + !$OMP SINGLE + deallocate(sumb) + !$OMP END SINGLE + end subroutine inner_s_exscan +#endif +end subroutine psi_s_exscanv + subroutine psb_m_sgelp(trans,iperm,x,info) use psb_serial_mod, psb_protect_name => psb_m_sgelp use psb_const_mod diff --git a/base/serial/psi_z_serial_impl.F90 b/base/serial/psi_z_serial_impl.F90 index f3087992f..0b15b2d61 100644 --- a/base/serial/psi_z_serial_impl.F90 +++ b/base/serial/psi_z_serial_impl.F90 @@ -29,6 +29,107 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +subroutine psi_z_exscanv(n,x,info,shift) + use psi_z_serial_mod, psb_protect_name => psi_z_exscanv + use psb_const_mod + use psb_error_mod +#if defined(OPENMP) + use omp_lib +#endif + implicit none + integer(psb_ipk_), intent(in) :: n + complex(psb_dpk_), intent (inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_), intent(in), optional :: shift + + complex(psb_dpk_) :: shift_, tp, ts + integer(psb_ipk_) :: i + logical is_nested, is_parallel + + if (present(shift)) then + shift_ = shift + else + shift_ = zzero + end if + +#if defined(OPENMP) + is_parallel = omp_in_parallel() + if (is_parallel) then + call inner_z_exscan() + else + !$OMP PARALLEL default(shared) + call inner_z_exscan() + !$OMP END PARALLEL + end if +#else + tp = shift_ + do i=1,n + ts = x(i) + x(i) = tp + tp = tp + ts + end do + +#endif +#if defined(OPENMP) +contains + subroutine inner_z_exscan() + ! Note: all these variables are private, but SUMB should *really* be + ! a pointer. The semantics of COPYPRIVATE is that the POINTER is copied + ! so effectively we are recovering a SHARED SUMB which is what + ! we need in this case. If it was an ALLOCATABLE, then it would be the contents + ! that would get copied, and the SHARED effect would no longer be there. + ! Simple parallel version of EXSCAN + integer(psb_ipk_) :: i,ithread,nthreads,idxstart,idxend,wrk + complex(psb_dpk_), pointer :: sumb(:) + complex(psb_dpk_) :: tp, ts + + nthreads = omp_get_num_threads() + ithread = omp_get_thread_num() + !$OMP SINGLE + allocate(sumb(nthreads+1)) + sumb(:) = 0 + !$OMP END SINGLE COPYPRIVATE(sumb) + + wrk = (n)/nthreads + if (ithread < MOD((n),nthreads)) then + wrk = wrk + 1 + idxstart = ithread*wrk + 1 + else + idxstart = ithread*wrk + MOD((n),nthreads) + 1 + end if + + idxend = min(idxstart + wrk - 1,n ) + tp = zzero + if (idxstart<=idxend) then + do i=idxstart,idxend + ts = x(i) + x(i) = tp + tp = tp + ts + end do + end if + sumb(ithread+2) = tp + !$OMP BARRIER + + !$OMP SINGLE + do i=2,nthreads+1 + sumb(i) = sumb(i) + sumb(i-1) + end do + !$OMP END SINGLE + + !$OMP BARRIER + + !$OMP DO SCHEDULE(STATIC) + do i=1,n + x(i) = x(i) + sumb(ithread+1) + shift_ + end do + !$OMP END DO + !$OMP SINGLE + deallocate(sumb) + !$OMP END SINGLE + end subroutine inner_z_exscan +#endif +end subroutine psi_z_exscanv + subroutine psb_m_zgelp(trans,iperm,x,info) use psb_serial_mod, psb_protect_name => psb_m_zgelp use psb_const_mod diff --git a/base/serial/sort/Makefile b/base/serial/sort/Makefile index 2ef6420ab..ff8fd6201 100644 --- a/base/serial/sort/Makefile +++ b/base/serial/sort/Makefile @@ -3,7 +3,6 @@ include ../../../Make.inc # # The object files # -BOBJS=psi_lcx_mod.o psi_alcx_mod.o psi_acx_mod.o IOBJS=psb_m_hsort_impl.o psb_m_isort_impl.o psb_m_msort_impl.o psb_m_qsort_impl.o LOBJS=psb_e_hsort_impl.o psb_e_isort_impl.o psb_e_msort_impl.o psb_e_qsort_impl.o SOBJS=psb_s_hsort_impl.o psb_s_isort_impl.o psb_s_msort_impl.o psb_s_qsort_impl.o @@ -11,7 +10,7 @@ DOBJS=psb_d_hsort_impl.o psb_d_isort_impl.o psb_d_msort_impl.o psb_d_qsort_impl. COBJS=psb_c_hsort_impl.o psb_c_isort_impl.o psb_c_msort_impl.o psb_c_qsort_impl.o ZOBJS=psb_z_hsort_impl.o psb_z_isort_impl.o psb_z_msort_impl.o psb_z_qsort_impl.o -OBJS=$(BOBJS) $(SOBJS) $(DOBJS) $(COBJS) $(ZOBJS) $(IOBJS) $(LOBJS) +OBJS=$(SOBJS) $(DOBJS) $(COBJS) $(ZOBJS) $(IOBJS) $(LOBJS) # # Where the library should go, and how it is called. @@ -35,7 +34,6 @@ lib: objs # A bit excessive, but safe $(OBJS): $(MODDIR)/psb_base_mod.o -$(IOBJS) $(LOBJS) $(SOBJS) $(DOBJS) $(COBJS) $(ZOBJS): $(BOBJS) clean: cleanobjs veryclean: cleanobjs diff --git a/base/serial/sort/psb_c_qsort_impl.f90 b/base/serial/sort/psb_c_qsort_impl.f90 index 712529fc7..7f33c0997 100644 --- a/base/serial/sort/psb_c_qsort_impl.f90 +++ b/base/serial/sort/psb_c_qsort_impl.f90 @@ -40,6 +40,7 @@ ! Data Structures and Algorithms ! Addison-Wesley ! + subroutine psb_cqsort(x,ix,dir,flag) use psb_sort_mod, psb_protect_name => psb_cqsort use psb_error_mod diff --git a/base/serial/sort/psb_d_msort_impl.f90 b/base/serial/sort/psb_d_msort_impl.f90 index 110298184..66ad78972 100644 --- a/base/serial/sort/psb_d_msort_impl.f90 +++ b/base/serial/sort/psb_d_msort_impl.f90 @@ -76,64 +76,6 @@ subroutine psb_dmsort_u(x,nout,dir) return end subroutine psb_dmsort_u - -function psb_dbsrch(key,n,v) result(ipos) - use psb_sort_mod, psb_protect_name => psb_dbsrch - implicit none - integer(psb_ipk_) :: ipos, n - real(psb_dpk_) :: key - real(psb_dpk_) :: v(:) - - integer(psb_ipk_) :: lb, ub, m, i - - ipos = -1 - if (n<5) then - do i=1,n - if (key.eq.v(i)) then - ipos = i - return - end if - enddo - return - end if - - lb = 1 - ub = n - - do while (lb.le.ub) - m = (lb+ub)/2 - if (key.eq.v(m)) then - ipos = m - lb = ub + 1 - else if (key < v(m)) then - ub = m-1 - else - lb = m + 1 - end if - enddo - return -end function psb_dbsrch - -function psb_dssrch(key,n,v) result(ipos) - use psb_sort_mod, psb_protect_name => psb_dssrch - implicit none - integer(psb_ipk_) :: ipos, n - real(psb_dpk_) :: key - real(psb_dpk_) :: v(:) - - integer(psb_ipk_) :: i - - ipos = -1 - do i=1,n - if (key.eq.v(i)) then - ipos = i - return - end if - enddo - - return -end function psb_dssrch - subroutine psb_dmsort(x,ix,dir,flag) use psb_sort_mod, psb_protect_name => psb_dmsort use psb_error_mod diff --git a/base/serial/sort/psb_d_qsort_impl.f90 b/base/serial/sort/psb_d_qsort_impl.f90 index 13328188f..8e4b1d213 100644 --- a/base/serial/sort/psb_d_qsort_impl.f90 +++ b/base/serial/sort/psb_d_qsort_impl.f90 @@ -40,6 +40,125 @@ ! Data Structures and Algorithms ! Addison-Wesley ! +function psb_dbsrch(key,n,v,dir,find) result(ipos) + use psb_sort_mod, psb_protect_name => psb_dbsrch + implicit none + integer(psb_ipk_) :: ipos, n + real(psb_dpk_) :: key + real(psb_dpk_) :: v(:) + integer(psb_ipk_), optional :: dir, find + + integer(psb_ipk_) :: lb, ub, m, i, k, dir_, find_ + + if (present(dir)) then + dir_ = dir + else + dir_ = psb_sort_up_ + end if + if (present(find)) then + find_ = find + else + find_ = psb_find_any_ + end if + + ipos = -1 + if (dir_ == psb_sort_up_) then + if (n<=5) then + do m=1,n + if (key == v(m)) then + ipos = m + exit + end if + enddo + + else + + lb = 1 + ub = n + + do while (lb.le.ub) + m = (lb+ub)/2 + if (key.eq.v(m)) then + ipos = m + exit + else if (key < v(m)) then + ub = m-1 + else + lb = m + 1 + end if + enddo + end if + select case(find_) + case (psb_find_any_ ) + ! do nothing + case (psb_find_last_le_ ) + if ((m>n) .or. (m<1)) then + m = n + do while (m>=1) + if (v(m)<=key) exit + m = m - 1 + end do + else + do while (mn) .or. (m<1)) then + m = 1 + do while (m<=n) + if (v(m)>=key) exit + m = m + 1 + end do + else + do while (m>1) + if (v(m-1)>=key) then + m=m-1 + else + exit + end if + end do + end if + ipos = max(m,1) + + case default + write(0,*) 'Wrong FIND' + end select + + + else if (dir_ == psb_sort_down_) then + write(0,*) ' bsrch on sort down not implemented' + else + write(0,*) ' bsrch wrong DIR ',dir_,psb_sort_up_,psb_sort_down_ + end if + return +end function psb_dbsrch + +function psb_dssrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_dssrch + implicit none + integer(psb_ipk_) :: ipos, n + real(psb_dpk_) :: key + real(psb_dpk_) :: v(:) + + integer(psb_ipk_) :: i + + ipos = -1 + do i=1,n + if (key.eq.v(i)) then + ipos = i + return + end if + enddo + + return +end function psb_dssrch + subroutine psb_dqsort(x,ix,dir,flag) use psb_sort_mod, psb_protect_name => psb_dqsort use psb_error_mod diff --git a/base/serial/sort/psb_e_msort_impl.f90 b/base/serial/sort/psb_e_msort_impl.f90 index d8cd64040..b97d448a6 100644 --- a/base/serial/sort/psb_e_msort_impl.f90 +++ b/base/serial/sort/psb_e_msort_impl.f90 @@ -131,64 +131,6 @@ subroutine psb_emsort_u(x,nout,dir) return end subroutine psb_emsort_u - -function psb_ebsrch(key,n,v) result(ipos) - use psb_sort_mod, psb_protect_name => psb_ebsrch - implicit none - integer(psb_ipk_) :: ipos, n - integer(psb_epk_) :: key - integer(psb_epk_) :: v(:) - - integer(psb_ipk_) :: lb, ub, m, i - - ipos = -1 - if (n<5) then - do i=1,n - if (key.eq.v(i)) then - ipos = i - return - end if - enddo - return - end if - - lb = 1 - ub = n - - do while (lb.le.ub) - m = (lb+ub)/2 - if (key.eq.v(m)) then - ipos = m - lb = ub + 1 - else if (key < v(m)) then - ub = m-1 - else - lb = m + 1 - end if - enddo - return -end function psb_ebsrch - -function psb_essrch(key,n,v) result(ipos) - use psb_sort_mod, psb_protect_name => psb_essrch - implicit none - integer(psb_ipk_) :: ipos, n - integer(psb_epk_) :: key - integer(psb_epk_) :: v(:) - - integer(psb_ipk_) :: i - - ipos = -1 - do i=1,n - if (key.eq.v(i)) then - ipos = i - return - end if - enddo - - return -end function psb_essrch - subroutine psb_emsort(x,ix,dir,flag) use psb_sort_mod, psb_protect_name => psb_emsort use psb_error_mod diff --git a/base/serial/sort/psb_e_qsort_impl.f90 b/base/serial/sort/psb_e_qsort_impl.f90 index 9b95c78ee..c70f80519 100644 --- a/base/serial/sort/psb_e_qsort_impl.f90 +++ b/base/serial/sort/psb_e_qsort_impl.f90 @@ -40,6 +40,125 @@ ! Data Structures and Algorithms ! Addison-Wesley ! +function psb_ebsrch(key,n,v,dir,find) result(ipos) + use psb_sort_mod, psb_protect_name => psb_ebsrch + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_epk_) :: key + integer(psb_epk_) :: v(:) + integer(psb_ipk_), optional :: dir, find + + integer(psb_ipk_) :: lb, ub, m, i, k, dir_, find_ + + if (present(dir)) then + dir_ = dir + else + dir_ = psb_sort_up_ + end if + if (present(find)) then + find_ = find + else + find_ = psb_find_any_ + end if + + ipos = -1 + if (dir_ == psb_sort_up_) then + if (n<=5) then + do m=1,n + if (key == v(m)) then + ipos = m + exit + end if + enddo + + else + + lb = 1 + ub = n + + do while (lb.le.ub) + m = (lb+ub)/2 + if (key.eq.v(m)) then + ipos = m + exit + else if (key < v(m)) then + ub = m-1 + else + lb = m + 1 + end if + enddo + end if + select case(find_) + case (psb_find_any_ ) + ! do nothing + case (psb_find_last_le_ ) + if ((m>n) .or. (m<1)) then + m = n + do while (m>=1) + if (v(m)<=key) exit + m = m - 1 + end do + else + do while (mn) .or. (m<1)) then + m = 1 + do while (m<=n) + if (v(m)>=key) exit + m = m + 1 + end do + else + do while (m>1) + if (v(m-1)>=key) then + m=m-1 + else + exit + end if + end do + end if + ipos = max(m,1) + + case default + write(0,*) 'Wrong FIND' + end select + + + else if (dir_ == psb_sort_down_) then + write(0,*) ' bsrch on sort down not implemented' + else + write(0,*) ' bsrch wrong DIR ',dir_,psb_sort_up_,psb_sort_down_ + end if + return +end function psb_ebsrch + +function psb_essrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_essrch + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_epk_) :: key + integer(psb_epk_) :: v(:) + + integer(psb_ipk_) :: i + + ipos = -1 + do i=1,n + if (key.eq.v(i)) then + ipos = i + return + end if + enddo + + return +end function psb_essrch + subroutine psb_eqsort(x,ix,dir,flag) use psb_sort_mod, psb_protect_name => psb_eqsort use psb_error_mod diff --git a/base/serial/sort/psb_m_msort_impl.f90 b/base/serial/sort/psb_m_msort_impl.f90 index cd99a3c56..437d10692 100644 --- a/base/serial/sort/psb_m_msort_impl.f90 +++ b/base/serial/sort/psb_m_msort_impl.f90 @@ -131,64 +131,6 @@ subroutine psb_mmsort_u(x,nout,dir) return end subroutine psb_mmsort_u - -function psb_mbsrch(key,n,v) result(ipos) - use psb_sort_mod, psb_protect_name => psb_mbsrch - implicit none - integer(psb_ipk_) :: ipos, n - integer(psb_mpk_) :: key - integer(psb_mpk_) :: v(:) - - integer(psb_ipk_) :: lb, ub, m, i - - ipos = -1 - if (n<5) then - do i=1,n - if (key.eq.v(i)) then - ipos = i - return - end if - enddo - return - end if - - lb = 1 - ub = n - - do while (lb.le.ub) - m = (lb+ub)/2 - if (key.eq.v(m)) then - ipos = m - lb = ub + 1 - else if (key < v(m)) then - ub = m-1 - else - lb = m + 1 - end if - enddo - return -end function psb_mbsrch - -function psb_mssrch(key,n,v) result(ipos) - use psb_sort_mod, psb_protect_name => psb_mssrch - implicit none - integer(psb_ipk_) :: ipos, n - integer(psb_mpk_) :: key - integer(psb_mpk_) :: v(:) - - integer(psb_ipk_) :: i - - ipos = -1 - do i=1,n - if (key.eq.v(i)) then - ipos = i - return - end if - enddo - - return -end function psb_mssrch - subroutine psb_mmsort(x,ix,dir,flag) use psb_sort_mod, psb_protect_name => psb_mmsort use psb_error_mod diff --git a/base/serial/sort/psb_m_qsort_impl.f90 b/base/serial/sort/psb_m_qsort_impl.f90 index ac8241f59..6b70c3a07 100644 --- a/base/serial/sort/psb_m_qsort_impl.f90 +++ b/base/serial/sort/psb_m_qsort_impl.f90 @@ -40,6 +40,125 @@ ! Data Structures and Algorithms ! Addison-Wesley ! +function psb_mbsrch(key,n,v,dir,find) result(ipos) + use psb_sort_mod, psb_protect_name => psb_mbsrch + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_mpk_) :: key + integer(psb_mpk_) :: v(:) + integer(psb_ipk_), optional :: dir, find + + integer(psb_ipk_) :: lb, ub, m, i, k, dir_, find_ + + if (present(dir)) then + dir_ = dir + else + dir_ = psb_sort_up_ + end if + if (present(find)) then + find_ = find + else + find_ = psb_find_any_ + end if + + ipos = -1 + if (dir_ == psb_sort_up_) then + if (n<=5) then + do m=1,n + if (key == v(m)) then + ipos = m + exit + end if + enddo + + else + + lb = 1 + ub = n + + do while (lb.le.ub) + m = (lb+ub)/2 + if (key.eq.v(m)) then + ipos = m + exit + else if (key < v(m)) then + ub = m-1 + else + lb = m + 1 + end if + enddo + end if + select case(find_) + case (psb_find_any_ ) + ! do nothing + case (psb_find_last_le_ ) + if ((m>n) .or. (m<1)) then + m = n + do while (m>=1) + if (v(m)<=key) exit + m = m - 1 + end do + else + do while (mn) .or. (m<1)) then + m = 1 + do while (m<=n) + if (v(m)>=key) exit + m = m + 1 + end do + else + do while (m>1) + if (v(m-1)>=key) then + m=m-1 + else + exit + end if + end do + end if + ipos = max(m,1) + + case default + write(0,*) 'Wrong FIND' + end select + + + else if (dir_ == psb_sort_down_) then + write(0,*) ' bsrch on sort down not implemented' + else + write(0,*) ' bsrch wrong DIR ',dir_,psb_sort_up_,psb_sort_down_ + end if + return +end function psb_mbsrch + +function psb_mssrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_mssrch + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_mpk_) :: key + integer(psb_mpk_) :: v(:) + + integer(psb_ipk_) :: i + + ipos = -1 + do i=1,n + if (key.eq.v(i)) then + ipos = i + return + end if + enddo + + return +end function psb_mssrch + subroutine psb_mqsort(x,ix,dir,flag) use psb_sort_mod, psb_protect_name => psb_mqsort use psb_error_mod diff --git a/base/serial/sort/psb_s_msort_impl.f90 b/base/serial/sort/psb_s_msort_impl.f90 index dfd7508cf..e3382f27b 100644 --- a/base/serial/sort/psb_s_msort_impl.f90 +++ b/base/serial/sort/psb_s_msort_impl.f90 @@ -76,64 +76,6 @@ subroutine psb_smsort_u(x,nout,dir) return end subroutine psb_smsort_u - -function psb_sbsrch(key,n,v) result(ipos) - use psb_sort_mod, psb_protect_name => psb_sbsrch - implicit none - integer(psb_ipk_) :: ipos, n - real(psb_spk_) :: key - real(psb_spk_) :: v(:) - - integer(psb_ipk_) :: lb, ub, m, i - - ipos = -1 - if (n<5) then - do i=1,n - if (key.eq.v(i)) then - ipos = i - return - end if - enddo - return - end if - - lb = 1 - ub = n - - do while (lb.le.ub) - m = (lb+ub)/2 - if (key.eq.v(m)) then - ipos = m - lb = ub + 1 - else if (key < v(m)) then - ub = m-1 - else - lb = m + 1 - end if - enddo - return -end function psb_sbsrch - -function psb_sssrch(key,n,v) result(ipos) - use psb_sort_mod, psb_protect_name => psb_sssrch - implicit none - integer(psb_ipk_) :: ipos, n - real(psb_spk_) :: key - real(psb_spk_) :: v(:) - - integer(psb_ipk_) :: i - - ipos = -1 - do i=1,n - if (key.eq.v(i)) then - ipos = i - return - end if - enddo - - return -end function psb_sssrch - subroutine psb_smsort(x,ix,dir,flag) use psb_sort_mod, psb_protect_name => psb_smsort use psb_error_mod diff --git a/base/serial/sort/psb_s_qsort_impl.f90 b/base/serial/sort/psb_s_qsort_impl.f90 index d6e0e66e7..cae325464 100644 --- a/base/serial/sort/psb_s_qsort_impl.f90 +++ b/base/serial/sort/psb_s_qsort_impl.f90 @@ -40,6 +40,125 @@ ! Data Structures and Algorithms ! Addison-Wesley ! +function psb_sbsrch(key,n,v,dir,find) result(ipos) + use psb_sort_mod, psb_protect_name => psb_sbsrch + implicit none + integer(psb_ipk_) :: ipos, n + real(psb_spk_) :: key + real(psb_spk_) :: v(:) + integer(psb_ipk_), optional :: dir, find + + integer(psb_ipk_) :: lb, ub, m, i, k, dir_, find_ + + if (present(dir)) then + dir_ = dir + else + dir_ = psb_sort_up_ + end if + if (present(find)) then + find_ = find + else + find_ = psb_find_any_ + end if + + ipos = -1 + if (dir_ == psb_sort_up_) then + if (n<=5) then + do m=1,n + if (key == v(m)) then + ipos = m + exit + end if + enddo + + else + + lb = 1 + ub = n + + do while (lb.le.ub) + m = (lb+ub)/2 + if (key.eq.v(m)) then + ipos = m + exit + else if (key < v(m)) then + ub = m-1 + else + lb = m + 1 + end if + enddo + end if + select case(find_) + case (psb_find_any_ ) + ! do nothing + case (psb_find_last_le_ ) + if ((m>n) .or. (m<1)) then + m = n + do while (m>=1) + if (v(m)<=key) exit + m = m - 1 + end do + else + do while (mn) .or. (m<1)) then + m = 1 + do while (m<=n) + if (v(m)>=key) exit + m = m + 1 + end do + else + do while (m>1) + if (v(m-1)>=key) then + m=m-1 + else + exit + end if + end do + end if + ipos = max(m,1) + + case default + write(0,*) 'Wrong FIND' + end select + + + else if (dir_ == psb_sort_down_) then + write(0,*) ' bsrch on sort down not implemented' + else + write(0,*) ' bsrch wrong DIR ',dir_,psb_sort_up_,psb_sort_down_ + end if + return +end function psb_sbsrch + +function psb_sssrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_sssrch + implicit none + integer(psb_ipk_) :: ipos, n + real(psb_spk_) :: key + real(psb_spk_) :: v(:) + + integer(psb_ipk_) :: i + + ipos = -1 + do i=1,n + if (key.eq.v(i)) then + ipos = i + return + end if + enddo + + return +end function psb_sssrch + subroutine psb_sqsort(x,ix,dir,flag) use psb_sort_mod, psb_protect_name => psb_sqsort use psb_error_mod diff --git a/base/serial/sort/psb_z_qsort_impl.f90 b/base/serial/sort/psb_z_qsort_impl.f90 index 7b0af1c5d..a1cdb1932 100644 --- a/base/serial/sort/psb_z_qsort_impl.f90 +++ b/base/serial/sort/psb_z_qsort_impl.f90 @@ -40,6 +40,7 @@ ! Data Structures and Algorithms ! Addison-Wesley ! + subroutine psb_zqsort(x,ix,dir,flag) use psb_sort_mod, psb_protect_name => psb_zqsort use psb_error_mod diff --git a/base/tools/psb_cd_inloc.f90 b/base/tools/psb_cd_inloc.f90 index e8b9578ec..30c3e9b39 100644 --- a/base/tools/psb_cd_inloc.f90 +++ b/base/tools/psb_cd_inloc.f90 @@ -176,7 +176,8 @@ subroutine psb_cd_inloc(v, ctxt, desc, info, globalcheck,idx,usehash) end if tmpgidx = 0 flag_ = 1 - do i=1,loc_row + !$omp parallel do private(i) + do i=1,loc_row if ((v(i)<1).or.(v(i)>m)) then info = psb_err_entry_out_of_bounds_ l_err(1) = i @@ -215,6 +216,7 @@ subroutine psb_cd_inloc(v, ctxt, desc, info, globalcheck,idx,usehash) novrl = 0 norphan = 0 npr_ov = 0 + !$omp parallel do private(i) do i=1,loc_row if ((v(i)<1).or.(v(i)>m)) then info = psb_err_entry_out_of_bounds_ @@ -222,7 +224,6 @@ subroutine psb_cd_inloc(v, ctxt, desc, info, globalcheck,idx,usehash) l_err(2) = v(i) l_err(3) = loc_row l_err(4) = m - exit endif vl(i) = v(i) end do diff --git a/base/tools/psb_cspins.F90 b/base/tools/psb_cspins.F90 index 27cfbd8e0..e5f2731d0 100644 --- a/base/tools/psb_cspins.F90 +++ b/base/tools/psb_cspins.F90 @@ -51,6 +51,9 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) use psb_base_mod, psb_protect_name => psb_cspins use psi_mod +#if defined(OPENMP) + use omp_lib +#endif implicit none !....parameters... @@ -131,11 +134,117 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) & a_err='allocate',i_err=(/info/)) goto 9999 end if +#if defined(OPENMP) + block + logical :: is_in_parallel + is_in_parallel = omp_in_parallel() + if (is_in_parallel) then + !$omp parallel private(ila,jla,nrow,ncol,nnl,k) + call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) + !$omp critical(spins) + if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& + & mask=(ila(1:nz)>0)) + !$omp end critical(spins) + !write(0,*) me,' after g2l_ins ',psb_errstatus_fatal(),info + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='psb_cdins',i_err=(/info/)) + goto 9998 + end if + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + !write(0,*) me,' Before csput',psb_errstatus_fatal() + if (a%is_bld()) then + call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='a%csput') + goto 9998 + end if + + if (a%is_remote_build()) then + nnl = count(ila(1:nz)<0) + if (nnl > 0) then + allocate(lila(nnl),ljla(nnl),lval(nnl)) + k = 0 + do i=1,nz + if (ila(i)<0) then + k=k+1 + lila(k) = ia(i) + ljla(k) = ja(i) + lval(k) = val(i) + end if + end do + if (k /= nnl) write(0,*) name,' Wrong conversion?',k,nnl + call a%rmta%csput(nnl,lila,ljla,lval,1_psb_lpk_,desc_a%get_global_rows(),& + & 1_psb_lpk_,desc_a%get_global_rows(),info) + end if + end if + + else + info = psb_err_invalid_a_and_cd_state_ + call psb_errpush(info,name) + end if +9998 continue + !write(0,*) me,' after csput',psb_errstatus_fatal() + !$omp end parallel + else + call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) + !write(0,*) me,' Before g2l_ins ',psb_errstatus_fatal() + if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& + & mask=(ila(1:nz)>0)) + !write(0,*) me,' after g2l_ins ',psb_errstatus_fatal(),info + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='psb_cdins',i_err=(/info/)) + goto 9999 + end if + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + !write(0,*) me,' Before csput',psb_errstatus_fatal() + if (a%is_bld()) then + call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='a%csput') + goto 9999 + end if + + if (a%is_remote_build()) then + nnl = count(ila(1:nz)<0) + if (nnl > 0) then + allocate(lila(nnl),ljla(nnl),lval(nnl)) + k = 0 + do i=1,nz + if (ila(i)<0) then + k=k+1 + lila(k) = ia(i) + ljla(k) = ja(i) + lval(k) = val(i) + end if + end do + if (k /= nnl) write(0,*) name,' Wrong conversion?',k,nnl + call a%rmta%csput(nnl,lila,ljla,lval,1_psb_lpk_,desc_a%get_global_rows(),& + & 1_psb_lpk_,desc_a%get_global_rows(),info) + end if + end if + + else + info = psb_err_invalid_a_and_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + end if + end block +#else + + !write(0,*) me,' Before g2l ',psb_errstatus_fatal() + call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) - call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& & mask=(ila(1:nz)>0)) + !write(0,*) me,' after g2l_ins ',psb_errstatus_fatal(),info if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_ai_,name,& & a_err='psb_cdins',i_err=(/info/)) @@ -143,7 +252,7 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) end if nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - + !write(0,*) me,' Before csput',psb_errstatus_fatal() if (a%is_bld()) then call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) if (info /= psb_success_) then @@ -151,11 +260,10 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) call psb_errpush(info,name,a_err='a%csput') goto 9999 end if - + if (a%is_remote_build()) then nnl = count(ila(1:nz)<0) if (nnl > 0) then - !write(0,*) 'Check on insert ',nnl allocate(lila(nnl),ljla(nnl),lval(nnl)) k = 0 do i=1,nz @@ -177,6 +285,8 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) call psb_errpush(info,name) goto 9999 end if +#endif + if (info /= 0) goto 9999 endif else if (desc_a%is_asb()) then @@ -189,9 +299,18 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) & a_err='allocate',i_err=(/info/)) goto 9999 end if +#if defined(OPENMP) + !$omp parallel private(ila,jla,nrow,ncol,nnl,k) +#endif if (local_) then +#if defined(OPENMP) + !$omp workshare +#endif ila(1:nz) = ia(1:nz) jla(1:nz) = ja(1:nz) +#if defined(OPENMP) + !$omp end workshare +#endif else call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) if (info == 0) call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info,& @@ -201,7 +320,7 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='a%csput') - goto 9999 + !goto 9999 end if if (a%is_remote_build()) then nnl = count(ila(1:nz)<0) @@ -220,8 +339,12 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) if (k /= nnl) write(0,*) name,' Wrong conversion?',k,nnl call a%rmta%csput(nnl,lila,ljla,lval,1_psb_lpk_,desc_a%get_global_rows(),& & 1_psb_lpk_,desc_a%get_global_rows(),info) - end if + end if end if +#if defined(OPENMP) + !$omp end parallel +#endif + else info = psb_err_invalid_cd_state_ call psb_errpush(info,name) diff --git a/base/tools/psb_dspins.F90 b/base/tools/psb_dspins.F90 index 2a70ab83a..cdeaa9314 100644 --- a/base/tools/psb_dspins.F90 +++ b/base/tools/psb_dspins.F90 @@ -51,6 +51,9 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) use psb_base_mod, psb_protect_name => psb_dspins use psi_mod +#if defined(OPENMP) + use omp_lib +#endif implicit none !....parameters... @@ -131,11 +134,117 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) & a_err='allocate',i_err=(/info/)) goto 9999 end if +#if defined(OPENMP) + block + logical :: is_in_parallel + is_in_parallel = omp_in_parallel() + if (is_in_parallel) then + !$omp parallel private(ila,jla,nrow,ncol,nnl,k) + call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) + !$omp critical(spins) + if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& + & mask=(ila(1:nz)>0)) + !$omp end critical(spins) + !write(0,*) me,' after g2l_ins ',psb_errstatus_fatal(),info + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='psb_cdins',i_err=(/info/)) + goto 9998 + end if + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + !write(0,*) me,' Before csput',psb_errstatus_fatal() + if (a%is_bld()) then + call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='a%csput') + goto 9998 + end if + + if (a%is_remote_build()) then + nnl = count(ila(1:nz)<0) + if (nnl > 0) then + allocate(lila(nnl),ljla(nnl),lval(nnl)) + k = 0 + do i=1,nz + if (ila(i)<0) then + k=k+1 + lila(k) = ia(i) + ljla(k) = ja(i) + lval(k) = val(i) + end if + end do + if (k /= nnl) write(0,*) name,' Wrong conversion?',k,nnl + call a%rmta%csput(nnl,lila,ljla,lval,1_psb_lpk_,desc_a%get_global_rows(),& + & 1_psb_lpk_,desc_a%get_global_rows(),info) + end if + end if + + else + info = psb_err_invalid_a_and_cd_state_ + call psb_errpush(info,name) + end if +9998 continue + !write(0,*) me,' after csput',psb_errstatus_fatal() + !$omp end parallel + else + call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) + !write(0,*) me,' Before g2l_ins ',psb_errstatus_fatal() + if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& + & mask=(ila(1:nz)>0)) + !write(0,*) me,' after g2l_ins ',psb_errstatus_fatal(),info + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='psb_cdins',i_err=(/info/)) + goto 9999 + end if + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + !write(0,*) me,' Before csput',psb_errstatus_fatal() + if (a%is_bld()) then + call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='a%csput') + goto 9999 + end if + + if (a%is_remote_build()) then + nnl = count(ila(1:nz)<0) + if (nnl > 0) then + allocate(lila(nnl),ljla(nnl),lval(nnl)) + k = 0 + do i=1,nz + if (ila(i)<0) then + k=k+1 + lila(k) = ia(i) + ljla(k) = ja(i) + lval(k) = val(i) + end if + end do + if (k /= nnl) write(0,*) name,' Wrong conversion?',k,nnl + call a%rmta%csput(nnl,lila,ljla,lval,1_psb_lpk_,desc_a%get_global_rows(),& + & 1_psb_lpk_,desc_a%get_global_rows(),info) + end if + end if + + else + info = psb_err_invalid_a_and_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + end if + end block +#else + + !write(0,*) me,' Before g2l ',psb_errstatus_fatal() + call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) - call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& & mask=(ila(1:nz)>0)) + !write(0,*) me,' after g2l_ins ',psb_errstatus_fatal(),info if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_ai_,name,& & a_err='psb_cdins',i_err=(/info/)) @@ -143,7 +252,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) end if nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - + !write(0,*) me,' Before csput',psb_errstatus_fatal() if (a%is_bld()) then call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) if (info /= psb_success_) then @@ -151,11 +260,10 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) call psb_errpush(info,name,a_err='a%csput') goto 9999 end if - + if (a%is_remote_build()) then nnl = count(ila(1:nz)<0) if (nnl > 0) then - !write(0,*) 'Check on insert ',nnl allocate(lila(nnl),ljla(nnl),lval(nnl)) k = 0 do i=1,nz @@ -177,6 +285,8 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) call psb_errpush(info,name) goto 9999 end if +#endif + if (info /= 0) goto 9999 endif else if (desc_a%is_asb()) then @@ -189,9 +299,18 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) & a_err='allocate',i_err=(/info/)) goto 9999 end if +#if defined(OPENMP) + !$omp parallel private(ila,jla,nrow,ncol,nnl,k) +#endif if (local_) then +#if defined(OPENMP) + !$omp workshare +#endif ila(1:nz) = ia(1:nz) jla(1:nz) = ja(1:nz) +#if defined(OPENMP) + !$omp end workshare +#endif else call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) if (info == 0) call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info,& @@ -201,7 +320,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='a%csput') - goto 9999 + !goto 9999 end if if (a%is_remote_build()) then nnl = count(ila(1:nz)<0) @@ -220,8 +339,12 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) if (k /= nnl) write(0,*) name,' Wrong conversion?',k,nnl call a%rmta%csput(nnl,lila,ljla,lval,1_psb_lpk_,desc_a%get_global_rows(),& & 1_psb_lpk_,desc_a%get_global_rows(),info) - end if + end if end if +#if defined(OPENMP) + !$omp end parallel +#endif + else info = psb_err_invalid_cd_state_ call psb_errpush(info,name) diff --git a/base/tools/psb_sspins.F90 b/base/tools/psb_sspins.F90 index aee7a9004..39e4ad799 100644 --- a/base/tools/psb_sspins.F90 +++ b/base/tools/psb_sspins.F90 @@ -51,6 +51,9 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) use psb_base_mod, psb_protect_name => psb_sspins use psi_mod +#if defined(OPENMP) + use omp_lib +#endif implicit none !....parameters... @@ -131,11 +134,117 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) & a_err='allocate',i_err=(/info/)) goto 9999 end if +#if defined(OPENMP) + block + logical :: is_in_parallel + is_in_parallel = omp_in_parallel() + if (is_in_parallel) then + !$omp parallel private(ila,jla,nrow,ncol,nnl,k) + call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) + !$omp critical(spins) + if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& + & mask=(ila(1:nz)>0)) + !$omp end critical(spins) + !write(0,*) me,' after g2l_ins ',psb_errstatus_fatal(),info + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='psb_cdins',i_err=(/info/)) + goto 9998 + end if + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + !write(0,*) me,' Before csput',psb_errstatus_fatal() + if (a%is_bld()) then + call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='a%csput') + goto 9998 + end if + + if (a%is_remote_build()) then + nnl = count(ila(1:nz)<0) + if (nnl > 0) then + allocate(lila(nnl),ljla(nnl),lval(nnl)) + k = 0 + do i=1,nz + if (ila(i)<0) then + k=k+1 + lila(k) = ia(i) + ljla(k) = ja(i) + lval(k) = val(i) + end if + end do + if (k /= nnl) write(0,*) name,' Wrong conversion?',k,nnl + call a%rmta%csput(nnl,lila,ljla,lval,1_psb_lpk_,desc_a%get_global_rows(),& + & 1_psb_lpk_,desc_a%get_global_rows(),info) + end if + end if + + else + info = psb_err_invalid_a_and_cd_state_ + call psb_errpush(info,name) + end if +9998 continue + !write(0,*) me,' after csput',psb_errstatus_fatal() + !$omp end parallel + else + call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) + !write(0,*) me,' Before g2l_ins ',psb_errstatus_fatal() + if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& + & mask=(ila(1:nz)>0)) + !write(0,*) me,' after g2l_ins ',psb_errstatus_fatal(),info + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='psb_cdins',i_err=(/info/)) + goto 9999 + end if + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + !write(0,*) me,' Before csput',psb_errstatus_fatal() + if (a%is_bld()) then + call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='a%csput') + goto 9999 + end if + + if (a%is_remote_build()) then + nnl = count(ila(1:nz)<0) + if (nnl > 0) then + allocate(lila(nnl),ljla(nnl),lval(nnl)) + k = 0 + do i=1,nz + if (ila(i)<0) then + k=k+1 + lila(k) = ia(i) + ljla(k) = ja(i) + lval(k) = val(i) + end if + end do + if (k /= nnl) write(0,*) name,' Wrong conversion?',k,nnl + call a%rmta%csput(nnl,lila,ljla,lval,1_psb_lpk_,desc_a%get_global_rows(),& + & 1_psb_lpk_,desc_a%get_global_rows(),info) + end if + end if + + else + info = psb_err_invalid_a_and_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + end if + end block +#else + + !write(0,*) me,' Before g2l ',psb_errstatus_fatal() + call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) - call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& & mask=(ila(1:nz)>0)) + !write(0,*) me,' after g2l_ins ',psb_errstatus_fatal(),info if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_ai_,name,& & a_err='psb_cdins',i_err=(/info/)) @@ -143,7 +252,7 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) end if nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - + !write(0,*) me,' Before csput',psb_errstatus_fatal() if (a%is_bld()) then call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) if (info /= psb_success_) then @@ -151,11 +260,10 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) call psb_errpush(info,name,a_err='a%csput') goto 9999 end if - + if (a%is_remote_build()) then nnl = count(ila(1:nz)<0) if (nnl > 0) then - !write(0,*) 'Check on insert ',nnl allocate(lila(nnl),ljla(nnl),lval(nnl)) k = 0 do i=1,nz @@ -177,6 +285,8 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) call psb_errpush(info,name) goto 9999 end if +#endif + if (info /= 0) goto 9999 endif else if (desc_a%is_asb()) then @@ -189,9 +299,18 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) & a_err='allocate',i_err=(/info/)) goto 9999 end if +#if defined(OPENMP) + !$omp parallel private(ila,jla,nrow,ncol,nnl,k) +#endif if (local_) then +#if defined(OPENMP) + !$omp workshare +#endif ila(1:nz) = ia(1:nz) jla(1:nz) = ja(1:nz) +#if defined(OPENMP) + !$omp end workshare +#endif else call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) if (info == 0) call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info,& @@ -201,7 +320,7 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='a%csput') - goto 9999 + !goto 9999 end if if (a%is_remote_build()) then nnl = count(ila(1:nz)<0) @@ -220,8 +339,12 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) if (k /= nnl) write(0,*) name,' Wrong conversion?',k,nnl call a%rmta%csput(nnl,lila,ljla,lval,1_psb_lpk_,desc_a%get_global_rows(),& & 1_psb_lpk_,desc_a%get_global_rows(),info) - end if + end if end if +#if defined(OPENMP) + !$omp end parallel +#endif + else info = psb_err_invalid_cd_state_ call psb_errpush(info,name) diff --git a/base/tools/psb_zspins.F90 b/base/tools/psb_zspins.F90 index abe64251d..0c0ff91fd 100644 --- a/base/tools/psb_zspins.F90 +++ b/base/tools/psb_zspins.F90 @@ -51,6 +51,9 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) use psb_base_mod, psb_protect_name => psb_zspins use psi_mod +#if defined(OPENMP) + use omp_lib +#endif implicit none !....parameters... @@ -131,11 +134,117 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) & a_err='allocate',i_err=(/info/)) goto 9999 end if +#if defined(OPENMP) + block + logical :: is_in_parallel + is_in_parallel = omp_in_parallel() + if (is_in_parallel) then + !$omp parallel private(ila,jla,nrow,ncol,nnl,k) + call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) + !$omp critical(spins) + if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& + & mask=(ila(1:nz)>0)) + !$omp end critical(spins) + !write(0,*) me,' after g2l_ins ',psb_errstatus_fatal(),info + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='psb_cdins',i_err=(/info/)) + goto 9998 + end if + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + !write(0,*) me,' Before csput',psb_errstatus_fatal() + if (a%is_bld()) then + call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='a%csput') + goto 9998 + end if + + if (a%is_remote_build()) then + nnl = count(ila(1:nz)<0) + if (nnl > 0) then + allocate(lila(nnl),ljla(nnl),lval(nnl)) + k = 0 + do i=1,nz + if (ila(i)<0) then + k=k+1 + lila(k) = ia(i) + ljla(k) = ja(i) + lval(k) = val(i) + end if + end do + if (k /= nnl) write(0,*) name,' Wrong conversion?',k,nnl + call a%rmta%csput(nnl,lila,ljla,lval,1_psb_lpk_,desc_a%get_global_rows(),& + & 1_psb_lpk_,desc_a%get_global_rows(),info) + end if + end if + + else + info = psb_err_invalid_a_and_cd_state_ + call psb_errpush(info,name) + end if +9998 continue + !write(0,*) me,' after csput',psb_errstatus_fatal() + !$omp end parallel + else + call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) + !write(0,*) me,' Before g2l_ins ',psb_errstatus_fatal() + if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& + & mask=(ila(1:nz)>0)) + !write(0,*) me,' after g2l_ins ',psb_errstatus_fatal(),info + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='psb_cdins',i_err=(/info/)) + goto 9999 + end if + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + !write(0,*) me,' Before csput',psb_errstatus_fatal() + if (a%is_bld()) then + call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='a%csput') + goto 9999 + end if + + if (a%is_remote_build()) then + nnl = count(ila(1:nz)<0) + if (nnl > 0) then + allocate(lila(nnl),ljla(nnl),lval(nnl)) + k = 0 + do i=1,nz + if (ila(i)<0) then + k=k+1 + lila(k) = ia(i) + ljla(k) = ja(i) + lval(k) = val(i) + end if + end do + if (k /= nnl) write(0,*) name,' Wrong conversion?',k,nnl + call a%rmta%csput(nnl,lila,ljla,lval,1_psb_lpk_,desc_a%get_global_rows(),& + & 1_psb_lpk_,desc_a%get_global_rows(),info) + end if + end if + + else + info = psb_err_invalid_a_and_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + end if + end block +#else + + !write(0,*) me,' Before g2l ',psb_errstatus_fatal() + call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) - call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& & mask=(ila(1:nz)>0)) + !write(0,*) me,' after g2l_ins ',psb_errstatus_fatal(),info if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_ai_,name,& & a_err='psb_cdins',i_err=(/info/)) @@ -143,7 +252,7 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) end if nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - + !write(0,*) me,' Before csput',psb_errstatus_fatal() if (a%is_bld()) then call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) if (info /= psb_success_) then @@ -151,11 +260,10 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) call psb_errpush(info,name,a_err='a%csput') goto 9999 end if - + if (a%is_remote_build()) then nnl = count(ila(1:nz)<0) if (nnl > 0) then - !write(0,*) 'Check on insert ',nnl allocate(lila(nnl),ljla(nnl),lval(nnl)) k = 0 do i=1,nz @@ -177,6 +285,8 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) call psb_errpush(info,name) goto 9999 end if +#endif + if (info /= 0) goto 9999 endif else if (desc_a%is_asb()) then @@ -189,9 +299,18 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) & a_err='allocate',i_err=(/info/)) goto 9999 end if +#if defined(OPENMP) + !$omp parallel private(ila,jla,nrow,ncol,nnl,k) +#endif if (local_) then +#if defined(OPENMP) + !$omp workshare +#endif ila(1:nz) = ia(1:nz) jla(1:nz) = ja(1:nz) +#if defined(OPENMP) + !$omp end workshare +#endif else call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) if (info == 0) call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info,& @@ -201,7 +320,7 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='a%csput') - goto 9999 + !goto 9999 end if if (a%is_remote_build()) then nnl = count(ila(1:nz)<0) @@ -220,8 +339,12 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) if (k /= nnl) write(0,*) name,' Wrong conversion?',k,nnl call a%rmta%csput(nnl,lila,ljla,lval,1_psb_lpk_,desc_a%get_global_rows(),& & 1_psb_lpk_,desc_a%get_global_rows(),info) - end if + end if end if +#if defined(OPENMP) + !$omp end parallel +#endif + else info = psb_err_invalid_cd_state_ call psb_errpush(info,name) diff --git a/config/pac.m4 b/config/pac.m4 index 773b7e596..69d2f8634 100644 --- a/config/pac.m4 +++ b/config/pac.m4 @@ -1256,7 +1256,7 @@ if test $pac_blas_ok = no; then [AC_LANG([C]) AC_CHECK_LIB(cblas, cblas_dgemm, [pac_blas_ok=yes - BLAS_LIBS="-lcblas -lf77blas -latlas $BLAS_LIBDIR"], + BLAS_LIBS="-lcblas -lf77blas -latlas"], [], [-lf77blas -latlas])], [], [-latlas])]) @@ -1269,7 +1269,7 @@ if test $pac_blas_ok = no; then [AC_LANG([C]) AC_CHECK_LIB(satlas, cblas_dgemm, [pac_blas_ok=yes - BLAS_LIBS="-lsatlas $BLAS_LIBDIR"], + BLAS_LIBS="-lsatlas"], [], [-lsatlas])], [], [-lsatlas])]) @@ -1281,7 +1281,7 @@ if test $pac_blas_ok = no; then AC_CHECK_LIB(blas, sgemm, [AC_CHECK_LIB(dgemm, dgemm, [AC_CHECK_LIB(sgemm, sgemm, - [pac_blas_ok=yes; BLAS_LIBS="-lsgemm -ldgemm -lblas $BLAS_LIBDIR"], + [pac_blas_ok=yes; BLAS_LIBS="-lsgemm -ldgemm -lblas"], [], [-lblas])], [], [-lblas])]) fi @@ -1290,7 +1290,7 @@ fi # BLAS in OpenBLAS? if test $pac_blas_ok = no; then AC_LANG([Fortran]) - AC_CHECK_LIB(openblas, sgemm, [pac_blas_ok=yes;BLAS_LIBS="-lopenblas $BLAS_LIBDIR"]) + AC_CHECK_LIB(openblas, sgemm, [pac_blas_ok=yes;BLAS_LIBS="-lopenblas"]) fi # BLAS in Intel MKL library? sgemm="sgemm"; @@ -1300,12 +1300,12 @@ if test $pac_blas_ok = no; then # 64 bit if test $host_cpu = x86_64; then AC_CHECK_LIB(mkl_gf_lp64, $sgemm, - [pac_blas_ok=yes;BLAS_LIBS="-lmkl_gf_lp64 -lmkl_sequential -lmkl_core -lpthread $BLAS_LIBDIR"],, + [pac_blas_ok=yes;BLAS_LIBS="-lmkl_gf_lp64 -lmkl_sequential -lmkl_core -lpthread"],, [-lmkl_gf_lp64 -lmkl_sequential -lmkl_core -lpthread]) # 32 bit elif test $host_cpu = i686; then AC_CHECK_LIB(mkl_gf, $sgemm, - [pac_blas_ok=yes;BLAS_LIBS="-lmkl_gf -lmkl_sequential -lmkl_core -lpthread $BLAS_LIBDIR"],, + [pac_blas_ok=yes;BLAS_LIBS="-lmkl_gf -lmkl_sequential -lmkl_core -lpthread"],, [-lmkl_gf -lmkl_sequential -lmkl_core -lpthread]) fi # MKL for other compilers (Intel, PGI, ...?) @@ -1313,37 +1313,37 @@ if test $pac_blas_ok = no; then # 64-bit if test $host_cpu = x86_64; then AC_CHECK_LIB(mkl_intel_lp64, $sgemm, - [pac_blas_ok=yes;BLAS_LIBS="-lmkl_intel_lp64 -lmkl_sequential -lmkl_core -lpthread $BLAS_LIBDIR"],, + [pac_blas_ok=yes;BLAS_LIBS="-lmkl_intel_lp64 -lmkl_sequential -lmkl_core -lpthread"],, [-lmkl_intel_lp64 -lmkl_sequential -lmkl_core -lpthread]) # 32-bit elif test $host_cpu = i686; then AC_CHECK_LIB(mkl_intel, $sgemm, - [pac_blas_ok=yes;BLAS_LIBS="-lmkl_intel -lmkl_sequential -lmkl_core -lpthread $BLAS_LIBDIR"],, + [pac_blas_ok=yes;BLAS_LIBS="-lmkl_intel -lmkl_sequential -lmkl_core -lpthread"],, [-lmkl_intel -lmkl_sequential -lmkl_core -lpthread]) fi fi fi # Old versions of MKL if test $pac_blas_ok = no; then - AC_CHECK_LIB(mkl, $sgemm, [pac_blas_ok=yes;BLAS_LIBS="-lmkl -lguide -lpthread $BLAS_LIBDIR"],,[-lguide -lpthread]) + AC_CHECK_LIB(mkl, $sgemm, [pac_blas_ok=yes;BLAS_LIBS="-lmkl -lguide -lpthread"],,[-lguide -lpthread]) fi # BLAS in Apple vecLib library? if test $pac_blas_ok = no; then save_LIBS="$LIBS"; LIBS="-framework vecLib $LIBS" AC_MSG_CHECKING([for $sgemm in -framework vecLib]) - AC_TRY_LINK_FUNC($sgemm, [pac_blas_ok=yes;BLAS_LIBS="-framework vecLib $BLAS_LIBDIR"]) + AC_TRY_LINK_FUNC($sgemm, [pac_blas_ok=yes;BLAS_LIBS="-framework vecLib"]) AC_MSG_RESULT($pac_blas_ok) LIBS="$save_LIBS" fi # BLAS in Alpha CXML library? if test $pac_blas_ok = no; then - AC_CHECK_LIB(cxml, sgemm, [pac_blas_ok=yes;BLAS_LIBS="-lcxml $BLAS_LIBDIR"]) + AC_CHECK_LIB(cxml, sgemm, [pac_blas_ok=yes;BLAS_LIBS="-lcxml"]) fi # BLAS in Alpha DXML library? (now called CXML, see above) if test $pac_blas_ok = no; then - AC_CHECK_LIB(dxml, sgemm, [pac_blas_ok=yes;BLAS_LIBS="-ldxml $BLAS_LIBDIR"]) + AC_CHECK_LIB(dxml, sgemm, [pac_blas_ok=yes;BLAS_LIBS="-ldxml"]) fi @@ -1352,7 +1352,7 @@ if test $pac_blas_ok = no; then if test "x$GCC" != xyes; then # only works with Sun CC AC_CHECK_LIB(sunmath, acosp, [AC_CHECK_LIB(sunperf, sgemm, - [BLAS_LIBS="-xlic_lib=sunperf -lsunmath $BLAS_LIBDIR" + [BLAS_LIBS="-xlic_lib=sunperf -lsunmath" pac_blas_ok=yes],[],[-lsunmath])]) fi @@ -1360,26 +1360,26 @@ fi # BLAS in SCSL library? (SGI/Cray Scientific Library) if test $pac_blas_ok = no; then - AC_CHECK_LIB(scs, sgemm, [pac_blas_ok=yes; BLAS_LIBS="-lscs $BLAS_LIBDIR"]) + AC_CHECK_LIB(scs, sgemm, [pac_blas_ok=yes; BLAS_LIBS="-lscs"]) fi # BLAS in SGIMATH library? if test $pac_blas_ok = no; then AC_CHECK_LIB(complib.sgimath, $sgemm, - [pac_blas_ok=yes; BLAS_LIBS="-lcomplib.sgimath $BLAS_LIBDIR"]) + [pac_blas_ok=yes; BLAS_LIBS="-lcomplib.sgimath"]) fi # BLAS in IBM ESSL library? (requires generic BLAS lib, too) if test $pac_blas_ok = no; then AC_CHECK_LIB(blas, $sgemm, [AC_CHECK_LIB(essl, sgemm, - [pac_blas_ok=yes; BLAS_LIBS="-lessl -lblas $BLAS_LIBDIR"], + [pac_blas_ok=yes; BLAS_LIBS="-lessl -lblas"], [], [-lblas $FLIBS])]) fi # BLAS in generic BLAS library? if test $pac_blas_ok = no; then AC_LANG([Fortran]) - AC_CHECK_LIB(blas, sgemm, , [pac_blas_ok=yes;BLAS_LIBS="-lblas $BLAS_LIBDIR"]) + AC_CHECK_LIB(blas, sgemm, , [pac_blas_ok=yes;BLAS_LIBS="-lblas"]) fi # BLAS linked to by default? (happens on some supercomputers) @@ -1391,7 +1391,7 @@ fi # Generic BLAS library? if test $pac_blas_ok = no; then AC_LANG([Fortran]) - AC_CHECK_LIB(blas, sgemm, [pac_blas_ok=yes; BLAS_LIBS="-lblas $BLAS_LIBDIR"]) + AC_CHECK_LIB(blas, sgemm, [pac_blas_ok=yes; BLAS_LIBS="-lblas"]) fi dnl AC_SUBST(BLAS_LIBS) @@ -1400,6 +1400,9 @@ LIBS="$pac_blas_save_LIBS" # Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: if test x"$pac_blas_ok" = xyes; then + if test "x$BLAS_LIBDIR" != "x" ; then + BLAS_LIBS="$BLAS_LIBS $BLAS_LIBDIR"; + fi ifelse([$1],,AC_DEFINE(HAVE_BLAS,1,[Define if you have a BLAS library.]),[$1]) : else @@ -1812,7 +1815,11 @@ fi if test "x$pac_amd_header_ok" == "xyes" ; then psblas_cv_amd_includes="$AMD_INCLUDES" - AMD_LIBS="$psblas_cv_amd $AMD_LIBDIR" + if test "x$AMD_LIBDIR" == "x" ; then + AMD_LIBS="$psblas_cv_amd" + else + AMD_LIBS="$psblas_cv_amd $AMD_LIBDIR" + fi LIBS="$AMD_LIBS -lm $LIBS"; AC_MSG_CHECKING([for amd_order in $AMD_LIBS]) AC_TRY_LINK_FUNC(amd_order, @@ -1958,7 +1965,11 @@ fi if test "x$pac_metis_header_ok" = "xyes" ; then psblas_cv_metis_includes="$METIS_INCLUDES" - METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR" + if test "x$METIS_LIBDIR" == "x" ; then + METIS_LIBS="$psblas_cv_metis" + else + METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR" + fi LIBS="$METIS_LIBS -lm $LIBS"; AC_MSG_CHECKING([for METIS_PartGraphKway in $METIS_LIBS]) AC_TRY_LINK_FUNC(METIS_PartGraphKway, diff --git a/configure b/configure index c20b7686c..752fe192f 100755 --- a/configure +++ b/configure @@ -3407,7 +3407,7 @@ test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}' test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' - +INSTALL="${INSTALL} -p" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking where to install" >&5 printf %s "checking where to install... " >&6; } case $prefix in @@ -4676,11 +4676,11 @@ if test x$ac_prog_cxx_stdcxx = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CXX option to enable C++11 features" >&5 printf %s "checking for $CXX option to enable C++11 features... " >&6; } -if test ${ac_cv_prog_cxx_11+y} +if test ${ac_cv_prog_cxx_cxx11+y} then : printf %s "(cached) " >&6 else $as_nop - ac_cv_prog_cxx_11=no + ac_cv_prog_cxx_cxx11=no ac_save_CXX=$CXX cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -4722,11 +4722,11 @@ if test x$ac_prog_cxx_stdcxx = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CXX option to enable C++98 features" >&5 printf %s "checking for $CXX option to enable C++98 features... " >&6; } -if test ${ac_cv_prog_cxx_98+y} +if test ${ac_cv_prog_cxx_cxx98+y} then : printf %s "(cached) " >&6 else $as_nop - ac_cv_prog_cxx_98=no + ac_cv_prog_cxx_cxx98=no ac_save_CXX=$CXX cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -7279,6 +7279,37 @@ if test "X$FCOPT" == "X" ; then # note that no space should be placed around the equality symbol in assignations # Note : 'native' is valid _only_ on GCC/x86 (32/64 bits) FCOPT="-g -O3 -frecursive $FCOPT" + elif test "X$psblas_cv_fc" == X"xlf" ; then + # XL compiler : consider using -qarch=auto + FCOPT="-O3 -qarch=auto -qlanglvl=extended -qxlf2003=polymorphic:autorealloc $FCOPT" + FCFLAGS="-qhalt=e -qlanglvl=extended -qxlf2003=polymorphic:autorealloc $FCFLAGS" + elif test "X$psblas_cv_fc" == X"ifc" ; then + # other compilers .. + FCOPT="-O3 -recursive $FCOPT" + elif test "X$psblas_cv_fc" == X"pg" ; then + # other compilers .. + FCOPT="-fast $FCOPT" + # NOTE : PG & Sun use -fast instead -O3 + elif test "X$psblas_cv_fc" == X"sun" ; then + # other compilers .. + FCOPT="-fast $FCOPT" + elif test "X$psblas_cv_fc" == X"cray" ; then + FCOPT="-O3 -em -J. $FCOPT" + elif test "X$psblas_cv_fc" == X"nag" ; then + # NAG compiler .. + FCOPT="-O2 " + # NOTE : PG & Sun use -fast instead -O3 + else + FCOPT="-g -O2 $FCOPT" + fi +fi +if test "X$psblas_cv_fc" == X"nag" ; then + # Add needed options + FCOPT="$FCOPT -dcfuns -f2003 -wmismatch=mpi_scatterv,mpi_alltoallv,mpi_gatherv,mpi_allgatherv" + EXTRA_OPT="-mismatch_all" +fi +if test "X$psblas_cv_fc" == "Xgcc" ; then + FCOPT="-frecursive $FCOPT" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for version 10 or later of GNU Fortran" >&5 printf %s "checking for version 10 or later of GNU Fortran... " >&6; } ac_ext=${ac_fc_srcext-f} @@ -7317,35 +7348,6 @@ ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $ ac_compiler_gnu=$ac_cv_c_compiler_gnu - - elif test "X$psblas_cv_fc" == X"xlf" ; then - # XL compiler : consider using -qarch=auto - FCOPT="-O3 -qarch=auto -qlanglvl=extended -qxlf2003=polymorphic:autorealloc $FCOPT" - FCFLAGS="-qhalt=e -qlanglvl=extended -qxlf2003=polymorphic:autorealloc $FCFLAGS" - elif test "X$psblas_cv_fc" == X"ifc" ; then - # other compilers .. - FCOPT="-O3 -recursive $FCOPT" - elif test "X$psblas_cv_fc" == X"pg" ; then - # other compilers .. - FCOPT="-fast $FCOPT" - # NOTE : PG & Sun use -fast instead -O3 - elif test "X$psblas_cv_fc" == X"sun" ; then - # other compilers .. - FCOPT="-fast $FCOPT" - elif test "X$psblas_cv_fc" == X"cray" ; then - FCOPT="-O3 -em -J. $FCOPT" - elif test "X$psblas_cv_fc" == X"nag" ; then - # NAG compiler .. - FCOPT="-O2 " - # NOTE : PG & Sun use -fast instead -O3 - else - FCOPT="-g -O2 $FCOPT" - fi -fi -if test "X$psblas_cv_fc" == X"nag" ; then - # Add needed options - FCOPT="$FCOPT -dcfuns -f2003 -wmismatch=mpi_scatterv,mpi_alltoallv,mpi_gatherv,mpi_allgatherv" - EXTRA_OPT="-mismatch_all" fi @@ -8912,7 +8914,7 @@ printf "%s\n" "$ac_cv_lib_cblas_cblas_dgemm" >&6; } if test "x$ac_cv_lib_cblas_cblas_dgemm" = xyes then : pac_blas_ok=yes - BLAS_LIBS="-lcblas -lf77blas -latlas $BLAS_LIBDIR" + BLAS_LIBS="-lcblas -lf77blas -latlas" fi fi @@ -9041,7 +9043,7 @@ printf "%s\n" "$ac_cv_lib_satlas_cblas_dgemm" >&6; } if test "x$ac_cv_lib_satlas_cblas_dgemm" = xyes then : pac_blas_ok=yes - BLAS_LIBS="-lsatlas $BLAS_LIBDIR" + BLAS_LIBS="-lsatlas" fi fi @@ -9139,7 +9141,7 @@ fi printf "%s\n" "$ac_cv_lib_sgemm_sgemm" >&6; } if test "x$ac_cv_lib_sgemm_sgemm" = xyes then : - pac_blas_ok=yes; BLAS_LIBS="-lsgemm -ldgemm -lblas $BLAS_LIBDIR" + pac_blas_ok=yes; BLAS_LIBS="-lsgemm -ldgemm -lblas" fi fi @@ -9183,7 +9185,7 @@ fi printf "%s\n" "$ac_cv_lib_openblas_sgemm" >&6; } if test "x$ac_cv_lib_openblas_sgemm" = xyes then : - pac_blas_ok=yes;BLAS_LIBS="-lopenblas $BLAS_LIBDIR" + pac_blas_ok=yes;BLAS_LIBS="-lopenblas" fi fi @@ -9223,7 +9225,7 @@ eval ac_res=\$$as_ac_Lib printf "%s\n" "$ac_res" >&6; } if eval test \"x\$"$as_ac_Lib"\" = x"yes" then : - pac_blas_ok=yes;BLAS_LIBS="-lmkl_gf_lp64 -lmkl_sequential -lmkl_core -lpthread $BLAS_LIBDIR" + pac_blas_ok=yes;BLAS_LIBS="-lmkl_gf_lp64 -lmkl_sequential -lmkl_core -lpthread" fi # 32 bit @@ -9257,7 +9259,7 @@ eval ac_res=\$$as_ac_Lib printf "%s\n" "$ac_res" >&6; } if eval test \"x\$"$as_ac_Lib"\" = x"yes" then : - pac_blas_ok=yes;BLAS_LIBS="-lmkl_gf -lmkl_sequential -lmkl_core -lpthread $BLAS_LIBDIR" + pac_blas_ok=yes;BLAS_LIBS="-lmkl_gf -lmkl_sequential -lmkl_core -lpthread" fi fi @@ -9294,7 +9296,7 @@ eval ac_res=\$$as_ac_Lib printf "%s\n" "$ac_res" >&6; } if eval test \"x\$"$as_ac_Lib"\" = x"yes" then : - pac_blas_ok=yes;BLAS_LIBS="-lmkl_intel_lp64 -lmkl_sequential -lmkl_core -lpthread $BLAS_LIBDIR" + pac_blas_ok=yes;BLAS_LIBS="-lmkl_intel_lp64 -lmkl_sequential -lmkl_core -lpthread" fi # 32-bit @@ -9328,7 +9330,7 @@ eval ac_res=\$$as_ac_Lib printf "%s\n" "$ac_res" >&6; } if eval test \"x\$"$as_ac_Lib"\" = x"yes" then : - pac_blas_ok=yes;BLAS_LIBS="-lmkl_intel -lmkl_sequential -lmkl_core -lpthread $BLAS_LIBDIR" + pac_blas_ok=yes;BLAS_LIBS="-lmkl_intel -lmkl_sequential -lmkl_core -lpthread" fi fi @@ -9365,7 +9367,7 @@ eval ac_res=\$$as_ac_Lib printf "%s\n" "$ac_res" >&6; } if eval test \"x\$"$as_ac_Lib"\" = x"yes" then : - pac_blas_ok=yes;BLAS_LIBS="-lmkl -lguide -lpthread $BLAS_LIBDIR" + pac_blas_ok=yes;BLAS_LIBS="-lmkl -lguide -lpthread" fi fi @@ -9382,7 +9384,7 @@ printf %s "checking for $sgemm in -framework vecLib... " >&6; } _ACEOF if ac_fn_fc_try_link "$LINENO" then : - pac_blas_ok=yes;BLAS_LIBS="-framework vecLib $BLAS_LIBDIR" + pac_blas_ok=yes;BLAS_LIBS="-framework vecLib" fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext @@ -9419,7 +9421,7 @@ fi printf "%s\n" "$ac_cv_lib_cxml_sgemm" >&6; } if test "x$ac_cv_lib_cxml_sgemm" = xyes then : - pac_blas_ok=yes;BLAS_LIBS="-lcxml $BLAS_LIBDIR" + pac_blas_ok=yes;BLAS_LIBS="-lcxml" fi fi @@ -9453,7 +9455,7 @@ fi printf "%s\n" "$ac_cv_lib_dxml_sgemm" >&6; } if test "x$ac_cv_lib_dxml_sgemm" = xyes then : - pac_blas_ok=yes;BLAS_LIBS="-ldxml $BLAS_LIBDIR" + pac_blas_ok=yes;BLAS_LIBS="-ldxml" fi @@ -9516,7 +9518,7 @@ fi printf "%s\n" "$ac_cv_lib_sunperf_sgemm" >&6; } if test "x$ac_cv_lib_sunperf_sgemm" = xyes then : - BLAS_LIBS="-xlic_lib=sunperf -lsunmath $BLAS_LIBDIR" + BLAS_LIBS="-xlic_lib=sunperf -lsunmath" pac_blas_ok=yes fi @@ -9555,7 +9557,7 @@ fi printf "%s\n" "$ac_cv_lib_scs_sgemm" >&6; } if test "x$ac_cv_lib_scs_sgemm" = xyes then : - pac_blas_ok=yes; BLAS_LIBS="-lscs $BLAS_LIBDIR" + pac_blas_ok=yes; BLAS_LIBS="-lscs" fi fi @@ -9591,7 +9593,7 @@ eval ac_res=\$$as_ac_Lib printf "%s\n" "$ac_res" >&6; } if eval test \"x\$"$as_ac_Lib"\" = x"yes" then : - pac_blas_ok=yes; BLAS_LIBS="-lcomplib.sgimath $BLAS_LIBDIR" + pac_blas_ok=yes; BLAS_LIBS="-lcomplib.sgimath" fi fi @@ -9654,7 +9656,7 @@ fi printf "%s\n" "$ac_cv_lib_essl_sgemm" >&6; } if test "x$ac_cv_lib_essl_sgemm" = xyes then : - pac_blas_ok=yes; BLAS_LIBS="-lessl -lblas $BLAS_LIBDIR" + pac_blas_ok=yes; BLAS_LIBS="-lessl -lblas" fi fi @@ -9699,7 +9701,7 @@ then : LIBS="-lblas $LIBS" else $as_nop - pac_blas_ok=yes;BLAS_LIBS="-lblas $BLAS_LIBDIR" + pac_blas_ok=yes;BLAS_LIBS="-lblas" fi fi @@ -9755,7 +9757,7 @@ fi printf "%s\n" "$ac_cv_lib_blas_sgemm" >&6; } if test "x$ac_cv_lib_blas_sgemm" = xyes then : - pac_blas_ok=yes; BLAS_LIBS="-lblas $BLAS_LIBDIR" + pac_blas_ok=yes; BLAS_LIBS="-lblas" fi fi @@ -9765,6 +9767,9 @@ LIBS="$pac_blas_save_LIBS" # Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: if test x"$pac_blas_ok" = xyes; then + if test "x$BLAS_LIBDIR" != "x" ; then + BLAS_LIBS="$BLAS_LIBS $BLAS_LIBDIR"; + fi printf "%s\n" "#define HAVE_BLAS 1" >>confdefs.h @@ -10225,7 +10230,11 @@ fi if test "x$pac_metis_header_ok" = "xyes" ; then psblas_cv_metis_includes="$METIS_INCLUDES" - METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR" + if test "x$METIS_LIBDIR" == "x" ; then + METIS_LIBS="$psblas_cv_metis" + else + METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR" + fi LIBS="$METIS_LIBS -lm $LIBS"; { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for METIS_PartGraphKway in $METIS_LIBS" >&5 printf %s "checking for METIS_PartGraphKway in $METIS_LIBS... " >&6; } @@ -10492,7 +10501,11 @@ fi if test "x$pac_amd_header_ok" == "xyes" ; then psblas_cv_amd_includes="$AMD_INCLUDES" - AMD_LIBS="$psblas_cv_amd $AMD_LIBDIR" + if test "x$AMD_LIBDIR" == "x" ; then + AMD_LIBS="$psblas_cv_amd" + else + AMD_LIBS="$psblas_cv_amd $AMD_LIBDIR" + fi LIBS="$AMD_LIBS -lm $LIBS"; { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for amd_order in $AMD_LIBS" >&5 printf %s "checking for amd_order in $AMD_LIBS... " >&6; } diff --git a/configure.ac b/configure.ac index 60191cdbf..d8a02a50b 100755 --- a/configure.ac +++ b/configure.ac @@ -70,7 +70,7 @@ AC_MSG_NOTICE([ # # AC_PROG_INSTALL - +INSTALL="${INSTALL} -p" AC_MSG_CHECKING([where to install]) case $prefix in \/* ) eval "INSTALL_DIR=$prefix";; @@ -416,11 +416,7 @@ if test "X$FCOPT" == "X" ; then if test "X$psblas_cv_fc" == "Xgcc" ; then # note that no space should be placed around the equality symbol in assignations # Note : 'native' is valid _only_ on GCC/x86 (32/64 bits) - FCOPT="-g -O3 -frecursive $FCOPT" - PAC_HAVE_GFORTRAN_10( - [FCOPT="-fallow-argument-mismatch $FCOPT"], - []) - + FCOPT="-g -O3 -frecursive $FCOPT" elif test "X$psblas_cv_fc" == X"xlf" ; then # XL compiler : consider using -qarch=auto FCOPT="-O3 -qarch=auto -qlanglvl=extended -qxlf2003=polymorphic:autorealloc $FCOPT" @@ -450,6 +446,12 @@ if test "X$psblas_cv_fc" == X"nag" ; then FCOPT="$FCOPT -dcfuns -f2003 -wmismatch=mpi_scatterv,mpi_alltoallv,mpi_gatherv,mpi_allgatherv" EXTRA_OPT="-mismatch_all" fi +if test "X$psblas_cv_fc" == "Xgcc" ; then + FCOPT="-frecursive $FCOPT" + PAC_HAVE_GFORTRAN_10( + [FCOPT="-fallow-argument-mismatch $FCOPT"], + []) +fi # COPT,FCOPT are aliases for CFLAGS,FCFLAGS . diff --git a/install-sh b/install-sh index e9de23842..ec298b537 100755 --- a/install-sh +++ b/install-sh @@ -1,251 +1,541 @@ #!/bin/sh -# # install - install a program, script, or datafile -# This comes from X11R5 (mit/util/scripts/install.sh). + +scriptversion=2020-11-14.01; # UTC + +# This originates from X11R5 (mit/util/scripts/install.sh), which was +# later released in X11R6 (xc/config/util/install.sh) with the +# following copyright and license. +# +# Copyright (C) 1994 X Consortium +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN +# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- +# TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. # -# Copyright 1991 by the Massachusetts Institute of Technology +# Except as contained in this notice, the name of the X Consortium shall not +# be used in advertising or otherwise to promote the sale, use or other deal- +# ings in this Software without prior written authorization from the X Consor- +# tium. # -# Permission to use, copy, modify, distribute, and sell this software and its -# documentation for any purpose is hereby granted without fee, provided that -# the above copyright notice appear in all copies and that both that -# copyright notice and this permission notice appear in supporting -# documentation, and that the name of M.I.T. not be used in advertising or -# publicity pertaining to distribution of the software without specific, -# written prior permission. M.I.T. makes no representations about the -# suitability of this software for any purpose. It is provided "as is" -# without express or implied warranty. +# +# FSF changes to this file are in the public domain. # # Calling this script install-sh is preferred over install.sh, to prevent -# `make' implicit rules from creating a file called install from it +# 'make' implicit rules from creating a file called install from it # when there is no Makefile. # # This script is compatible with the BSD install script, but was written -# from scratch. It can only install one file at a time, a restriction -# shared with many OS's install programs. +# from scratch. + +tab=' ' +nl=' +' +IFS=" $tab$nl" +# Set DOITPROG to "echo" to test this script. -# set DOITPROG to echo to test this script +doit=${DOITPROG-} +doit_exec=${doit:-exec} -# Don't use :- since 4.3BSD and earlier shells don't like it. -doit="${DOITPROG-}" +# Put in absolute file names if you don't have them in your path; +# or use environment vars. +chgrpprog=${CHGRPPROG-chgrp} +chmodprog=${CHMODPROG-chmod} +chownprog=${CHOWNPROG-chown} +cmpprog=${CMPPROG-cmp} +cpprog=${CPPROG-cp} +mkdirprog=${MKDIRPROG-mkdir} +mvprog=${MVPROG-mv} +rmprog=${RMPROG-rm} +stripprog=${STRIPPROG-strip} -# put in absolute paths if you don't have them in your path; or use env. vars. +posix_mkdir= -mvprog="${MVPROG-mv}" -cpprog="${CPPROG-cp}" -chmodprog="${CHMODPROG-chmod}" -chownprog="${CHOWNPROG-chown}" -chgrpprog="${CHGRPPROG-chgrp}" -stripprog="${STRIPPROG-strip}" -rmprog="${RMPROG-rm}" -mkdirprog="${MKDIRPROG-mkdir}" +# Desired mode of installed file. +mode=0755 -transformbasename="" -transform_arg="" -instcmd="$mvprog" -chmodcmd="$chmodprog 0755" -chowncmd="" -chgrpcmd="" -stripcmd="" +# Create dirs (including intermediate dirs) using mode 755. +# This is like GNU 'install' as of coreutils 8.32 (2020). +mkdir_umask=22 + +backupsuffix= +chgrpcmd= +chmodcmd=$chmodprog +chowncmd= +mvcmd=$mvprog rmcmd="$rmprog -f" -mvcmd="$mvprog" -src="" -dst="" -dir_arg="" - -while [ x"$1" != x ]; do - case $1 in - -c) instcmd="$cpprog" - shift - continue;; - - -d) dir_arg=true - shift - continue;; - - -m) chmodcmd="$chmodprog $2" - shift - shift - continue;; - - -o) chowncmd="$chownprog $2" - shift - shift - continue;; - - -g) chgrpcmd="$chgrpprog $2" - shift - shift - continue;; - - -s) stripcmd="$stripprog" - shift - continue;; - - -t=*) transformarg=`echo $1 | sed 's/-t=//'` - shift - continue;; - - -b=*) transformbasename=`echo $1 | sed 's/-b=//'` - shift - continue;; - - *) if [ x"$src" = x ] - then - src=$1 - else - # this colon is to work around a 386BSD /bin/sh bug - : - dst=$1 - fi - shift - continue;; - esac -done +stripcmd= -if [ x"$src" = x ] -then - echo "install: no input file specified" - exit 1 -else - true -fi +src= +dst= +dir_arg= +dst_arg= -if [ x"$dir_arg" != x ]; then - dst=$src - src="" - - if [ -d $dst ]; then - instcmd=: - chmodcmd="" - else - instcmd=mkdir - fi -else +copy_on_change=false +is_target_a_directory=possibly -# Waiting for this to be detected by the "$instcmd $src $dsttmp" command -# might cause directories to be created, which would be especially bad -# if $src (and thus $dsttmp) contains '*'. +usage="\ +Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE + or: $0 [OPTION]... SRCFILES... DIRECTORY + or: $0 [OPTION]... -t DIRECTORY SRCFILES... + or: $0 [OPTION]... -d DIRECTORIES... - if [ -f $src -o -d $src ] - then - true - else - echo "install: $src does not exist" - exit 1 - fi - - if [ x"$dst" = x ] - then - echo "install: no destination specified" - exit 1 - else - true - fi +In the 1st form, copy SRCFILE to DSTFILE. +In the 2nd and 3rd, copy all SRCFILES to DIRECTORY. +In the 4th, create DIRECTORIES. -# If destination is a directory, append the input filename; if your system -# does not like double slashes in filenames, you may need to add some logic +Options: + --help display this help and exit. + --version display version info and exit. - if [ -d $dst ] - then - dst="$dst"/`basename $src` - else - true - fi -fi + -c (ignored) + -C install only if different (preserve data modification time) + -d create directories instead of installing files. + -g GROUP $chgrpprog installed files to GROUP. + -m MODE $chmodprog installed files to MODE. + -o USER $chownprog installed files to USER. + -p pass -p to $cpprog. + -s $stripprog installed files. + -S SUFFIX attempt to back up existing files, with suffix SUFFIX. + -t DIRECTORY install into DIRECTORY. + -T report an error if DSTFILE is a directory. -## this sed command emulates the dirname command -dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` +Environment variables override the default commands: + CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG + RMPROG STRIPPROG -# Make sure that the destination directory exists. -# this part is taken from Noah Friedman's mkinstalldirs script +By default, rm is invoked with -f; when overridden with RMPROG, +it's up to you to specify -f if you want it. -# Skip lots of stat calls in the usual case. -if [ ! -d "$dstdir" ]; then -defaultIFS=' -' -IFS="${IFS-${defaultIFS}}" +If -S is not specified, no backups are attempted. -oIFS="${IFS}" -# Some sh's can't handle IFS=/ for some reason. -IFS='%' -set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` -IFS="${oIFS}" +Email bug reports to bug-automake@gnu.org. +Automake home page: https://www.gnu.org/software/automake/ +" -pathcomp='' +while test $# -ne 0; do + case $1 in + -c) ;; -while [ $# -ne 0 ] ; do - pathcomp="${pathcomp}${1}" - shift + -C) copy_on_change=true;; - if [ ! -d "${pathcomp}" ] ; - then - $mkdirprog "${pathcomp}" - else - true - fi + -d) dir_arg=true;; - pathcomp="${pathcomp}/" -done -fi + -g) chgrpcmd="$chgrpprog $2" + shift;; -if [ x"$dir_arg" != x ] -then - $doit $instcmd $dst && + --help) echo "$usage"; exit $?;; - if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && - if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && - if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && - if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi -else + -m) mode=$2 + case $mode in + *' '* | *"$tab"* | *"$nl"* | *'*'* | *'?'* | *'['*) + echo "$0: invalid mode: $mode" >&2 + exit 1;; + esac + shift;; -# If we're going to rename the final executable, determine the name now. + -o) chowncmd="$chownprog $2" + shift;; - if [ x"$transformarg" = x ] - then - dstfile=`basename $dst` - else - dstfile=`basename $dst $transformbasename | - sed $transformarg`$transformbasename - fi + -p) cpprog="$cpprog -p";; -# don't allow the sed command to completely eliminate the filename + -s) stripcmd=$stripprog;; - if [ x"$dstfile" = x ] - then - dstfile=`basename $dst` - else - true - fi + -S) backupsuffix="$2" + shift;; -# Make a temp file name in the proper directory. + -t) + is_target_a_directory=always + dst_arg=$2 + # Protect names problematic for 'test' and other utilities. + case $dst_arg in + -* | [=\(\)!]) dst_arg=./$dst_arg;; + esac + shift;; - dsttmp=$dstdir/#inst.$$# + -T) is_target_a_directory=never;; -# Move or copy the file name to the temp name + --version) echo "$0 $scriptversion"; exit $?;; - $doit $instcmd $src $dsttmp && + --) shift + break;; - trap "rm -f ${dsttmp}" 0 && + -*) echo "$0: invalid option: $1" >&2 + exit 1;; -# and set any options; do chmod last to preserve setuid bits + *) break;; + esac + shift +done -# If any of these fail, we abort the whole thing. If we want to -# ignore errors from any of these, just make sure not to ignore -# errors from the above "$doit $instcmd $src $dsttmp" command. +# We allow the use of options -d and -T together, by making -d +# take the precedence; this is for compatibility with GNU install. - if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && - if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && - if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && - if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && +if test -n "$dir_arg"; then + if test -n "$dst_arg"; then + echo "$0: target directory not allowed when installing a directory." >&2 + exit 1 + fi +fi -# Now rename the file to the real destination. +if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then + # When -d is used, all remaining arguments are directories to create. + # When -t is used, the destination is already specified. + # Otherwise, the last argument is the destination. Remove it from $@. + for arg + do + if test -n "$dst_arg"; then + # $@ is not empty: it contains at least $arg. + set fnord "$@" "$dst_arg" + shift # fnord + fi + shift # arg + dst_arg=$arg + # Protect names problematic for 'test' and other utilities. + case $dst_arg in + -* | [=\(\)!]) dst_arg=./$dst_arg;; + esac + done +fi + +if test $# -eq 0; then + if test -z "$dir_arg"; then + echo "$0: no input file specified." >&2 + exit 1 + fi + # It's OK to call 'install-sh -d' without argument. + # This can happen when creating conditional directories. + exit 0 +fi + +if test -z "$dir_arg"; then + if test $# -gt 1 || test "$is_target_a_directory" = always; then + if test ! -d "$dst_arg"; then + echo "$0: $dst_arg: Is not a directory." >&2 + exit 1 + fi + fi +fi - $doit $rmcmd -f $dstdir/$dstfile && - $doit $mvcmd $dsttmp $dstdir/$dstfile +if test -z "$dir_arg"; then + do_exit='(exit $ret); exit $ret' + trap "ret=129; $do_exit" 1 + trap "ret=130; $do_exit" 2 + trap "ret=141; $do_exit" 13 + trap "ret=143; $do_exit" 15 + + # Set umask so as not to create temps with too-generous modes. + # However, 'strip' requires both read and write access to temps. + case $mode in + # Optimize common cases. + *644) cp_umask=133;; + *755) cp_umask=22;; + + *[0-7]) + if test -z "$stripcmd"; then + u_plus_rw= + else + u_plus_rw='% 200' + fi + cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; + *) + if test -z "$stripcmd"; then + u_plus_rw= + else + u_plus_rw=,u+rw + fi + cp_umask=$mode$u_plus_rw;; + esac +fi -fi && +for src +do + # Protect names problematic for 'test' and other utilities. + case $src in + -* | [=\(\)!]) src=./$src;; + esac + + if test -n "$dir_arg"; then + dst=$src + dstdir=$dst + test -d "$dstdir" + dstdir_status=$? + # Don't chown directories that already exist. + if test $dstdir_status = 0; then + chowncmd="" + fi + else + + # Waiting for this to be detected by the "$cpprog $src $dsttmp" command + # might cause directories to be created, which would be especially bad + # if $src (and thus $dsttmp) contains '*'. + if test ! -f "$src" && test ! -d "$src"; then + echo "$0: $src does not exist." >&2 + exit 1 + fi + + if test -z "$dst_arg"; then + echo "$0: no destination specified." >&2 + exit 1 + fi + dst=$dst_arg + + # If destination is a directory, append the input filename. + if test -d "$dst"; then + if test "$is_target_a_directory" = never; then + echo "$0: $dst_arg: Is a directory" >&2 + exit 1 + fi + dstdir=$dst + dstbase=`basename "$src"` + case $dst in + */) dst=$dst$dstbase;; + *) dst=$dst/$dstbase;; + esac + dstdir_status=0 + else + dstdir=`dirname "$dst"` + test -d "$dstdir" + dstdir_status=$? + fi + fi + + case $dstdir in + */) dstdirslash=$dstdir;; + *) dstdirslash=$dstdir/;; + esac + + obsolete_mkdir_used=false + + if test $dstdir_status != 0; then + case $posix_mkdir in + '') + # With -d, create the new directory with the user-specified mode. + # Otherwise, rely on $mkdir_umask. + if test -n "$dir_arg"; then + mkdir_mode=-m$mode + else + mkdir_mode= + fi + + posix_mkdir=false + # The $RANDOM variable is not portable (e.g., dash). Use it + # here however when possible just to lower collision chance. + tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ + + trap ' + ret=$? + rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" 2>/dev/null + exit $ret + ' 0 + + # Because "mkdir -p" follows existing symlinks and we likely work + # directly in world-writeable /tmp, make sure that the '$tmpdir' + # directory is successfully created first before we actually test + # 'mkdir -p'. + if (umask $mkdir_umask && + $mkdirprog $mkdir_mode "$tmpdir" && + exec $mkdirprog $mkdir_mode -p -- "$tmpdir/a/b") >/dev/null 2>&1 + then + if test -z "$dir_arg" || { + # Check for POSIX incompatibilities with -m. + # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or + # other-writable bit of parent directory when it shouldn't. + # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. + test_tmpdir="$tmpdir/a" + ls_ld_tmpdir=`ls -ld "$test_tmpdir"` + case $ls_ld_tmpdir in + d????-?r-*) different_mode=700;; + d????-?--*) different_mode=755;; + *) false;; + esac && + $mkdirprog -m$different_mode -p -- "$test_tmpdir" && { + ls_ld_tmpdir_1=`ls -ld "$test_tmpdir"` + test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" + } + } + then posix_mkdir=: + fi + rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" + else + # Remove any dirs left behind by ancient mkdir implementations. + rmdir ./$mkdir_mode ./-p ./-- "$tmpdir" 2>/dev/null + fi + trap '' 0;; + esac + if + $posix_mkdir && ( + umask $mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" + ) + then : + else + + # mkdir does not conform to POSIX, + # or it failed possibly due to a race condition. Create the + # directory the slow way, step by step, checking for races as we go. + + case $dstdir in + /*) prefix='/';; + [-=\(\)!]*) prefix='./';; + *) prefix='';; + esac + + oIFS=$IFS + IFS=/ + set -f + set fnord $dstdir + shift + set +f + IFS=$oIFS + + prefixes= + + for d + do + test X"$d" = X && continue + + prefix=$prefix$d + if test -d "$prefix"; then + prefixes= + else + if $posix_mkdir; then + (umask $mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break + # Don't fail if two instances are running concurrently. + test -d "$prefix" || exit 1 + else + case $prefix in + *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; + *) qprefix=$prefix;; + esac + prefixes="$prefixes '$qprefix'" + fi + fi + prefix=$prefix/ + done + + if test -n "$prefixes"; then + # Don't fail if two instances are running concurrently. + (umask $mkdir_umask && + eval "\$doit_exec \$mkdirprog $prefixes") || + test -d "$dstdir" || exit 1 + obsolete_mkdir_used=true + fi + fi + fi + + if test -n "$dir_arg"; then + { test -z "$chowncmd" || $doit $chowncmd "$dst"; } && + { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } && + { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false || + test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1 + else + + # Make a couple of temp file names in the proper directory. + dsttmp=${dstdirslash}_inst.$$_ + rmtmp=${dstdirslash}_rm.$$_ + + # Trap to clean up those temp files at exit. + trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0 + + # Copy the file name to the temp name. + (umask $cp_umask && + { test -z "$stripcmd" || { + # Create $dsttmp read-write so that cp doesn't create it read-only, + # which would cause strip to fail. + if test -z "$doit"; then + : >"$dsttmp" # No need to fork-exec 'touch'. + else + $doit touch "$dsttmp" + fi + } + } && + $doit_exec $cpprog "$src" "$dsttmp") && + + # and set any options; do chmod last to preserve setuid bits. + # + # If any of these fail, we abort the whole thing. If we want to + # ignore errors from any of these, just make sure not to ignore + # errors from the above "$doit $cpprog $src $dsttmp" command. + # + { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } && + { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } && + { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } && + { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } && + + # If -C, don't bother to copy if it wouldn't change the file. + if $copy_on_change && + old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && + new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && + set -f && + set X $old && old=:$2:$4:$5:$6 && + set X $new && new=:$2:$4:$5:$6 && + set +f && + test "$old" = "$new" && + $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 + then + rm -f "$dsttmp" + else + # If $backupsuffix is set, and the file being installed + # already exists, attempt a backup. Don't worry if it fails, + # e.g., if mv doesn't support -f. + if test -n "$backupsuffix" && test -f "$dst"; then + $doit $mvcmd -f "$dst" "$dst$backupsuffix" 2>/dev/null + fi + + # Rename the file to the real destination. + $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null || + + # The rename failed, perhaps because mv can't rename something else + # to itself, or perhaps because mv is so ancient that it does not + # support -f. + { + # Now remove or move aside any old file at destination location. + # We try this two ways since rm can't unlink itself on some + # systems and the destination file might be busy for other + # reasons. In this case, the final cleanup might fail but the new + # file should still install successfully. + { + test ! -f "$dst" || + $doit $rmcmd "$dst" 2>/dev/null || + { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && + { $doit $rmcmd "$rmtmp" 2>/dev/null; :; } + } || + { echo "$0: cannot unlink or rename $dst" >&2 + (exit 1); exit 1 + } + } && + + # Now rename the file to the real destination. + $doit $mvcmd "$dsttmp" "$dst" + } + fi || exit 1 + + trap '' 0 + fi +done -exit 0 +# Local variables: +# eval: (add-hook 'before-save-hook 'time-stamp) +# time-stamp-start: "scriptversion=" +# time-stamp-format: "%:y-%02m-%02d.%02H" +# time-stamp-time-zone: "UTC0" +# time-stamp-end: "; # UTC" +# End: diff --git a/prec/impl/psb_c_ilu0_fact.f90 b/prec/impl/psb_c_ilu0_fact.f90 index 1a3e10463..c016359fd 100644 --- a/prec/impl/psb_c_ilu0_fact.f90 +++ b/prec/impl/psb_c_ilu0_fact.f90 @@ -130,7 +130,7 @@ ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck is empty. ! -subroutine psb_cilu0_fact(ialg,a,l,u,d,info,blck, upd) +subroutine psb_cilu0_fact(ialg,a,l,u,d,info,blck, upd,shft) use psb_base_mod use psb_c_ilu_fact_mod, psb_protect_name => psb_cilu0_fact @@ -145,11 +145,13 @@ subroutine psb_cilu0_fact(ialg,a,l,u,d,info,blck, upd) integer(psb_ipk_), intent(out) :: info type(psb_cspmat_type),intent(in), optional, target :: blck character, intent(in), optional :: upd + complex(psb_spk_), intent(in), optional :: shft ! Local variables integer(psb_ipk_) :: l1, l2, m, err_act type(psb_cspmat_type), pointer :: blck_ type(psb_c_csr_sparse_mat) :: ll, uu + complex(psb_spk_) :: shft_ character :: upd_ character(len=20) :: name, ch_err @@ -177,7 +179,12 @@ subroutine psb_cilu0_fact(ialg,a,l,u,d,info,blck, upd) else upd_ = 'F' end if - + if (present(shft)) then + shft_ = shft + else + shft_ = czero + end if + m = a%get_nrows() + blck_%get_nrows() if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& & (m > size(d)) ) then @@ -193,7 +200,7 @@ subroutine psb_cilu0_fact(ialg,a,l,u,d,info,blck, upd) ! Compute the ILU(0) or the MILU(0) factorization, depending on ialg ! call psb_cilu0_factint(ialg,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,upd_,info) + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,upd_,shft_,info) if(info.ne.0) then info=psb_err_from_subroutine_ ch_err='psb_cilu0_factint' @@ -314,7 +321,7 @@ contains ! Error code. ! subroutine psb_cilu0_factint(ialg,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,info) + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,shft,info) implicit none @@ -325,6 +332,7 @@ contains integer(psb_ipk_), intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) complex(psb_spk_), intent(inout) :: lval(:),uval(:),d(:) character, intent(in) :: upd + complex(psb_spk_), intent(in) :: shft ! Local variables integer(psb_ipk_) :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act, m @@ -382,14 +390,14 @@ contains ! into lval/d(i)/uval ! call ilu_copyin(i,ma,a,i,ione,m,l1,lja,lval,& - & d(i),l2,uja,uval,ktrw,trw,upd) + & d(i),l2,uja,uval,ktrw,trw,upd,shft_) else ! ! Copy the i-th local row of the matrix, stored in b ! (as (i-ma)-th row), into lval/d(i)/uval ! call ilu_copyin(i-ma,mb,b,i,ione,m,l1,lja,lval,& - & d(i),l2,uja,uval,ktrw,trw,upd) + & d(i),l2,uja,uval,ktrw,trw,upd,shft_) endif lirp(i+1) = l1 + 1 @@ -583,7 +591,7 @@ contains ! every nrb calls to copyin. If A is in CSR format it is unused. ! subroutine ilu_copyin(i,m,a,jd,jmin,jmax,l1,lja,lval,& - & dia,l2,uja,uval,ktrw,trw,upd) + & dia,l2,uja,uval,ktrw,trw,upd,shft) use psb_base_mod @@ -597,6 +605,7 @@ contains integer(psb_ipk_), intent(inout) :: lja(:), uja(:) complex(psb_spk_), intent(inout) :: lval(:), uval(:), dia character, intent(in) :: upd + complex(psb_spk_), intent(in) :: shft ! Local variables integer(psb_ipk_) :: k,j,info,irb, nz integer(psb_ipk_), parameter :: nrb=40 @@ -625,7 +634,7 @@ contains lval(l1) = aa%val(j) lja(l1) = k else if (k == jd) then - dia = aa%val(j) + dia = aa%val(j) + shft else if ((k > jd).and.(k <= jmax)) then l2 = l2 + 1 uval(l2) = aa%val(j) @@ -665,7 +674,7 @@ contains lval(l1) = trw%val(ktrw) lja(l1) = k else if (k == jd) then - dia = trw%val(ktrw) + dia = trw%val(ktrw) + shft else if ((k > jd).and.(k <= jmax)) then l2 = l2 + 1 uval(l2) = trw%val(ktrw) diff --git a/prec/impl/psb_c_iluk_fact.f90 b/prec/impl/psb_c_iluk_fact.f90 index c4ebc678c..6c6d8a5f3 100644 --- a/prec/impl/psb_c_iluk_fact.f90 +++ b/prec/impl/psb_c_iluk_fact.f90 @@ -127,7 +127,7 @@ ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck does not contain any row. ! -subroutine psb_ciluk_fact(fill_in,ialg,a,l,u,d,info,blck) +subroutine psb_ciluk_fact(fill_in,ialg,a,l,u,d,info,blck,shft) use psb_base_mod use psb_c_ilu_fact_mod, psb_protect_name => psb_ciluk_fact @@ -141,9 +141,11 @@ subroutine psb_ciluk_fact(fill_in,ialg,a,l,u,d,info,blck) type(psb_cspmat_type),intent(inout) :: l,u type(psb_cspmat_type),intent(in), optional, target :: blck complex(psb_spk_), intent(inout) :: d(:) + complex(psb_spk_), intent(in), optional :: shft ! Local Variables integer(psb_ipk_) :: l1, l2, m, err_act + complex(psb_spk_) :: shft_ type(psb_cspmat_type), pointer :: blck_ type(psb_c_csr_sparse_mat) :: ll, uu character(len=20) :: name, ch_err @@ -167,6 +169,11 @@ subroutine psb_ciluk_fact(fill_in,ialg,a,l,u,d,info,blck) goto 9999 end if endif + if (present(shft)) then + shft_ = shft + else + shft_ = czero + end if m = a%get_nrows() + blck_%get_nrows() if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& @@ -184,7 +191,7 @@ subroutine psb_ciluk_fact(fill_in,ialg,a,l,u,d,info,blck) ! Compute the ILU(k) or the MILU(k) factorization, depending on ialg ! call psb_ciluk_factint(fill_in,ialg,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info) + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info,shft_) if (info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_ciluk_factint' @@ -298,7 +305,7 @@ contains ! Error code. ! subroutine psb_ciluk_factint(fill_in,ialg,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info) + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info,shft) use psb_base_mod @@ -311,6 +318,7 @@ contains integer(psb_ipk_), allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) complex(psb_spk_), allocatable, intent(inout) :: lval(:),uval(:) complex(psb_spk_), intent(inout) :: d(:) + complex(psb_spk_), intent(in) :: shft ! Local variables integer(psb_ipk_) :: ma,mb,i, ktrw,err_act,nidx, m @@ -400,13 +408,13 @@ contains ! ! Copy into trw the i-th local row of the matrix, stored in a ! - call iluk_copyin(i,ma,a,ione,m,row,rowlevs,heap,ktrw,trw,info) + call iluk_copyin(i,ma,a,ione,m,row,rowlevs,heap,ktrw,trw,info,shft) else ! ! Copy into trw the i-th local row of the matrix, stored in b ! (as (i-ma)-th row) ! - call iluk_copyin(i-ma,mb,b,ione,m,row,rowlevs,heap,ktrw,trw,info) + call iluk_copyin(i-ma,mb,b,ione,m,row,rowlevs,heap,ktrw,trw,info,shft) endif ! Do an elimination step on the current row. It turns out we only @@ -516,7 +524,7 @@ contains ! until we empty the buffer. Thus we will make a call to psb_sp_getblk ! every nrb calls to copyin. If A is in CSR format it is unused. ! - subroutine iluk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info) + subroutine iluk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info,shft) use psb_base_mod @@ -530,6 +538,8 @@ contains integer(psb_ipk_), intent(inout) :: rowlevs(:) complex(psb_spk_), intent(inout) :: row(:) type(psb_i_heap), intent(inout) :: heap + complex(psb_spk_), intent(in) :: shft + ! Local variables integer(psb_ipk_) :: k,j,irb,err_act,nz @@ -554,6 +564,7 @@ contains k = aa%ja(j) if ((jmin<=k).and.(k<=jmax)) then row(k) = aa%val(j) + if (k==i) row(k) = row(k) + shft rowlevs(k) = 0 call heap%insert(k,info) end if @@ -587,6 +598,7 @@ contains k = trw%ja(ktrw) if ((jmin<=k).and.(k<=jmax)) then row(k) = trw%val(ktrw) + if (k==i) row(k) = row(k) + shft rowlevs(k) = 0 call heap%insert(k,info) end if @@ -670,7 +682,8 @@ contains ! Note: this argument is intent(inout) and not only intent(out) ! to retain its allocation, done by this routine. ! - subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,uja,uirp,uval,uplevs,nidx,idxs,info) + subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,& + & uja,uirp,uval,uplevs,nidx,idxs,info) use psb_base_mod diff --git a/prec/impl/psb_c_ilut_fact.f90 b/prec/impl/psb_c_ilut_fact.f90 index 633899deb..8421ee1c3 100644 --- a/prec/impl/psb_c_ilut_fact.f90 +++ b/prec/impl/psb_c_ilut_fact.f90 @@ -123,7 +123,7 @@ ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck does not contain any row. ! -subroutine psb_cilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) +subroutine psb_cilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale,shft) use psb_base_mod use psb_c_ilu_fact_mod, psb_protect_name => psb_cilut_fact @@ -139,9 +139,11 @@ subroutine psb_cilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) complex(psb_spk_), intent(inout) :: d(:) type(psb_cspmat_type),intent(in), optional, target :: blck integer(psb_ipk_), intent(in), optional :: iscale + complex(psb_spk_), intent(in), optional :: shft ! Local Variables integer(psb_ipk_) :: l1, l2, m, err_act, iscale_ + complex(psb_spk_) :: shft_ type(psb_cspmat_type), pointer :: blck_ type(psb_c_csr_sparse_mat) :: ll, uu real(psb_spk_) :: scale @@ -177,6 +179,11 @@ subroutine psb_cilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) else iscale_ = psb_ilu_scale_none_ end if + if (present(shft)) then + shft_ = shft + else + shft_ = czero + end if select case(iscale_) case(psb_ilu_scale_none_) @@ -206,7 +213,7 @@ subroutine psb_cilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) ! Compute the ILU(k,t) factorization ! call psb_cilut_factint(fill_in,thres,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info,scale) + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info,scale,shft_) if (info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_cilut_factint' @@ -316,7 +323,7 @@ contains ! Error code. ! subroutine psb_cilut_factint(fill_in,thres,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info,scale) + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info,scale,shft) use psb_base_mod @@ -331,6 +338,7 @@ contains complex(psb_spk_), allocatable, intent(inout) :: lval(:),uval(:) complex(psb_spk_), intent(inout) :: d(:) real(psb_spk_), intent(in), optional :: scale + complex(psb_spk_), intent(in) :: shft ! Local Variables integer(psb_ipk_) :: i, ktrw,err_act,nidx,nlw,nup,jmaxup, ma, mb, m @@ -401,10 +409,10 @@ contains d(i) = czero if (i<=ma) then call ilut_copyin(i,ma,a,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& - & row,heap,ktrw,trw,info) + & row,heap,ktrw,trw,info,shft) else call ilut_copyin(i-ma,mb,b,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& - & row,heap,ktrw,trw,info) + & row,heap,ktrw,trw,info,shft) endif ! @@ -540,7 +548,7 @@ contains ! every nrb calls to copyin. If A is in CSR format it is unused. ! subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,& - & nrmi,weight,row,heap,ktrw,trw,info) + & nrmi,weight,row,heap,ktrw,trw,info,shft) use psb_base_mod implicit none type(psb_cspmat_type), intent(in) :: a @@ -551,6 +559,7 @@ contains complex(psb_spk_), intent(inout) :: row(:) real(psb_spk_), intent(in) :: weight type(psb_i_heap), intent(inout) :: heap + complex(psb_spk_), intent(in) :: shft integer(psb_ipk_) :: k,j,irb,kin,nz integer(psb_ipk_), parameter :: nrb=40 @@ -597,6 +606,7 @@ contains call heap%insert(k,info) if (info /= psb_success_) exit if (kjd) then nup = nup + 1 if (abs(row(k))>dmaxup) then @@ -648,6 +658,7 @@ contains call heap%insert(k,info) if (info /= psb_success_) exit if (kjd) then nup = nup + 1 if (abs(row(k))>dmaxup) then diff --git a/prec/impl/psb_d_ilu0_fact.f90 b/prec/impl/psb_d_ilu0_fact.f90 index 478eedfac..dde22249e 100644 --- a/prec/impl/psb_d_ilu0_fact.f90 +++ b/prec/impl/psb_d_ilu0_fact.f90 @@ -130,7 +130,7 @@ ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck is empty. ! -subroutine psb_dilu0_fact(ialg,a,l,u,d,info,blck, upd) +subroutine psb_dilu0_fact(ialg,a,l,u,d,info,blck, upd,shft) use psb_base_mod use psb_d_ilu_fact_mod, psb_protect_name => psb_dilu0_fact @@ -145,11 +145,13 @@ subroutine psb_dilu0_fact(ialg,a,l,u,d,info,blck, upd) integer(psb_ipk_), intent(out) :: info type(psb_dspmat_type),intent(in), optional, target :: blck character, intent(in), optional :: upd + real(psb_dpk_), intent(in), optional :: shft ! Local variables integer(psb_ipk_) :: l1, l2, m, err_act type(psb_dspmat_type), pointer :: blck_ type(psb_d_csr_sparse_mat) :: ll, uu + real(psb_dpk_) :: shft_ character :: upd_ character(len=20) :: name, ch_err @@ -177,7 +179,12 @@ subroutine psb_dilu0_fact(ialg,a,l,u,d,info,blck, upd) else upd_ = 'F' end if - + if (present(shft)) then + shft_ = shft + else + shft_ = dzero + end if + m = a%get_nrows() + blck_%get_nrows() if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& & (m > size(d)) ) then @@ -193,7 +200,7 @@ subroutine psb_dilu0_fact(ialg,a,l,u,d,info,blck, upd) ! Compute the ILU(0) or the MILU(0) factorization, depending on ialg ! call psb_dilu0_factint(ialg,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,upd_,info) + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,upd_,shft_,info) if(info.ne.0) then info=psb_err_from_subroutine_ ch_err='psb_dilu0_factint' @@ -314,7 +321,7 @@ contains ! Error code. ! subroutine psb_dilu0_factint(ialg,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,info) + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,shft,info) implicit none @@ -325,6 +332,7 @@ contains integer(psb_ipk_), intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) real(psb_dpk_), intent(inout) :: lval(:),uval(:),d(:) character, intent(in) :: upd + real(psb_dpk_), intent(in) :: shft ! Local variables integer(psb_ipk_) :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act, m @@ -382,14 +390,14 @@ contains ! into lval/d(i)/uval ! call ilu_copyin(i,ma,a,i,ione,m,l1,lja,lval,& - & d(i),l2,uja,uval,ktrw,trw,upd) + & d(i),l2,uja,uval,ktrw,trw,upd,shft_) else ! ! Copy the i-th local row of the matrix, stored in b ! (as (i-ma)-th row), into lval/d(i)/uval ! call ilu_copyin(i-ma,mb,b,i,ione,m,l1,lja,lval,& - & d(i),l2,uja,uval,ktrw,trw,upd) + & d(i),l2,uja,uval,ktrw,trw,upd,shft_) endif lirp(i+1) = l1 + 1 @@ -583,7 +591,7 @@ contains ! every nrb calls to copyin. If A is in CSR format it is unused. ! subroutine ilu_copyin(i,m,a,jd,jmin,jmax,l1,lja,lval,& - & dia,l2,uja,uval,ktrw,trw,upd) + & dia,l2,uja,uval,ktrw,trw,upd,shft) use psb_base_mod @@ -597,6 +605,7 @@ contains integer(psb_ipk_), intent(inout) :: lja(:), uja(:) real(psb_dpk_), intent(inout) :: lval(:), uval(:), dia character, intent(in) :: upd + real(psb_dpk_), intent(in) :: shft ! Local variables integer(psb_ipk_) :: k,j,info,irb, nz integer(psb_ipk_), parameter :: nrb=40 @@ -625,7 +634,7 @@ contains lval(l1) = aa%val(j) lja(l1) = k else if (k == jd) then - dia = aa%val(j) + dia = aa%val(j) + shft else if ((k > jd).and.(k <= jmax)) then l2 = l2 + 1 uval(l2) = aa%val(j) @@ -665,7 +674,7 @@ contains lval(l1) = trw%val(ktrw) lja(l1) = k else if (k == jd) then - dia = trw%val(ktrw) + dia = trw%val(ktrw) + shft else if ((k > jd).and.(k <= jmax)) then l2 = l2 + 1 uval(l2) = trw%val(ktrw) diff --git a/prec/impl/psb_d_iluk_fact.f90 b/prec/impl/psb_d_iluk_fact.f90 index 544ec987a..dc837ba91 100644 --- a/prec/impl/psb_d_iluk_fact.f90 +++ b/prec/impl/psb_d_iluk_fact.f90 @@ -127,7 +127,7 @@ ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck does not contain any row. ! -subroutine psb_diluk_fact(fill_in,ialg,a,l,u,d,info,blck) +subroutine psb_diluk_fact(fill_in,ialg,a,l,u,d,info,blck,shft) use psb_base_mod use psb_d_ilu_fact_mod, psb_protect_name => psb_diluk_fact @@ -141,9 +141,11 @@ subroutine psb_diluk_fact(fill_in,ialg,a,l,u,d,info,blck) type(psb_dspmat_type),intent(inout) :: l,u type(psb_dspmat_type),intent(in), optional, target :: blck real(psb_dpk_), intent(inout) :: d(:) + real(psb_dpk_), intent(in), optional :: shft ! Local Variables integer(psb_ipk_) :: l1, l2, m, err_act + real(psb_dpk_) :: shft_ type(psb_dspmat_type), pointer :: blck_ type(psb_d_csr_sparse_mat) :: ll, uu character(len=20) :: name, ch_err @@ -167,6 +169,11 @@ subroutine psb_diluk_fact(fill_in,ialg,a,l,u,d,info,blck) goto 9999 end if endif + if (present(shft)) then + shft_ = shft + else + shft_ = dzero + end if m = a%get_nrows() + blck_%get_nrows() if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& @@ -184,7 +191,7 @@ subroutine psb_diluk_fact(fill_in,ialg,a,l,u,d,info,blck) ! Compute the ILU(k) or the MILU(k) factorization, depending on ialg ! call psb_diluk_factint(fill_in,ialg,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info) + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info,shft_) if (info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_diluk_factint' @@ -298,7 +305,7 @@ contains ! Error code. ! subroutine psb_diluk_factint(fill_in,ialg,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info) + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info,shft) use psb_base_mod @@ -311,6 +318,7 @@ contains integer(psb_ipk_), allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) real(psb_dpk_), allocatable, intent(inout) :: lval(:),uval(:) real(psb_dpk_), intent(inout) :: d(:) + real(psb_dpk_), intent(in) :: shft ! Local variables integer(psb_ipk_) :: ma,mb,i, ktrw,err_act,nidx, m @@ -400,13 +408,13 @@ contains ! ! Copy into trw the i-th local row of the matrix, stored in a ! - call iluk_copyin(i,ma,a,ione,m,row,rowlevs,heap,ktrw,trw,info) + call iluk_copyin(i,ma,a,ione,m,row,rowlevs,heap,ktrw,trw,info,shft) else ! ! Copy into trw the i-th local row of the matrix, stored in b ! (as (i-ma)-th row) ! - call iluk_copyin(i-ma,mb,b,ione,m,row,rowlevs,heap,ktrw,trw,info) + call iluk_copyin(i-ma,mb,b,ione,m,row,rowlevs,heap,ktrw,trw,info,shft) endif ! Do an elimination step on the current row. It turns out we only @@ -516,7 +524,7 @@ contains ! until we empty the buffer. Thus we will make a call to psb_sp_getblk ! every nrb calls to copyin. If A is in CSR format it is unused. ! - subroutine iluk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info) + subroutine iluk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info,shft) use psb_base_mod @@ -530,6 +538,8 @@ contains integer(psb_ipk_), intent(inout) :: rowlevs(:) real(psb_dpk_), intent(inout) :: row(:) type(psb_i_heap), intent(inout) :: heap + real(psb_dpk_), intent(in) :: shft + ! Local variables integer(psb_ipk_) :: k,j,irb,err_act,nz @@ -554,6 +564,7 @@ contains k = aa%ja(j) if ((jmin<=k).and.(k<=jmax)) then row(k) = aa%val(j) + if (k==i) row(k) = row(k) + shft rowlevs(k) = 0 call heap%insert(k,info) end if @@ -587,6 +598,7 @@ contains k = trw%ja(ktrw) if ((jmin<=k).and.(k<=jmax)) then row(k) = trw%val(ktrw) + if (k==i) row(k) = row(k) + shft rowlevs(k) = 0 call heap%insert(k,info) end if @@ -670,7 +682,8 @@ contains ! Note: this argument is intent(inout) and not only intent(out) ! to retain its allocation, done by this routine. ! - subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,uja,uirp,uval,uplevs,nidx,idxs,info) + subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,& + & uja,uirp,uval,uplevs,nidx,idxs,info) use psb_base_mod diff --git a/prec/impl/psb_d_ilut_fact.f90 b/prec/impl/psb_d_ilut_fact.f90 index 6c2dc698c..cd185e806 100644 --- a/prec/impl/psb_d_ilut_fact.f90 +++ b/prec/impl/psb_d_ilut_fact.f90 @@ -123,7 +123,7 @@ ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck does not contain any row. ! -subroutine psb_dilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) +subroutine psb_dilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale,shft) use psb_base_mod use psb_d_ilu_fact_mod, psb_protect_name => psb_dilut_fact @@ -139,9 +139,11 @@ subroutine psb_dilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) real(psb_dpk_), intent(inout) :: d(:) type(psb_dspmat_type),intent(in), optional, target :: blck integer(psb_ipk_), intent(in), optional :: iscale + real(psb_dpk_), intent(in), optional :: shft ! Local Variables integer(psb_ipk_) :: l1, l2, m, err_act, iscale_ + real(psb_dpk_) :: shft_ type(psb_dspmat_type), pointer :: blck_ type(psb_d_csr_sparse_mat) :: ll, uu real(psb_dpk_) :: scale @@ -177,6 +179,11 @@ subroutine psb_dilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) else iscale_ = psb_ilu_scale_none_ end if + if (present(shft)) then + shft_ = shft + else + shft_ = dzero + end if select case(iscale_) case(psb_ilu_scale_none_) @@ -206,7 +213,7 @@ subroutine psb_dilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) ! Compute the ILU(k,t) factorization ! call psb_dilut_factint(fill_in,thres,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info,scale) + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info,scale,shft_) if (info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_dilut_factint' @@ -316,7 +323,7 @@ contains ! Error code. ! subroutine psb_dilut_factint(fill_in,thres,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info,scale) + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info,scale,shft) use psb_base_mod @@ -331,6 +338,7 @@ contains real(psb_dpk_), allocatable, intent(inout) :: lval(:),uval(:) real(psb_dpk_), intent(inout) :: d(:) real(psb_dpk_), intent(in), optional :: scale + real(psb_dpk_), intent(in) :: shft ! Local Variables integer(psb_ipk_) :: i, ktrw,err_act,nidx,nlw,nup,jmaxup, ma, mb, m @@ -401,10 +409,10 @@ contains d(i) = czero if (i<=ma) then call ilut_copyin(i,ma,a,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& - & row,heap,ktrw,trw,info) + & row,heap,ktrw,trw,info,shft) else call ilut_copyin(i-ma,mb,b,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& - & row,heap,ktrw,trw,info) + & row,heap,ktrw,trw,info,shft) endif ! @@ -540,7 +548,7 @@ contains ! every nrb calls to copyin. If A is in CSR format it is unused. ! subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,& - & nrmi,weight,row,heap,ktrw,trw,info) + & nrmi,weight,row,heap,ktrw,trw,info,shft) use psb_base_mod implicit none type(psb_dspmat_type), intent(in) :: a @@ -551,6 +559,7 @@ contains real(psb_dpk_), intent(inout) :: row(:) real(psb_dpk_), intent(in) :: weight type(psb_i_heap), intent(inout) :: heap + real(psb_dpk_), intent(in) :: shft integer(psb_ipk_) :: k,j,irb,kin,nz integer(psb_ipk_), parameter :: nrb=40 @@ -597,6 +606,7 @@ contains call heap%insert(k,info) if (info /= psb_success_) exit if (kjd) then nup = nup + 1 if (abs(row(k))>dmaxup) then @@ -648,6 +658,7 @@ contains call heap%insert(k,info) if (info /= psb_success_) exit if (kjd) then nup = nup + 1 if (abs(row(k))>dmaxup) then diff --git a/prec/impl/psb_s_ilu0_fact.f90 b/prec/impl/psb_s_ilu0_fact.f90 index b6f442e9a..d9ce1298e 100644 --- a/prec/impl/psb_s_ilu0_fact.f90 +++ b/prec/impl/psb_s_ilu0_fact.f90 @@ -130,7 +130,7 @@ ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck is empty. ! -subroutine psb_silu0_fact(ialg,a,l,u,d,info,blck, upd) +subroutine psb_silu0_fact(ialg,a,l,u,d,info,blck, upd,shft) use psb_base_mod use psb_s_ilu_fact_mod, psb_protect_name => psb_silu0_fact @@ -145,11 +145,13 @@ subroutine psb_silu0_fact(ialg,a,l,u,d,info,blck, upd) integer(psb_ipk_), intent(out) :: info type(psb_sspmat_type),intent(in), optional, target :: blck character, intent(in), optional :: upd + real(psb_spk_), intent(in), optional :: shft ! Local variables integer(psb_ipk_) :: l1, l2, m, err_act type(psb_sspmat_type), pointer :: blck_ type(psb_s_csr_sparse_mat) :: ll, uu + real(psb_spk_) :: shft_ character :: upd_ character(len=20) :: name, ch_err @@ -177,7 +179,12 @@ subroutine psb_silu0_fact(ialg,a,l,u,d,info,blck, upd) else upd_ = 'F' end if - + if (present(shft)) then + shft_ = shft + else + shft_ = szero + end if + m = a%get_nrows() + blck_%get_nrows() if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& & (m > size(d)) ) then @@ -193,7 +200,7 @@ subroutine psb_silu0_fact(ialg,a,l,u,d,info,blck, upd) ! Compute the ILU(0) or the MILU(0) factorization, depending on ialg ! call psb_silu0_factint(ialg,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,upd_,info) + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,upd_,shft_,info) if(info.ne.0) then info=psb_err_from_subroutine_ ch_err='psb_silu0_factint' @@ -314,7 +321,7 @@ contains ! Error code. ! subroutine psb_silu0_factint(ialg,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,info) + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,shft,info) implicit none @@ -325,6 +332,7 @@ contains integer(psb_ipk_), intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) real(psb_spk_), intent(inout) :: lval(:),uval(:),d(:) character, intent(in) :: upd + real(psb_spk_), intent(in) :: shft ! Local variables integer(psb_ipk_) :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act, m @@ -382,14 +390,14 @@ contains ! into lval/d(i)/uval ! call ilu_copyin(i,ma,a,i,ione,m,l1,lja,lval,& - & d(i),l2,uja,uval,ktrw,trw,upd) + & d(i),l2,uja,uval,ktrw,trw,upd,shft_) else ! ! Copy the i-th local row of the matrix, stored in b ! (as (i-ma)-th row), into lval/d(i)/uval ! call ilu_copyin(i-ma,mb,b,i,ione,m,l1,lja,lval,& - & d(i),l2,uja,uval,ktrw,trw,upd) + & d(i),l2,uja,uval,ktrw,trw,upd,shft_) endif lirp(i+1) = l1 + 1 @@ -583,7 +591,7 @@ contains ! every nrb calls to copyin. If A is in CSR format it is unused. ! subroutine ilu_copyin(i,m,a,jd,jmin,jmax,l1,lja,lval,& - & dia,l2,uja,uval,ktrw,trw,upd) + & dia,l2,uja,uval,ktrw,trw,upd,shft) use psb_base_mod @@ -597,6 +605,7 @@ contains integer(psb_ipk_), intent(inout) :: lja(:), uja(:) real(psb_spk_), intent(inout) :: lval(:), uval(:), dia character, intent(in) :: upd + real(psb_spk_), intent(in) :: shft ! Local variables integer(psb_ipk_) :: k,j,info,irb, nz integer(psb_ipk_), parameter :: nrb=40 @@ -625,7 +634,7 @@ contains lval(l1) = aa%val(j) lja(l1) = k else if (k == jd) then - dia = aa%val(j) + dia = aa%val(j) + shft else if ((k > jd).and.(k <= jmax)) then l2 = l2 + 1 uval(l2) = aa%val(j) @@ -665,7 +674,7 @@ contains lval(l1) = trw%val(ktrw) lja(l1) = k else if (k == jd) then - dia = trw%val(ktrw) + dia = trw%val(ktrw) + shft else if ((k > jd).and.(k <= jmax)) then l2 = l2 + 1 uval(l2) = trw%val(ktrw) diff --git a/prec/impl/psb_s_iluk_fact.f90 b/prec/impl/psb_s_iluk_fact.f90 index 6129663b9..67fb8ada2 100644 --- a/prec/impl/psb_s_iluk_fact.f90 +++ b/prec/impl/psb_s_iluk_fact.f90 @@ -127,7 +127,7 @@ ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck does not contain any row. ! -subroutine psb_siluk_fact(fill_in,ialg,a,l,u,d,info,blck) +subroutine psb_siluk_fact(fill_in,ialg,a,l,u,d,info,blck,shft) use psb_base_mod use psb_s_ilu_fact_mod, psb_protect_name => psb_siluk_fact @@ -141,9 +141,11 @@ subroutine psb_siluk_fact(fill_in,ialg,a,l,u,d,info,blck) type(psb_sspmat_type),intent(inout) :: l,u type(psb_sspmat_type),intent(in), optional, target :: blck real(psb_spk_), intent(inout) :: d(:) + real(psb_spk_), intent(in), optional :: shft ! Local Variables integer(psb_ipk_) :: l1, l2, m, err_act + real(psb_spk_) :: shft_ type(psb_sspmat_type), pointer :: blck_ type(psb_s_csr_sparse_mat) :: ll, uu character(len=20) :: name, ch_err @@ -167,6 +169,11 @@ subroutine psb_siluk_fact(fill_in,ialg,a,l,u,d,info,blck) goto 9999 end if endif + if (present(shft)) then + shft_ = shft + else + shft_ = szero + end if m = a%get_nrows() + blck_%get_nrows() if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& @@ -184,7 +191,7 @@ subroutine psb_siluk_fact(fill_in,ialg,a,l,u,d,info,blck) ! Compute the ILU(k) or the MILU(k) factorization, depending on ialg ! call psb_siluk_factint(fill_in,ialg,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info) + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info,shft_) if (info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_siluk_factint' @@ -298,7 +305,7 @@ contains ! Error code. ! subroutine psb_siluk_factint(fill_in,ialg,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info) + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info,shft) use psb_base_mod @@ -311,6 +318,7 @@ contains integer(psb_ipk_), allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) real(psb_spk_), allocatable, intent(inout) :: lval(:),uval(:) real(psb_spk_), intent(inout) :: d(:) + real(psb_spk_), intent(in) :: shft ! Local variables integer(psb_ipk_) :: ma,mb,i, ktrw,err_act,nidx, m @@ -400,13 +408,13 @@ contains ! ! Copy into trw the i-th local row of the matrix, stored in a ! - call iluk_copyin(i,ma,a,ione,m,row,rowlevs,heap,ktrw,trw,info) + call iluk_copyin(i,ma,a,ione,m,row,rowlevs,heap,ktrw,trw,info,shft) else ! ! Copy into trw the i-th local row of the matrix, stored in b ! (as (i-ma)-th row) ! - call iluk_copyin(i-ma,mb,b,ione,m,row,rowlevs,heap,ktrw,trw,info) + call iluk_copyin(i-ma,mb,b,ione,m,row,rowlevs,heap,ktrw,trw,info,shft) endif ! Do an elimination step on the current row. It turns out we only @@ -516,7 +524,7 @@ contains ! until we empty the buffer. Thus we will make a call to psb_sp_getblk ! every nrb calls to copyin. If A is in CSR format it is unused. ! - subroutine iluk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info) + subroutine iluk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info,shft) use psb_base_mod @@ -530,6 +538,8 @@ contains integer(psb_ipk_), intent(inout) :: rowlevs(:) real(psb_spk_), intent(inout) :: row(:) type(psb_i_heap), intent(inout) :: heap + real(psb_spk_), intent(in) :: shft + ! Local variables integer(psb_ipk_) :: k,j,irb,err_act,nz @@ -554,6 +564,7 @@ contains k = aa%ja(j) if ((jmin<=k).and.(k<=jmax)) then row(k) = aa%val(j) + if (k==i) row(k) = row(k) + shft rowlevs(k) = 0 call heap%insert(k,info) end if @@ -587,6 +598,7 @@ contains k = trw%ja(ktrw) if ((jmin<=k).and.(k<=jmax)) then row(k) = trw%val(ktrw) + if (k==i) row(k) = row(k) + shft rowlevs(k) = 0 call heap%insert(k,info) end if @@ -670,7 +682,8 @@ contains ! Note: this argument is intent(inout) and not only intent(out) ! to retain its allocation, done by this routine. ! - subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,uja,uirp,uval,uplevs,nidx,idxs,info) + subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,& + & uja,uirp,uval,uplevs,nidx,idxs,info) use psb_base_mod diff --git a/prec/impl/psb_s_ilut_fact.f90 b/prec/impl/psb_s_ilut_fact.f90 index 43cacf410..3d1111033 100644 --- a/prec/impl/psb_s_ilut_fact.f90 +++ b/prec/impl/psb_s_ilut_fact.f90 @@ -123,7 +123,7 @@ ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck does not contain any row. ! -subroutine psb_silut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) +subroutine psb_silut_fact(fill_in,thres,a,l,u,d,info,blck,iscale,shft) use psb_base_mod use psb_s_ilu_fact_mod, psb_protect_name => psb_silut_fact @@ -139,9 +139,11 @@ subroutine psb_silut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) real(psb_spk_), intent(inout) :: d(:) type(psb_sspmat_type),intent(in), optional, target :: blck integer(psb_ipk_), intent(in), optional :: iscale + real(psb_spk_), intent(in), optional :: shft ! Local Variables integer(psb_ipk_) :: l1, l2, m, err_act, iscale_ + real(psb_spk_) :: shft_ type(psb_sspmat_type), pointer :: blck_ type(psb_s_csr_sparse_mat) :: ll, uu real(psb_spk_) :: scale @@ -177,6 +179,11 @@ subroutine psb_silut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) else iscale_ = psb_ilu_scale_none_ end if + if (present(shft)) then + shft_ = shft + else + shft_ = szero + end if select case(iscale_) case(psb_ilu_scale_none_) @@ -206,7 +213,7 @@ subroutine psb_silut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) ! Compute the ILU(k,t) factorization ! call psb_silut_factint(fill_in,thres,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info,scale) + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info,scale,shft_) if (info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_silut_factint' @@ -316,7 +323,7 @@ contains ! Error code. ! subroutine psb_silut_factint(fill_in,thres,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info,scale) + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info,scale,shft) use psb_base_mod @@ -331,6 +338,7 @@ contains real(psb_spk_), allocatable, intent(inout) :: lval(:),uval(:) real(psb_spk_), intent(inout) :: d(:) real(psb_spk_), intent(in), optional :: scale + real(psb_spk_), intent(in) :: shft ! Local Variables integer(psb_ipk_) :: i, ktrw,err_act,nidx,nlw,nup,jmaxup, ma, mb, m @@ -401,10 +409,10 @@ contains d(i) = czero if (i<=ma) then call ilut_copyin(i,ma,a,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& - & row,heap,ktrw,trw,info) + & row,heap,ktrw,trw,info,shft) else call ilut_copyin(i-ma,mb,b,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& - & row,heap,ktrw,trw,info) + & row,heap,ktrw,trw,info,shft) endif ! @@ -540,7 +548,7 @@ contains ! every nrb calls to copyin. If A is in CSR format it is unused. ! subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,& - & nrmi,weight,row,heap,ktrw,trw,info) + & nrmi,weight,row,heap,ktrw,trw,info,shft) use psb_base_mod implicit none type(psb_sspmat_type), intent(in) :: a @@ -551,6 +559,7 @@ contains real(psb_spk_), intent(inout) :: row(:) real(psb_spk_), intent(in) :: weight type(psb_i_heap), intent(inout) :: heap + real(psb_spk_), intent(in) :: shft integer(psb_ipk_) :: k,j,irb,kin,nz integer(psb_ipk_), parameter :: nrb=40 @@ -597,6 +606,7 @@ contains call heap%insert(k,info) if (info /= psb_success_) exit if (kjd) then nup = nup + 1 if (abs(row(k))>dmaxup) then @@ -648,6 +658,7 @@ contains call heap%insert(k,info) if (info /= psb_success_) exit if (kjd) then nup = nup + 1 if (abs(row(k))>dmaxup) then diff --git a/prec/impl/psb_z_ilu0_fact.f90 b/prec/impl/psb_z_ilu0_fact.f90 index 26322e959..997a5e054 100644 --- a/prec/impl/psb_z_ilu0_fact.f90 +++ b/prec/impl/psb_z_ilu0_fact.f90 @@ -130,7 +130,7 @@ ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck is empty. ! -subroutine psb_zilu0_fact(ialg,a,l,u,d,info,blck, upd) +subroutine psb_zilu0_fact(ialg,a,l,u,d,info,blck, upd,shft) use psb_base_mod use psb_z_ilu_fact_mod, psb_protect_name => psb_zilu0_fact @@ -145,11 +145,13 @@ subroutine psb_zilu0_fact(ialg,a,l,u,d,info,blck, upd) integer(psb_ipk_), intent(out) :: info type(psb_zspmat_type),intent(in), optional, target :: blck character, intent(in), optional :: upd + complex(psb_dpk_), intent(in), optional :: shft ! Local variables integer(psb_ipk_) :: l1, l2, m, err_act type(psb_zspmat_type), pointer :: blck_ type(psb_z_csr_sparse_mat) :: ll, uu + complex(psb_dpk_) :: shft_ character :: upd_ character(len=20) :: name, ch_err @@ -177,7 +179,12 @@ subroutine psb_zilu0_fact(ialg,a,l,u,d,info,blck, upd) else upd_ = 'F' end if - + if (present(shft)) then + shft_ = shft + else + shft_ = zzero + end if + m = a%get_nrows() + blck_%get_nrows() if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& & (m > size(d)) ) then @@ -193,7 +200,7 @@ subroutine psb_zilu0_fact(ialg,a,l,u,d,info,blck, upd) ! Compute the ILU(0) or the MILU(0) factorization, depending on ialg ! call psb_zilu0_factint(ialg,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,upd_,info) + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,upd_,shft_,info) if(info.ne.0) then info=psb_err_from_subroutine_ ch_err='psb_zilu0_factint' @@ -314,7 +321,7 @@ contains ! Error code. ! subroutine psb_zilu0_factint(ialg,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,info) + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,shft,info) implicit none @@ -325,6 +332,7 @@ contains integer(psb_ipk_), intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) complex(psb_dpk_), intent(inout) :: lval(:),uval(:),d(:) character, intent(in) :: upd + complex(psb_dpk_), intent(in) :: shft ! Local variables integer(psb_ipk_) :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act, m @@ -382,14 +390,14 @@ contains ! into lval/d(i)/uval ! call ilu_copyin(i,ma,a,i,ione,m,l1,lja,lval,& - & d(i),l2,uja,uval,ktrw,trw,upd) + & d(i),l2,uja,uval,ktrw,trw,upd,shft_) else ! ! Copy the i-th local row of the matrix, stored in b ! (as (i-ma)-th row), into lval/d(i)/uval ! call ilu_copyin(i-ma,mb,b,i,ione,m,l1,lja,lval,& - & d(i),l2,uja,uval,ktrw,trw,upd) + & d(i),l2,uja,uval,ktrw,trw,upd,shft_) endif lirp(i+1) = l1 + 1 @@ -583,7 +591,7 @@ contains ! every nrb calls to copyin. If A is in CSR format it is unused. ! subroutine ilu_copyin(i,m,a,jd,jmin,jmax,l1,lja,lval,& - & dia,l2,uja,uval,ktrw,trw,upd) + & dia,l2,uja,uval,ktrw,trw,upd,shft) use psb_base_mod @@ -597,6 +605,7 @@ contains integer(psb_ipk_), intent(inout) :: lja(:), uja(:) complex(psb_dpk_), intent(inout) :: lval(:), uval(:), dia character, intent(in) :: upd + complex(psb_dpk_), intent(in) :: shft ! Local variables integer(psb_ipk_) :: k,j,info,irb, nz integer(psb_ipk_), parameter :: nrb=40 @@ -625,7 +634,7 @@ contains lval(l1) = aa%val(j) lja(l1) = k else if (k == jd) then - dia = aa%val(j) + dia = aa%val(j) + shft else if ((k > jd).and.(k <= jmax)) then l2 = l2 + 1 uval(l2) = aa%val(j) @@ -665,7 +674,7 @@ contains lval(l1) = trw%val(ktrw) lja(l1) = k else if (k == jd) then - dia = trw%val(ktrw) + dia = trw%val(ktrw) + shft else if ((k > jd).and.(k <= jmax)) then l2 = l2 + 1 uval(l2) = trw%val(ktrw) diff --git a/prec/impl/psb_z_iluk_fact.f90 b/prec/impl/psb_z_iluk_fact.f90 index 1a398cdac..a5540880b 100644 --- a/prec/impl/psb_z_iluk_fact.f90 +++ b/prec/impl/psb_z_iluk_fact.f90 @@ -127,7 +127,7 @@ ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck does not contain any row. ! -subroutine psb_ziluk_fact(fill_in,ialg,a,l,u,d,info,blck) +subroutine psb_ziluk_fact(fill_in,ialg,a,l,u,d,info,blck,shft) use psb_base_mod use psb_z_ilu_fact_mod, psb_protect_name => psb_ziluk_fact @@ -141,9 +141,11 @@ subroutine psb_ziluk_fact(fill_in,ialg,a,l,u,d,info,blck) type(psb_zspmat_type),intent(inout) :: l,u type(psb_zspmat_type),intent(in), optional, target :: blck complex(psb_dpk_), intent(inout) :: d(:) + complex(psb_dpk_), intent(in), optional :: shft ! Local Variables integer(psb_ipk_) :: l1, l2, m, err_act + complex(psb_dpk_) :: shft_ type(psb_zspmat_type), pointer :: blck_ type(psb_z_csr_sparse_mat) :: ll, uu character(len=20) :: name, ch_err @@ -167,6 +169,11 @@ subroutine psb_ziluk_fact(fill_in,ialg,a,l,u,d,info,blck) goto 9999 end if endif + if (present(shft)) then + shft_ = shft + else + shft_ = zzero + end if m = a%get_nrows() + blck_%get_nrows() if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& @@ -184,7 +191,7 @@ subroutine psb_ziluk_fact(fill_in,ialg,a,l,u,d,info,blck) ! Compute the ILU(k) or the MILU(k) factorization, depending on ialg ! call psb_ziluk_factint(fill_in,ialg,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info) + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info,shft_) if (info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_ziluk_factint' @@ -298,7 +305,7 @@ contains ! Error code. ! subroutine psb_ziluk_factint(fill_in,ialg,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info) + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info,shft) use psb_base_mod @@ -311,6 +318,7 @@ contains integer(psb_ipk_), allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) complex(psb_dpk_), allocatable, intent(inout) :: lval(:),uval(:) complex(psb_dpk_), intent(inout) :: d(:) + complex(psb_dpk_), intent(in) :: shft ! Local variables integer(psb_ipk_) :: ma,mb,i, ktrw,err_act,nidx, m @@ -400,13 +408,13 @@ contains ! ! Copy into trw the i-th local row of the matrix, stored in a ! - call iluk_copyin(i,ma,a,ione,m,row,rowlevs,heap,ktrw,trw,info) + call iluk_copyin(i,ma,a,ione,m,row,rowlevs,heap,ktrw,trw,info,shft) else ! ! Copy into trw the i-th local row of the matrix, stored in b ! (as (i-ma)-th row) ! - call iluk_copyin(i-ma,mb,b,ione,m,row,rowlevs,heap,ktrw,trw,info) + call iluk_copyin(i-ma,mb,b,ione,m,row,rowlevs,heap,ktrw,trw,info,shft) endif ! Do an elimination step on the current row. It turns out we only @@ -516,7 +524,7 @@ contains ! until we empty the buffer. Thus we will make a call to psb_sp_getblk ! every nrb calls to copyin. If A is in CSR format it is unused. ! - subroutine iluk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info) + subroutine iluk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info,shft) use psb_base_mod @@ -530,6 +538,8 @@ contains integer(psb_ipk_), intent(inout) :: rowlevs(:) complex(psb_dpk_), intent(inout) :: row(:) type(psb_i_heap), intent(inout) :: heap + complex(psb_dpk_), intent(in) :: shft + ! Local variables integer(psb_ipk_) :: k,j,irb,err_act,nz @@ -554,6 +564,7 @@ contains k = aa%ja(j) if ((jmin<=k).and.(k<=jmax)) then row(k) = aa%val(j) + if (k==i) row(k) = row(k) + shft rowlevs(k) = 0 call heap%insert(k,info) end if @@ -587,6 +598,7 @@ contains k = trw%ja(ktrw) if ((jmin<=k).and.(k<=jmax)) then row(k) = trw%val(ktrw) + if (k==i) row(k) = row(k) + shft rowlevs(k) = 0 call heap%insert(k,info) end if @@ -670,7 +682,8 @@ contains ! Note: this argument is intent(inout) and not only intent(out) ! to retain its allocation, done by this routine. ! - subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,uja,uirp,uval,uplevs,nidx,idxs,info) + subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,& + & uja,uirp,uval,uplevs,nidx,idxs,info) use psb_base_mod diff --git a/prec/impl/psb_z_ilut_fact.f90 b/prec/impl/psb_z_ilut_fact.f90 index 291dc7782..0c2785157 100644 --- a/prec/impl/psb_z_ilut_fact.f90 +++ b/prec/impl/psb_z_ilut_fact.f90 @@ -123,7 +123,7 @@ ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck does not contain any row. ! -subroutine psb_zilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) +subroutine psb_zilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale,shft) use psb_base_mod use psb_z_ilu_fact_mod, psb_protect_name => psb_zilut_fact @@ -139,9 +139,11 @@ subroutine psb_zilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) complex(psb_dpk_), intent(inout) :: d(:) type(psb_zspmat_type),intent(in), optional, target :: blck integer(psb_ipk_), intent(in), optional :: iscale + complex(psb_dpk_), intent(in), optional :: shft ! Local Variables integer(psb_ipk_) :: l1, l2, m, err_act, iscale_ + complex(psb_dpk_) :: shft_ type(psb_zspmat_type), pointer :: blck_ type(psb_z_csr_sparse_mat) :: ll, uu real(psb_dpk_) :: scale @@ -177,6 +179,11 @@ subroutine psb_zilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) else iscale_ = psb_ilu_scale_none_ end if + if (present(shft)) then + shft_ = shft + else + shft_ = zzero + end if select case(iscale_) case(psb_ilu_scale_none_) @@ -206,7 +213,7 @@ subroutine psb_zilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) ! Compute the ILU(k,t) factorization ! call psb_zilut_factint(fill_in,thres,a,blck_,& - & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info,scale) + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info,scale,shft_) if (info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_zilut_factint' @@ -316,7 +323,7 @@ contains ! Error code. ! subroutine psb_zilut_factint(fill_in,thres,a,b,& - & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info,scale) + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info,scale,shft) use psb_base_mod @@ -331,6 +338,7 @@ contains complex(psb_dpk_), allocatable, intent(inout) :: lval(:),uval(:) complex(psb_dpk_), intent(inout) :: d(:) real(psb_dpk_), intent(in), optional :: scale + complex(psb_dpk_), intent(in) :: shft ! Local Variables integer(psb_ipk_) :: i, ktrw,err_act,nidx,nlw,nup,jmaxup, ma, mb, m @@ -401,10 +409,10 @@ contains d(i) = czero if (i<=ma) then call ilut_copyin(i,ma,a,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& - & row,heap,ktrw,trw,info) + & row,heap,ktrw,trw,info,shft) else call ilut_copyin(i-ma,mb,b,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& - & row,heap,ktrw,trw,info) + & row,heap,ktrw,trw,info,shft) endif ! @@ -540,7 +548,7 @@ contains ! every nrb calls to copyin. If A is in CSR format it is unused. ! subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,& - & nrmi,weight,row,heap,ktrw,trw,info) + & nrmi,weight,row,heap,ktrw,trw,info,shft) use psb_base_mod implicit none type(psb_zspmat_type), intent(in) :: a @@ -551,6 +559,7 @@ contains complex(psb_dpk_), intent(inout) :: row(:) real(psb_dpk_), intent(in) :: weight type(psb_i_heap), intent(inout) :: heap + complex(psb_dpk_), intent(in) :: shft integer(psb_ipk_) :: k,j,irb,kin,nz integer(psb_ipk_), parameter :: nrb=40 @@ -597,6 +606,7 @@ contains call heap%insert(k,info) if (info /= psb_success_) exit if (kjd) then nup = nup + 1 if (abs(row(k))>dmaxup) then @@ -648,6 +658,7 @@ contains call heap%insert(k,info) if (info /= psb_success_) exit if (kjd) then nup = nup + 1 if (abs(row(k))>dmaxup) then diff --git a/prec/psb_c_ilu_fact_mod.f90 b/prec/psb_c_ilu_fact_mod.f90 index 45d062117..0fae1fc5f 100644 --- a/prec/psb_c_ilu_fact_mod.f90 +++ b/prec/psb_c_ilu_fact_mod.f90 @@ -80,7 +80,7 @@ module psb_c_ilu_fact_mod use psb_base_mod use psb_prec_const_mod interface psb_ilu0_fact - subroutine psb_cilu0_fact(ialg,a,l,u,d,info,blck,upd) + subroutine psb_cilu0_fact(ialg,a,l,u,d,info,blck,upd,shft) import psb_cspmat_type, psb_spk_, psb_ipk_ integer(psb_ipk_), intent(in) :: ialg integer(psb_ipk_), intent(out) :: info @@ -89,11 +89,12 @@ module psb_c_ilu_fact_mod type(psb_cspmat_type),intent(in), optional, target :: blck character, intent(in), optional :: upd complex(psb_spk_), intent(inout) :: d(:) + complex(psb_spk_), intent(in), optional :: shft end subroutine psb_cilu0_fact end interface interface psb_iluk_fact - subroutine psb_ciluk_fact(fill_in,ialg,a,l,u,d,info,blck) + subroutine psb_ciluk_fact(fill_in,ialg,a,l,u,d,info,blck,shft) import psb_cspmat_type, psb_spk_, psb_ipk_ integer(psb_ipk_), intent(in) :: fill_in,ialg integer(psb_ipk_), intent(out) :: info @@ -101,11 +102,12 @@ module psb_c_ilu_fact_mod type(psb_cspmat_type),intent(inout) :: l,u type(psb_cspmat_type),intent(in), optional, target :: blck complex(psb_spk_), intent(inout) :: d(:) + complex(psb_spk_), intent(in), optional :: shft end subroutine psb_ciluk_fact end interface interface psb_ilut_fact - subroutine psb_cilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) + subroutine psb_cilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale,shft) import psb_cspmat_type, psb_spk_, psb_ipk_ integer(psb_ipk_), intent(in) :: fill_in real(psb_spk_), intent(in) :: thres @@ -115,6 +117,7 @@ module psb_c_ilu_fact_mod complex(psb_spk_), intent(inout) :: d(:) type(psb_cspmat_type),intent(in), optional, target :: blck integer(psb_ipk_), intent(in), optional :: iscale + complex(psb_spk_), intent(in), optional :: shft end subroutine psb_cilut_fact end interface diff --git a/prec/psb_d_ilu_fact_mod.f90 b/prec/psb_d_ilu_fact_mod.f90 index 02753a4c1..6354573d0 100644 --- a/prec/psb_d_ilu_fact_mod.f90 +++ b/prec/psb_d_ilu_fact_mod.f90 @@ -80,7 +80,7 @@ module psb_d_ilu_fact_mod use psb_base_mod use psb_prec_const_mod interface psb_ilu0_fact - subroutine psb_dilu0_fact(ialg,a,l,u,d,info,blck,upd) + subroutine psb_dilu0_fact(ialg,a,l,u,d,info,blck,upd,shft) import psb_dspmat_type, psb_dpk_, psb_ipk_ integer(psb_ipk_), intent(in) :: ialg integer(psb_ipk_), intent(out) :: info @@ -89,11 +89,12 @@ module psb_d_ilu_fact_mod type(psb_dspmat_type),intent(in), optional, target :: blck character, intent(in), optional :: upd real(psb_dpk_), intent(inout) :: d(:) + real(psb_dpk_), intent(in), optional :: shft end subroutine psb_dilu0_fact end interface interface psb_iluk_fact - subroutine psb_diluk_fact(fill_in,ialg,a,l,u,d,info,blck) + subroutine psb_diluk_fact(fill_in,ialg,a,l,u,d,info,blck,shft) import psb_dspmat_type, psb_dpk_, psb_ipk_ integer(psb_ipk_), intent(in) :: fill_in,ialg integer(psb_ipk_), intent(out) :: info @@ -101,11 +102,12 @@ module psb_d_ilu_fact_mod type(psb_dspmat_type),intent(inout) :: l,u type(psb_dspmat_type),intent(in), optional, target :: blck real(psb_dpk_), intent(inout) :: d(:) + real(psb_dpk_), intent(in), optional :: shft end subroutine psb_diluk_fact end interface interface psb_ilut_fact - subroutine psb_dilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) + subroutine psb_dilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale,shft) import psb_dspmat_type, psb_dpk_, psb_ipk_ integer(psb_ipk_), intent(in) :: fill_in real(psb_dpk_), intent(in) :: thres @@ -115,6 +117,7 @@ module psb_d_ilu_fact_mod real(psb_dpk_), intent(inout) :: d(:) type(psb_dspmat_type),intent(in), optional, target :: blck integer(psb_ipk_), intent(in), optional :: iscale + real(psb_dpk_), intent(in), optional :: shft end subroutine psb_dilut_fact end interface diff --git a/prec/psb_s_ilu_fact_mod.f90 b/prec/psb_s_ilu_fact_mod.f90 index 6334df15b..4021adc9b 100644 --- a/prec/psb_s_ilu_fact_mod.f90 +++ b/prec/psb_s_ilu_fact_mod.f90 @@ -80,7 +80,7 @@ module psb_s_ilu_fact_mod use psb_base_mod use psb_prec_const_mod interface psb_ilu0_fact - subroutine psb_silu0_fact(ialg,a,l,u,d,info,blck,upd) + subroutine psb_silu0_fact(ialg,a,l,u,d,info,blck,upd,shft) import psb_sspmat_type, psb_spk_, psb_ipk_ integer(psb_ipk_), intent(in) :: ialg integer(psb_ipk_), intent(out) :: info @@ -89,11 +89,12 @@ module psb_s_ilu_fact_mod type(psb_sspmat_type),intent(in), optional, target :: blck character, intent(in), optional :: upd real(psb_spk_), intent(inout) :: d(:) + real(psb_spk_), intent(in), optional :: shft end subroutine psb_silu0_fact end interface interface psb_iluk_fact - subroutine psb_siluk_fact(fill_in,ialg,a,l,u,d,info,blck) + subroutine psb_siluk_fact(fill_in,ialg,a,l,u,d,info,blck,shft) import psb_sspmat_type, psb_spk_, psb_ipk_ integer(psb_ipk_), intent(in) :: fill_in,ialg integer(psb_ipk_), intent(out) :: info @@ -101,11 +102,12 @@ module psb_s_ilu_fact_mod type(psb_sspmat_type),intent(inout) :: l,u type(psb_sspmat_type),intent(in), optional, target :: blck real(psb_spk_), intent(inout) :: d(:) + real(psb_spk_), intent(in), optional :: shft end subroutine psb_siluk_fact end interface interface psb_ilut_fact - subroutine psb_silut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) + subroutine psb_silut_fact(fill_in,thres,a,l,u,d,info,blck,iscale,shft) import psb_sspmat_type, psb_spk_, psb_ipk_ integer(psb_ipk_), intent(in) :: fill_in real(psb_spk_), intent(in) :: thres @@ -115,6 +117,7 @@ module psb_s_ilu_fact_mod real(psb_spk_), intent(inout) :: d(:) type(psb_sspmat_type),intent(in), optional, target :: blck integer(psb_ipk_), intent(in), optional :: iscale + real(psb_spk_), intent(in), optional :: shft end subroutine psb_silut_fact end interface diff --git a/prec/psb_z_ilu_fact_mod.f90 b/prec/psb_z_ilu_fact_mod.f90 index 220d673fe..4793b43bd 100644 --- a/prec/psb_z_ilu_fact_mod.f90 +++ b/prec/psb_z_ilu_fact_mod.f90 @@ -80,7 +80,7 @@ module psb_z_ilu_fact_mod use psb_base_mod use psb_prec_const_mod interface psb_ilu0_fact - subroutine psb_zilu0_fact(ialg,a,l,u,d,info,blck,upd) + subroutine psb_zilu0_fact(ialg,a,l,u,d,info,blck,upd,shft) import psb_zspmat_type, psb_dpk_, psb_ipk_ integer(psb_ipk_), intent(in) :: ialg integer(psb_ipk_), intent(out) :: info @@ -89,11 +89,12 @@ module psb_z_ilu_fact_mod type(psb_zspmat_type),intent(in), optional, target :: blck character, intent(in), optional :: upd complex(psb_dpk_), intent(inout) :: d(:) + complex(psb_dpk_), intent(in), optional :: shft end subroutine psb_zilu0_fact end interface interface psb_iluk_fact - subroutine psb_ziluk_fact(fill_in,ialg,a,l,u,d,info,blck) + subroutine psb_ziluk_fact(fill_in,ialg,a,l,u,d,info,blck,shft) import psb_zspmat_type, psb_dpk_, psb_ipk_ integer(psb_ipk_), intent(in) :: fill_in,ialg integer(psb_ipk_), intent(out) :: info @@ -101,11 +102,12 @@ module psb_z_ilu_fact_mod type(psb_zspmat_type),intent(inout) :: l,u type(psb_zspmat_type),intent(in), optional, target :: blck complex(psb_dpk_), intent(inout) :: d(:) + complex(psb_dpk_), intent(in), optional :: shft end subroutine psb_ziluk_fact end interface interface psb_ilut_fact - subroutine psb_zilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) + subroutine psb_zilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale,shft) import psb_zspmat_type, psb_dpk_, psb_ipk_ integer(psb_ipk_), intent(in) :: fill_in real(psb_dpk_), intent(in) :: thres @@ -115,6 +117,7 @@ module psb_z_ilu_fact_mod complex(psb_dpk_), intent(inout) :: d(:) type(psb_zspmat_type),intent(in), optional, target :: blck integer(psb_ipk_), intent(in), optional :: iscale + complex(psb_dpk_), intent(in), optional :: shft end subroutine psb_zilut_fact end interface diff --git a/test/omp/Makefile b/test/omp/Makefile new file mode 100644 index 000000000..c35431c50 --- /dev/null +++ b/test/omp/Makefile @@ -0,0 +1,56 @@ +INSTALLDIR=../.. +INCDIR=$(INSTALLDIR)/include +MODDIR=$(INSTALLDIR)/modules/ +include $(INCDIR)/Make.inc.psblas +# +# Libraries used +LIBDIR=$(INSTALLDIR)/lib +PSBLAS_LIB= -L$(LIBDIR) -lpsb_util -lpsb_krylov -lpsb_prec -lpsb_base +LDLIBS=$(PSBLDLIBS) +# +# Compilers and such +# +CCOPT= -g +FINCLUDES=$(FMFLAG)$(MODDIR) $(FMFLAG). + + +EXEDIR=./runs + +all: runsd psb_tomp #psb_d_pde3d psb_s_pde3d psb_d_pde2d psb_s_pde2d + +runsd: + (if test ! -d runs ; then mkdir runs; fi) + +psb_tomp: psb_tomp.o + $(FLINK) psb_tomp.o -o psb_tomp $(PSBLAS_LIB) $(LDLIBS) + /bin/mv psb_tomp $(EXEDIR) + +psb_d_pde3d: psb_d_pde3d.o + $(FLINK) psb_d_pde3d.o -o psb_d_pde3d $(PSBLAS_LIB) $(LDLIBS) + /bin/mv psb_d_pde3d $(EXEDIR) + + +psb_s_pde3d: psb_s_pde3d.o + $(FLINK) psb_s_pde3d.o -o psb_s_pde3d $(PSBLAS_LIB) $(LDLIBS) + /bin/mv psb_s_pde3d $(EXEDIR) + +psb_d_pde2d: psb_d_pde2d.o + $(FLINK) psb_d_pde2d.o -o psb_d_pde2d $(PSBLAS_LIB) $(LDLIBS) + /bin/mv psb_d_pde2d $(EXEDIR) + + +psb_s_pde2d: psb_s_pde2d.o + $(FLINK) psb_s_pde2d.o -o psb_s_pde2d $(PSBLAS_LIB) $(LDLIBS) + /bin/mv psb_s_pde2d $(EXEDIR) + + +clean: + /bin/rm -f psb_tomp.o psb_d_pde3d.o psb_s_pde3d.o psb_d_pde2d.o psb_s_pde2d.o *$(.mod) \ + $(EXEDIR)/psb_d_pde3d $(EXEDIR)/psb_s_pde3d $(EXEDIR)/psb_d_pde2d $(EXEDIR)/psb_s_pde2d +verycleanlib: + (cd ../..; make veryclean) +lib: + (cd ../../; make library) + + + diff --git a/test/omp/psb_tomp.F90 b/test/omp/psb_tomp.F90 new file mode 100644 index 000000000..79097ca81 --- /dev/null +++ b/test/omp/psb_tomp.F90 @@ -0,0 +1,1091 @@ +! +! 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. +! +! +! File: psb_d_pde3d.f90 +! +! Program: psb_d_pde3d +! This sample program solves a linear system obtained by discretizing a +! PDE with Dirichlet BCs. +! +! +! The PDE is a general second order equation in 3d +! +! a1 dd(u) a2 dd(u) a3 dd(u) b1 d(u) b2 d(u) b3 d(u) +! - ------ - ------ - ------ + ----- + ------ + ------ + c u = f +! dxdx dydy dzdz dx dy dz +! +! with Dirichlet boundary conditions +! u = g +! +! on the unit cube 0<=x,y,z<=1. +! +! +! Note that if b1=b2=b3=c=0., the PDE is the Laplace equation. +! +! There are three choices available for data distribution: +! 1. A simple BLOCK distribution +! 2. A ditribution based on arbitrary assignment of indices to processes, +! typically from a graph partitioner +! 3. A 3D distribution in which the unit cube is partitioned +! into subcubes, each one assigned to a process. +! +! +module psb_d_pde3d_mod + + + use psb_base_mod, only : psb_dpk_, psb_ipk_, psb_lpk_, psb_desc_type,& + & psb_dspmat_type, psb_d_vect_type, dzero,& + & psb_d_base_sparse_mat, psb_d_base_vect_type, & + & psb_i_base_vect_type, psb_l_base_vect_type + + interface + function d_func_3d(x,y,z) result(val) + import :: psb_dpk_ + real(psb_dpk_), intent(in) :: x,y,z + real(psb_dpk_) :: val + end function d_func_3d + end interface + + interface psb_gen_pde3d + module procedure psb_d_gen_pde3d + end interface psb_gen_pde3d + +contains + + function d_null_func_3d(x,y,z) result(val) + + real(psb_dpk_), intent(in) :: x,y,z + real(psb_dpk_) :: val + + val = dzero + + end function d_null_func_3d + ! + ! functions parametrizing the differential equation + ! + + ! + ! Note: b1, b2 and b3 are the coefficients of the first + ! derivative of the unknown function. The default + ! we apply here is to have them zero, so that the resulting + ! matrix is symmetric/hermitian and suitable for + ! testing with CG and FCG. + ! When testing methods for non-hermitian matrices you can + ! change the B1/B2/B3 functions to e.g. done/sqrt((3*done)) + ! + function b1(x,y,z) + use psb_base_mod, only : psb_dpk_, done, dzero + implicit none + real(psb_dpk_) :: b1 + real(psb_dpk_), intent(in) :: x,y,z + b1=dzero + end function b1 + function b2(x,y,z) + use psb_base_mod, only : psb_dpk_, done, dzero + implicit none + real(psb_dpk_) :: b2 + real(psb_dpk_), intent(in) :: x,y,z + b2=dzero + end function b2 + function b3(x,y,z) + use psb_base_mod, only : psb_dpk_, done, dzero + implicit none + real(psb_dpk_) :: b3 + real(psb_dpk_), intent(in) :: x,y,z + b3=dzero + end function b3 + function c(x,y,z) + use psb_base_mod, only : psb_dpk_, done, dzero + implicit none + real(psb_dpk_) :: c + real(psb_dpk_), intent(in) :: x,y,z + c=dzero + end function c + function a1(x,y,z) + use psb_base_mod, only : psb_dpk_, done, dzero + implicit none + real(psb_dpk_) :: a1 + real(psb_dpk_), intent(in) :: x,y,z + a1=done/80 + end function a1 + function a2(x,y,z) + use psb_base_mod, only : psb_dpk_, done, dzero + implicit none + real(psb_dpk_) :: a2 + real(psb_dpk_), intent(in) :: x,y,z + a2=done/80 + end function a2 + function a3(x,y,z) + use psb_base_mod, only : psb_dpk_, done, dzero + implicit none + real(psb_dpk_) :: a3 + real(psb_dpk_), intent(in) :: x,y,z + a3=done/80 + end function a3 + function g(x,y,z) + use psb_base_mod, only : psb_dpk_, done, dzero + implicit none + real(psb_dpk_) :: g + real(psb_dpk_), intent(in) :: x,y,z + g = dzero + if (x == done) then + g = done + else if (x == dzero) then + g = exp(y**2-z**2) + end if + end function g + + + ! + ! subroutine to allocate and fill in the coefficient matrix and + ! the rhs. + ! + subroutine psb_d_gen_pde3d(ctxt,idim,a,bv,xv,desc_a,afmt,info,& + & f,amold,vmold,imold,partition,nrl,iv) + use psb_base_mod + use psb_util_mod +#if defined(OPENMP) + use omp_lib +#endif + ! + ! Discretizes the partial differential equation + ! + ! a1 dd(u) a2 dd(u) a3 dd(u) b1 d(u) b2 d(u) b3 d(u) + ! - ------ - ------ - ------ + ----- + ------ + ------ + c u = f + ! dxdx dydy dzdz dx dy dz + ! + ! with Dirichlet boundary conditions + ! u = g + ! + ! on the unit cube 0<=x,y,z<=1. + ! + ! + ! Note that if b1=b2=b3=c=0., the PDE is the Laplace equation. + ! + implicit none + integer(psb_ipk_) :: idim + type(psb_dspmat_type) :: a + type(psb_d_vect_type) :: xv,bv + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: info + character(len=*) :: afmt + procedure(d_func_3d), optional :: f + class(psb_d_base_sparse_mat), optional :: amold + class(psb_d_base_vect_type), optional :: vmold + class(psb_i_base_vect_type), optional :: imold + integer(psb_ipk_), optional :: partition, nrl,iv(:) + + ! Local variables. + + integer(psb_ipk_), parameter :: nb=20 + type(psb_d_csc_sparse_mat) :: acsc + type(psb_d_coo_sparse_mat) :: acoo + type(psb_d_csr_sparse_mat) :: acsr + real(psb_dpk_) :: zt(nb),x,y,z + integer(psb_ipk_) :: nnz,nr,nlr,i,j,ii,ib,k, partition_, mysz + integer(psb_lpk_) :: m,n,glob_row,nt + integer(psb_ipk_) :: ix,iy,iz,ia,indx_owner + ! For 3D partition + ! Note: integer control variables going directly into an MPI call + ! must be 4 bytes, i.e. psb_mpk_ + integer(psb_mpk_) :: npdims(3), npp, minfo + integer(psb_ipk_) :: npx,npy,npz, iamx,iamy,iamz,mynx,myny,mynz + integer(psb_ipk_), allocatable :: bndx(:),bndy(:),bndz(:) + ! Process grid + integer(psb_ipk_) :: np, iam + integer(psb_ipk_) :: icoeff + integer(psb_lpk_), allocatable :: myidx(:) + ! deltah dimension of each grid cell + ! deltat discretization time + real(psb_dpk_) :: deltah, sqdeltah, deltah2 + real(psb_dpk_), parameter :: rhs=dzero,one=done,zero=dzero + real(psb_dpk_) :: t0, t1, t2, t3, tasb, talc, ttot, tgen, tcdasb + integer(psb_ipk_) :: err_act + procedure(d_func_3d), pointer :: f_ + character(len=20) :: name, ch_err,tmpfmt + + info = psb_success_ + name = 'create_matrix' + call psb_erractionsave(err_act) + + call psb_info(ctxt, iam, np) + + + if (present(f)) then + f_ => f + else + f_ => d_null_func_3d + end if + + deltah = done/(idim+1) + sqdeltah = deltah*deltah + deltah2 = (2*done)* deltah + + if (present(partition)) then + if ((1<= partition).and.(partition <= 3)) then + partition_ = partition + else + write(*,*) 'Invalid partition choice ',partition,' defaulting to 3' + partition_ = 3 + end if + else + partition_ = 3 + end if + + ! initialize array descriptor and sparse matrix storage. provide an + ! estimate of the number of non zeroes + + m = (1_psb_lpk_*idim)*idim*idim + n = m + nnz = ((n*7)/(np)) + if(iam == psb_root_) write(psb_out_unit,'("Generating Matrix (size=",i0,")...")')n + t0 = psb_wtime() + select case(partition_) + case(1) + ! A BLOCK partition + if (present(nrl)) then + nr = nrl + else + ! + ! Using a simple BLOCK distribution. + ! + nt = (m+np-1)/np + nr = max(0,min(nt,m-(iam*nt))) + end if + + nt = nr + call psb_sum(ctxt,nt) + if (nt /= m) then + write(psb_err_unit,*) iam, 'Initialization error ',nr,nt,m + info = -1 + call psb_barrier(ctxt) + call psb_abort(ctxt) + return + end if + + ! + ! First example of use of CDALL: specify for each process a number of + ! contiguous rows + ! + call psb_cdall(ctxt,desc_a,info,nl=nr) + myidx = desc_a%get_global_indices() + nlr = size(myidx) + + case(2) + ! A partition defined by the user through IV + + if (present(iv)) then + if (size(iv) /= m) then + write(psb_err_unit,*) iam, 'Initialization error: wrong IV size',size(iv),m + info = -1 + call psb_barrier(ctxt) + call psb_abort(ctxt) + return + end if + else + write(psb_err_unit,*) iam, 'Initialization error: IV not present' + info = -1 + call psb_barrier(ctxt) + call psb_abort(ctxt) + return + end if + + ! + ! Second example of use of CDALL: specify for each row the + ! process that owns it + ! + call psb_cdall(ctxt,desc_a,info,vg=iv) + myidx = desc_a%get_global_indices() + nlr = size(myidx) + + case(3) + ! A 3-dimensional partition + + ! A nifty MPI function will split the process list + npdims = 0 +#if defined(SERIAL_MPI) + npdims = 1 +#else + call mpi_dims_create(np,3,npdims,info) +#endif + npx = npdims(1) + npy = npdims(2) + npz = npdims(3) + + allocate(bndx(0:npx),bndy(0:npy),bndz(0:npz)) + ! We can reuse idx2ijk for process indices as well. + call idx2ijk(iamx,iamy,iamz,iam,npx,npy,npz,base=0) + ! Now let's split the 3D cube in hexahedra + call dist1Didx(bndx,idim,npx) + mynx = bndx(iamx+1)-bndx(iamx) + call dist1Didx(bndy,idim,npy) + myny = bndy(iamy+1)-bndy(iamy) + call dist1Didx(bndz,idim,npz) + mynz = bndz(iamz+1)-bndz(iamz) + + ! How many indices do I own? + nlr = mynx*myny*mynz + allocate(myidx(nlr)) + ! Now, let's generate the list of indices I own + nr = 0 + do i=bndx(iamx),bndx(iamx+1)-1 + do j=bndy(iamy),bndy(iamy+1)-1 + do k=bndz(iamz),bndz(iamz+1)-1 + nr = nr + 1 + call ijk2idx(myidx(nr),i,j,k,idim,idim,idim) + end do + end do + end do + if (nr /= nlr) then + write(psb_err_unit,*) iam,iamx,iamy,iamz, 'Initialization error: NR vs NLR ',& + & nr,nlr,mynx,myny,mynz + info = -1 + call psb_barrier(ctxt) + call psb_abort(ctxt) + end if + + ! + ! Third example of use of CDALL: specify for each process + ! the set of global indices it owns. + ! + call psb_cdall(ctxt,desc_a,info,vl=myidx) + + + ! + ! Specify process topology + ! + block + ! + ! Use adjcncy methods + ! + integer(psb_mpk_), allocatable :: neighbours(:) + integer(psb_mpk_) :: cnt + logical, parameter :: debug_adj=.true. + if (debug_adj.and.(np > 1)) then + cnt = 0 + allocate(neighbours(np)) + if (iamx < npx-1) then + cnt = cnt + 1 + call ijk2idx(neighbours(cnt),iamx+1,iamy,iamz,npx,npy,npz,base=0) + end if + if (iamy < npy-1) then + cnt = cnt + 1 + call ijk2idx(neighbours(cnt),iamx,iamy+1,iamz,npx,npy,npz,base=0) + end if + if (iamz < npz-1) then + cnt = cnt + 1 + call ijk2idx(neighbours(cnt),iamx,iamy,iamz+1,npx,npy,npz,base=0) + end if + if (iamx >0) then + cnt = cnt + 1 + call ijk2idx(neighbours(cnt),iamx-1,iamy,iamz,npx,npy,npz,base=0) + end if + if (iamy >0) then + cnt = cnt + 1 + call ijk2idx(neighbours(cnt),iamx,iamy-1,iamz,npx,npy,npz,base=0) + end if + if (iamz >0) then + cnt = cnt + 1 + call ijk2idx(neighbours(cnt),iamx,iamy,iamz-1,npx,npy,npz,base=0) + end if + call psb_realloc(cnt, neighbours,info) + call desc_a%set_p_adjcncy(neighbours) + !write(0,*) iam,' Check on neighbours: ',desc_a%get_p_adjcncy() + end if + end block + + case default + write(psb_err_unit,*) iam, 'Initialization error: should not get here' + info = -1 + call psb_barrier(ctxt) + call psb_abort(ctxt) + return + end select + + + if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz, & + & bldmode=psb_matbld_remote_,dupl=psb_dupl_add_) + ! define rhs from boundary conditions; also build initial guess + if (info == psb_success_) call psb_geall(xv,desc_a,info) + if (info == psb_success_) call psb_geall(bv,desc_a,info,& + & bldmode=psb_matbld_remote_,dupl=psb_dupl_add_) + + call psb_barrier(ctxt) + talc = psb_wtime()-t0 + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='allocation rout.' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ctxt) + t1 = psb_wtime() + !$omp parallel shared(deltah,myidx,a,desc_a) + ! + block + integer(psb_ipk_) :: i,j,ii,ib,icoeff, ix,iy,iz, ith,nth + integer(psb_lpk_) :: glob_row + integer(psb_lpk_), allocatable :: irow(:),icol(:) + real(psb_dpk_), allocatable :: val(:) + real(psb_dpk_) :: x,y,z, zt(nb) +#if defined(OPENMP) + nth = omp_get_num_threads() + ith = omp_get_thread_num() +#else + nth = 1 + ith = 0 +#endif + allocate(val(20*nb),irow(20*nb),& + &icol(20*nb),stat=info) + if (info /= psb_success_ ) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + !goto 9999 + endif + + + ! loop over rows belonging to current process in a block + ! distribution. + + !$omp do schedule(dynamic,4) + ! + do ii=1, nlr, nb + if (info /= 0) cycle + ib = min(nb,nlr-ii+1) + !ib = min(nb,mysz-ii+1) + icoeff = 1 + do k=1,ib + i=ii+k-1 + ! local matrix pointer + glob_row=myidx(i) + ! compute gridpoint coordinates + call idx2ijk(ix,iy,iz,glob_row,idim,idim,idim) + ! x, y, z coordinates + x = (ix-1)*deltah + y = (iy-1)*deltah + z = (iz-1)*deltah + zt(k) = f_(x,y,z) + ! internal point: build discretization + ! + ! term depending on (x-1,y,z) + ! + val(icoeff) = -a1(x,y,z)/sqdeltah-b1(x,y,z)/deltah2 + if (ix == 1) then + zt(k) = g(dzero,y,z)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix-1,iy,iz,idim,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + ! term depending on (x,y-1,z) + val(icoeff) = -a2(x,y,z)/sqdeltah-b2(x,y,z)/deltah2 + if (iy == 1) then + zt(k) = g(x,dzero,z)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix,iy-1,iz,idim,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + ! term depending on (x,y,z-1) + val(icoeff)=-a3(x,y,z)/sqdeltah-b3(x,y,z)/deltah2 + if (iz == 1) then + zt(k) = g(x,y,dzero)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix,iy,iz-1,idim,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + + ! term depending on (x,y,z) + val(icoeff)=(2*done)*(a1(x,y,z)+a2(x,y,z)+a3(x,y,z))/sqdeltah & + & + c(x,y,z) + call ijk2idx(icol(icoeff),ix,iy,iz,idim,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + ! term depending on (x,y,z+1) + val(icoeff)=-a3(x,y,z)/sqdeltah+b3(x,y,z)/deltah2 + if (iz == idim) then + zt(k) = g(x,y,done)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix,iy,iz+1,idim,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + ! term depending on (x,y+1,z) + val(icoeff)=-a2(x,y,z)/sqdeltah+b2(x,y,z)/deltah2 + if (iy == idim) then + zt(k) = g(x,done,z)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix,iy+1,iz,idim,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + ! term depending on (x+1,y,z) + val(icoeff)=-a1(x,y,z)/sqdeltah+b1(x,y,z)/deltah2 + if (ix==idim) then + zt(k) = g(done,y,z)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix+1,iy,iz,idim,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + + end do +#if defined(OPENMP) +!!$ write(0,*) omp_get_thread_num(),' Check insertion ',& +!!$ & irow(1:icoeff-1),':',icol(1:icoeff-1) +#endif + call psb_spins(icoeff-1,irow,icol,val,a,desc_a,info) + if(info /= psb_success_) cycle + call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),bv,desc_a,info) + if(info /= psb_success_) cycle + zt(:)=dzero + call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),xv,desc_a,info) + if(info /= psb_success_) cycle + end do + !$omp end do + deallocate(val,irow,icol) + end block + !$omp end parallel + + tgen = psb_wtime()-t1 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='insert rout.' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + call psb_barrier(ctxt) + t1 = psb_wtime() + call psb_cdasb(desc_a,info,mold=imold) + tcdasb = psb_wtime()-t1 + + call psb_barrier(ctxt) + t1 = psb_wtime() + if (info == psb_success_) then + if (present(amold)) then + call psb_spasb(a,desc_a,info,mold=amold) + else + call psb_spasb(a,desc_a,info,afmt=afmt) + end if + end if + call psb_barrier(ctxt) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='asb rout.' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (info == psb_success_) call psb_geasb(xv,desc_a,info,mold=vmold) + if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='asb rout.' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + tasb = psb_wtime()-t1 + call psb_barrier(ctxt) + ttot = psb_wtime() - t0 + + call psb_amx(ctxt,talc) + call psb_amx(ctxt,tgen) + call psb_amx(ctxt,tasb) + call psb_amx(ctxt,ttot) + if(iam == psb_root_) then + tmpfmt = a%get_fmt() + write(psb_out_unit,'("The matrix has been generated and assembled in ",a3," format.")')& + & tmpfmt + write(psb_out_unit,'("-allocation time : ",es12.5)') talc + write(psb_out_unit,'("-coeff. gen. time : ",es12.5)') tgen + write(psb_out_unit,'("-desc asbly time : ",es12.5)') tcdasb + write(psb_out_unit,'("- mat asbly time : ",es12.5)') tasb + write(psb_out_unit,'("-total time : ",es12.5)') ttot + + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psb_d_gen_pde3d + function outside(i,j,k,bndx,bndy,bndz,iamx,iamy,iamz) result(res) + logical :: res + integer(psb_ipk_), intent(in) :: i,j,k,iamx,iamy,iamz + integer(psb_ipk_), intent(in) :: bndx(0:),bndy(0:),bndz(0:) + + res = (i=bndx(iamx+1)) & + & .or.(j=bndy(iamy+1)) & + & .or.(k=bndz(iamz+1)) + end function outside +end module psb_d_pde3d_mod + +program psb_d_pde3d + use psb_base_mod + use psb_prec_mod + use psb_krylov_mod + use psb_util_mod + use psb_d_pde3d_mod +#if defined(OPENMP) + use omp_lib +#endif + implicit none + + ! input parameters + character(len=20) :: kmethd, ptype + character(len=5) :: afmt + integer(psb_ipk_) :: idim + integer(psb_epk_) :: system_size + + ! miscellaneous + real(psb_dpk_), parameter :: one = done + real(psb_dpk_) :: t1, t2, tprec + + ! sparse matrix and preconditioner + type(psb_dspmat_type) :: a + type(psb_dprec_type) :: prec + ! descriptor + type(psb_desc_type) :: desc_a + ! dense vectors + type(psb_d_vect_type) :: xxv,bv + ! parallel environment + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np, nth + + ! solver parameters + integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst, ipart + integer(psb_epk_) :: amatsize, precsize, descsize, d2size + real(psb_dpk_) :: err, eps + + ! Parameters for solvers in Block-Jacobi preconditioner + type ainvparms + character(len=12) :: alg, orth_alg, ilu_alg, ilut_scale + integer(psb_ipk_) :: fill, inv_fill + real(psb_dpk_) :: thresh, inv_thresh + end type ainvparms + type(ainvparms) :: parms + + ! other variables + integer(psb_ipk_) :: info, i + character(len=20) :: name,ch_err + character(len=40) :: fname + + info=psb_success_ + + + call psb_init(ctxt) + call psb_info(ctxt,iam,np) +#if defined(OPENMP) + !$OMP parallel shared(nth) + !$OMP master + nth = omp_get_num_threads() + !$OMP end master + !$OMP end parallel +#else + nth = 1 +#endif + + if (iam < 0) then + ! This should not happen, but just in case + call psb_exit(ctxt) + stop + endif + if(psb_errstatus_fatal()) goto 9999 + name='pde3d90' + call psb_set_errverbosity(itwo) + call psb_cd_set_large_threshold(125000_psb_ipk_) + ! + ! Hello world + ! + if (iam == psb_root_) then + write(*,*) 'Welcome to PSBLAS version: ',psb_version_string_ + write(*,*) 'This is the ',trim(name),' sample program' + end if +#if 0 + block + integer(psb_ipk_), parameter :: ntv=10 + integer(psb_ipk_) :: itv(ntv+1),i + itv(:) = 0 + do i=1,ntv + itv(i) = 2 + mod(i,2) + end do + write(0,*) 'ITV before : ',itv(:) + call psi_exscan(ntv,itv,info) + write(0,*) 'ITV after : ',itv(:) + itv(:) = 0 + do i=1,ntv + itv(i) = 2 + mod(i,2) + end do + write(0,*) 'ITV before 1: ',itv(:) + call psi_exscan(ntv,itv,info,shift=ione) + write(0,*) 'ITV after 1: ',itv(:) + ! call a%print('a.mtx',head='Test') + end block +!!$ +!!$ call psb_exit(ctxt) +!!$ stop +#endif + ! + ! get parameters + ! + call get_parms(ctxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart,parms) + ! + ! allocate and fill in the coefficient matrix, rhs and initial guess + ! + call psb_barrier(ctxt) + t1 = psb_wtime() + call psb_gen_pde3d(ctxt,idim,a,bv,xxv,desc_a,afmt,info,partition=ipart) + call psb_barrier(ctxt) + t2 = psb_wtime() - t1 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_gen_pde3d' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (iam == psb_root_) write(psb_out_unit,'("Overall matrix creation time : ",es12.5)')t2 + if (iam == psb_root_) write(psb_out_unit,'(" ")') + call a%print('a.mtx',head='Test') + ! + ! prepare the preconditioner. + ! + if(iam == psb_root_) write(psb_out_unit,'("Setting preconditioner to : ",a)')ptype + call prec%init(ctxt,ptype,info) + ! + ! Set the options for the BJAC preconditioner + ! + if (psb_toupper(ptype) == "BJAC") then + call prec%set('sub_solve', parms%alg, info) + select case (psb_toupper(parms%alg)) + case ("ILU") + call prec%set('sub_fillin', parms%fill, info) + call prec%set('ilu_alg', parms%ilu_alg, info) + case ("ILUT") + call prec%set('sub_fillin', parms%fill, info) + call prec%set('sub_iluthrs', parms%thresh, info) + call prec%set('ilut_scale', parms%ilut_scale, info) + case ("AINV") + call prec%set('inv_thresh', parms%inv_thresh, info) + call prec%set('inv_fillin', parms%inv_fill, info) + call prec%set('ilut_scale', parms%ilut_scale, info) + call prec%set('ainv_alg', parms%orth_alg, info) + case ("INVK") + call prec%set('sub_fillin', parms%fill, info) + call prec%set('inv_fillin', parms%inv_fill, info) + call prec%set('ilut_scale', parms%ilut_scale, info) + case ("INVT") + call prec%set('sub_fillin', parms%fill, info) + call prec%set('inv_fillin', parms%inv_fill, info) + call prec%set('sub_iluthrs', parms%thresh, info) + call prec%set('inv_thresh', parms%inv_thresh, info) + call prec%set('ilut_scale', parms%ilut_scale, info) + case default + ! Do nothing, use default setting in the init routine + end select + else + ! nothing to set for NONE or DIAG preconditioner + end if + + call psb_barrier(ctxt) + t1 = psb_wtime() + call prec%build(a,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_precbld' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + tprec = psb_wtime()-t1 + + call psb_amx(ctxt,tprec) + + if (iam == psb_root_) write(psb_out_unit,'("Preconditioner time : ",es12.5)')tprec + if (iam == psb_root_) write(psb_out_unit,'(" ")') + call prec%descr(info) + ! + ! iterative method parameters + ! + if(iam == psb_root_) write(psb_out_unit,'("Calling iterative method ",a)')kmethd + call psb_barrier(ctxt) + t1 = psb_wtime() + eps = 1.d-6 + call psb_krylov(kmethd,a,prec,bv,xxv,eps,desc_a,info,& + & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='solver routine' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ctxt) + t2 = psb_wtime() - t1 + call psb_amx(ctxt,t2) + amatsize = a%sizeof() + descsize = desc_a%sizeof() + precsize = prec%sizeof() + system_size = desc_a%get_global_rows() + call psb_sum(ctxt,amatsize) + call psb_sum(ctxt,descsize) + call psb_sum(ctxt,precsize) + + if (iam == psb_root_) then + write(psb_out_unit,'(" ")') + write(psb_out_unit,'("Number of processes : ",i12)')np + write(psb_out_unit,'("Number of threads : ",i12)')nth + write(psb_out_unit,'("Linear system size : ",i12)') system_size + write(psb_out_unit,'("Time to solve system : ",es12.5)')t2 + write(psb_out_unit,'("Time per iteration : ",es12.5)')t2/iter + write(psb_out_unit,'("Number of iterations : ",i12)')iter + write(psb_out_unit,'("Convergence indicator on exit : ",es12.5)')err + write(psb_out_unit,'("Info on exit : ",i12)')info + write(psb_out_unit,'("Total memory occupation for A: ",i12)')amatsize + write(psb_out_unit,'("Total memory occupation for PREC: ",i12)')precsize + write(psb_out_unit,'("Total memory occupation for DESC_A: ",i12)')descsize + write(psb_out_unit,'("Storage format for A: ",a)') a%get_fmt() + write(psb_out_unit,'("Storage format for DESC_A: ",a)') desc_a%get_fmt() + end if + + ! + ! cleanup storage and exit + ! + call psb_gefree(bv,desc_a,info) + call psb_gefree(xxv,desc_a,info) + call psb_spfree(a,desc_a,info) + call prec%free(info) + call psb_cdfree(desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='free routine' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_exit(ctxt) + stop + +9999 call psb_error(ctxt) + + stop + +contains + ! + ! get iteration parameters from standard input + ! + subroutine get_parms(ctxt,kmethd,ptype,afmt,idim,istopc,& + & itmax,itrace,irst,ipart,parms) + type(psb_ctxt_type) :: ctxt + character(len=*) :: kmethd, ptype, afmt + integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst,ipart + integer(psb_ipk_) :: np, iam + integer(psb_ipk_) :: ip, inp_unit + character(len=1024) :: filename + type(ainvparms) :: parms + + call psb_info(ctxt, iam, np) + + if (iam == 0) then + if (command_argument_count()>0) then + call get_command_argument(1,filename) + inp_unit = 30 + open(inp_unit,file=filename,action='read',iostat=info) + if (info /= 0) then + write(psb_err_unit,*) 'Could not open file ',filename,' for input' + call psb_abort(ctxt) + stop + else + write(psb_err_unit,*) 'Opened file ',trim(filename),' for input' + end if + else + inp_unit=psb_inp_unit + end if + read(inp_unit,*) ip + if (ip >= 3) then + read(inp_unit,*) kmethd + read(inp_unit,*) ptype + read(inp_unit,*) afmt + + read(inp_unit,*) idim + if (ip >= 4) then + read(inp_unit,*) ipart + else + ipart = 3 + endif + if (ip >= 5) then + read(inp_unit,*) istopc + else + istopc=1 + endif + if (ip >= 6) then + read(inp_unit,*) itmax + else + itmax=500 + endif + if (ip >= 7) then + read(inp_unit,*) itrace + else + itrace=-1 + endif + if (ip >= 8) then + read(inp_unit,*) irst + else + irst=1 + endif + if (ip >= 9) then + read(inp_unit,*) parms%alg + read(inp_unit,*) parms%ilu_alg + read(inp_unit,*) parms%ilut_scale + read(inp_unit,*) parms%fill + read(inp_unit,*) parms%inv_fill + read(inp_unit,*) parms%thresh + read(inp_unit,*) parms%inv_thresh + read(inp_unit,*) parms%orth_alg + else + parms%alg = 'ILU' ! Block Solver ILU,ILUT,INVK,AINVT,AORTH + parms%ilu_alg = 'NONE' ! If ILU : MILU or NONE othewise ignored + parms%ilut_scale = 'NONE' ! If ILUT: NONE, MAXVAL, DIAG, ARWSUM, ACLSUM, ARCSUM + parms%fill = 0 ! Level of fill for forward factorization + parms%inv_fill = 1 ! Level of fill for inverse factorization (only INVK) + parms%thresh = 1E-1_psb_dpk_ ! Threshold for forward factorization + parms%inv_thresh = 1E-1_psb_dpk_ ! Threshold for inverse factorization + parms%orth_alg = 'LLK' ! What orthogonalization algorithm? + endif + + write(psb_out_unit,'("Solving matrix : ell1")') + write(psb_out_unit,& + & '("Grid dimensions : ",i4," x ",i4," x ",i4)') & + & idim,idim,idim + write(psb_out_unit,'("Number of processors : ",i0)')np + select case(ipart) + case(1) + write(psb_out_unit,'("Data distribution : BLOCK")') + case(3) + write(psb_out_unit,'("Data distribution : 3D")') + case default + ipart = 3 + write(psb_out_unit,'("Unknown data distrbution, defaulting to 3D")') + end select + write(psb_out_unit,'("Preconditioner : ",a)') ptype + if( psb_toupper(ptype) == "BJAC" ) then + write(psb_out_unit,'("Block subsolver : ",a)') parms%alg + select case (psb_toupper(parms%alg)) + case ('ILU') + write(psb_out_unit,'("Fill in : ",i0)') parms%fill + write(psb_out_unit,'("MILU : ",a)') parms%ilu_alg + case ('ILUT') + write(psb_out_unit,'("Fill in : ",i0)') parms%fill + write(psb_out_unit,'("Threshold : ",es12.5)') parms%thresh + write(psb_out_unit,'("Scaling : ",a)') parms%ilut_scale + case ('INVK') + write(psb_out_unit,'("Fill in : ",i0)') parms%fill + write(psb_out_unit,'("Invese Fill in : ",i0)') parms%inv_fill + write(psb_out_unit,'("Scaling : ",a)') parms%ilut_scale + case ('INVT') + write(psb_out_unit,'("Fill in : ",i0)') parms%fill + write(psb_out_unit,'("Threshold : ",es12.5)') parms%thresh + write(psb_out_unit,'("Invese Fill in : ",i0)') parms%inv_fill + write(psb_out_unit,'("Inverse Threshold : ",es12.5)') parms%inv_thresh + write(psb_out_unit,'("Scaling : ",a)') parms%ilut_scale + case ('AINV','AORTH') + write(psb_out_unit,'("Inverse Threshold : ",es12.5)') parms%inv_thresh + write(psb_out_unit,'("Invese Fill in : ",i0)') parms%inv_fill + write(psb_out_unit,'("Orthogonalization : ",a)') parms%orth_alg + write(psb_out_unit,'("Scaling : ",a)') parms%ilut_scale + case default + write(psb_out_unit,'("Unknown diagonal solver")') + end select + end if + write(psb_out_unit,'("Iterative method : ",a)') kmethd + write(psb_out_unit,'(" ")') + else + ! wrong number of parameter, print an error message and exit + call pr_usage(izero) + call psb_abort(ctxt) + stop 1 + endif + if (inp_unit /= psb_inp_unit) then + close(inp_unit) + end if + + end if + ! broadcast parameters to all processors + call psb_bcast(ctxt,kmethd) + call psb_bcast(ctxt,afmt) + call psb_bcast(ctxt,ptype) + call psb_bcast(ctxt,idim) + call psb_bcast(ctxt,ipart) + call psb_bcast(ctxt,istopc) + call psb_bcast(ctxt,itmax) + call psb_bcast(ctxt,itrace) + call psb_bcast(ctxt,irst) + call psb_bcast(ctxt,parms%alg) + call psb_bcast(ctxt,parms%fill) + call psb_bcast(ctxt,parms%inv_fill) + call psb_bcast(ctxt,parms%thresh) + call psb_bcast(ctxt,parms%inv_thresh) + call psb_bcast(ctxt,parms%orth_alg) + call psb_bcast(ctxt,parms%ilut_scale) + + return + + end subroutine get_parms + ! + ! print an error message + ! + subroutine pr_usage(iout) + integer(psb_ipk_) :: iout + write(iout,*)'incorrect parameter(s) found' + write(iout,*)' usage: pde3d90 methd prec dim & + &[istop itmax itrace]' + write(iout,*)' where:' + write(iout,*)' methd: cgstab cgs rgmres bicgstabl' + write(iout,*)' prec : bjac diag none' + write(iout,*)' dim number of points along each axis' + write(iout,*)' the size of the resulting linear ' + write(iout,*)' system is dim**3' + write(iout,*)' ipart data partition 1 3 ' + write(iout,*)' istop stopping criterion 1, 2 ' + write(iout,*)' itmax maximum number of iterations [500] ' + write(iout,*)' itrace <=0 (no tracing, default) or ' + write(iout,*)' >= 1 do tracing every itrace' + write(iout,*)' iterations ' + end subroutine pr_usage + +end program psb_d_pde3d diff --git a/test/pargen/psb_d_pde2d.F90 b/test/pargen/psb_d_pde2d.F90 index 6da978283..11777b194 100644 --- a/test/pargen/psb_d_pde2d.F90 +++ b/test/pargen/psb_d_pde2d.F90 @@ -156,6 +156,9 @@ contains & f,amold,vmold,imold,partition,nrl,iv) use psb_base_mod use psb_util_mod +#if defined(OPENMP) + use omp_lib +#endif ! ! Discretizes the partial differential equation ! @@ -192,7 +195,7 @@ contains type(psb_d_coo_sparse_mat) :: acoo type(psb_d_csr_sparse_mat) :: acsr real(psb_dpk_) :: zt(nb),x,y,z - integer(psb_ipk_) :: nnz,nr,nlr,i,j,ii,ib,k, partition_ + integer(psb_ipk_) :: nnz,nr,nlr,i,j,ii,ib,k, partition_, mysz integer(psb_lpk_) :: m,n,glob_row,nt integer(psb_ipk_) :: ix,iy,iz,ia,indx_owner ! For 2D partition @@ -204,8 +207,7 @@ contains ! Process grid integer(psb_ipk_) :: np, iam integer(psb_ipk_) :: icoeff - integer(psb_lpk_), allocatable :: irow(:),icol(:),myidx(:) - real(psb_dpk_), allocatable :: val(:) + integer(psb_lpk_), allocatable :: myidx(:) ! deltah dimension of each grid cell ! deltat discretization time real(psb_dpk_) :: deltah, sqdeltah, deltah2 @@ -391,7 +393,6 @@ contains end if end block - case default write(psb_err_unit,*) iam, 'Initialization error: should not get here' info = -1 @@ -418,94 +419,114 @@ contains goto 9999 end if - ! we build an auxiliary matrix consisting of one row at a - ! time; just a small matrix. might be extended to generate - ! a bunch of rows per call. - ! - allocate(val(20*nb),irow(20*nb),& - &icol(20*nb),stat=info) - if (info /= psb_success_ ) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - - ! loop over rows belonging to current process in a block - ! distribution. call psb_barrier(ctxt) t1 = psb_wtime() - do ii=1, nlr,nb - ib = min(nb,nlr-ii+1) - icoeff = 1 - do k=1,ib - i=ii+k-1 - ! local matrix pointer - glob_row=myidx(i) - ! compute gridpoint coordinates - call idx2ijk(ix,iy,glob_row,idim,idim) - ! x, y coordinates - x = (ix-1)*deltah - y = (iy-1)*deltah - - zt(k) = f_(x,y) - ! internal point: build discretization - ! - ! term depending on (x-1,y) - ! - val(icoeff) = -a1(x,y)/sqdeltah-b1(x,y)/deltah2 - if (ix == 1) then - zt(k) = g(dzero,y)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix-1,iy,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - ! term depending on (x,y-1) - val(icoeff) = -a2(x,y)/sqdeltah-b2(x,y)/deltah2 - if (iy == 1) then - zt(k) = g(x,dzero)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix,iy-1,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - - ! term depending on (x,y) - val(icoeff)=(2*done)*(a1(x,y) + a2(x,y))/sqdeltah + c(x,y) - call ijk2idx(icol(icoeff),ix,iy,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - ! term depending on (x,y+1) - val(icoeff)=-a2(x,y)/sqdeltah+b2(x,y)/deltah2 - if (iy == idim) then - zt(k) = g(x,done)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix,iy+1,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - ! term depending on (x+1,y) - val(icoeff)=-a1(x,y)/sqdeltah+b1(x,y)/deltah2 - if (ix==idim) then - zt(k) = g(done,y)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix+1,iy,idim,idim) + !$omp parallel shared(deltah,myidx,a,desc_a) + ! + block + integer(psb_ipk_) :: i,j,k,ii,ib,icoeff, ix,iy, ith,nth + integer(psb_lpk_) :: glob_row + integer(psb_lpk_), allocatable :: irow(:),icol(:) + real(psb_dpk_), allocatable :: val(:) + real(psb_dpk_) :: x,y, zt(nb) +#if defined(OPENMP) + nth = omp_get_num_threads() + ith = omp_get_thread_num() +#else + nth = 1 + ith = 0 +#endif + allocate(val(20*nb),irow(20*nb),& + &icol(20*nb),stat=info) + if (info /= psb_success_ ) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + !goto 9999 + endif + + !$omp do schedule(dynamic) + ! + do ii=1, nlr,nb + if(info /= psb_success_) cycle + ib = min(nb,nlr-ii+1) + icoeff = 1 + do k=1,ib + i=ii+k-1 + ! local matrix pointer + glob_row=myidx(i) + ! compute gridpoint coordinates + call idx2ijk(ix,iy,glob_row,idim,idim) + ! x, y coordinates + x = (ix-1)*deltah + y = (iy-1)*deltah + + zt(k) = f_(x,y) + ! internal point: build discretization + ! + ! term depending on (x-1,y) + ! + val(icoeff) = -a1(x,y)/sqdeltah-b1(x,y)/deltah2 + if (ix == 1) then + zt(k) = g(dzero,y)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix-1,iy,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + ! term depending on (x,y-1) + val(icoeff) = -a2(x,y)/sqdeltah-b2(x,y)/deltah2 + if (iy == 1) then + zt(k) = g(x,dzero)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix,iy-1,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + + ! term depending on (x,y) + val(icoeff)=(2*done)*(a1(x,y) + a2(x,y))/sqdeltah + c(x,y) + call ijk2idx(icol(icoeff),ix,iy,idim,idim) irow(icoeff) = glob_row icoeff = icoeff+1 - endif - + ! term depending on (x,y+1) + val(icoeff)=-a2(x,y)/sqdeltah+b2(x,y)/deltah2 + if (iy == idim) then + zt(k) = g(x,done)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix,iy+1,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + ! term depending on (x+1,y) + val(icoeff)=-a1(x,y)/sqdeltah+b1(x,y)/deltah2 + if (ix==idim) then + zt(k) = g(done,y)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix+1,iy,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + + end do +#if defined(OPENMP) +!!$ write(0,*) omp_get_thread_num(),' Check insertion ',& +!!$ & irow(1:icoeff-1),':',icol(1:icoeff-1) +#endif + call psb_spins(icoeff-1,irow,icol,val,a,desc_a,info) + if(info /= psb_success_) cycle + call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),bv,desc_a,info) + if(info /= psb_success_) cycle + zt(:)=dzero + call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),xv,desc_a,info) + if(info /= psb_success_) cycle end do - call psb_spins(icoeff-1,irow,icol,val,a,desc_a,info) - if(info /= psb_success_) exit - call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),bv,desc_a,info) - if(info /= psb_success_) exit - zt(:)=dzero - call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),xv,desc_a,info) - if(info /= psb_success_) exit - end do - + !$omp end do + deallocate(val,irow,icol) + end block + !$omp end parallel + + tgen = psb_wtime()-t1 if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -514,8 +535,6 @@ contains goto 9999 end if - deallocate(val,irow,icol) - call psb_barrier(ctxt) t1 = psb_wtime() call psb_cdasb(desc_a,info,mold=imold) @@ -579,6 +598,9 @@ program psb_d_pde2d use psb_krylov_mod use psb_util_mod use psb_d_pde2d_mod +#if defined(OPENMP) + use omp_lib +#endif implicit none ! input parameters @@ -600,7 +622,7 @@ program psb_d_pde2d type(psb_d_vect_type) :: xxv,bv ! parallel environment type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: iam, np + integer(psb_ipk_) :: iam, np, nth ! solver parameters integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst, ipart @@ -625,7 +647,16 @@ program psb_d_pde2d call psb_init(ctxt) call psb_info(ctxt,iam,np) - +#if defined(OPENMP) + !$OMP parallel shared(nth) + !$OMP master + nth = omp_get_num_threads() + !$OMP end master + !$OMP end parallel +#else + nth = 1 +#endif + if (iam < 0) then ! This should not happen, but just in case call psb_exit(ctxt) @@ -750,6 +781,8 @@ program psb_d_pde2d if (iam == psb_root_) then write(psb_out_unit,'(" ")') write(psb_out_unit,'("Number of processes : ",i12)')np + write(psb_out_unit,'("Number of threads : ",i12)')nth + write(psb_out_unit,'("Total number of tasks : ",i12)')nth*np write(psb_out_unit,'("Linear system size : ",i12)') system_size write(psb_out_unit,'("Time to solve system : ",es12.5)')t2 write(psb_out_unit,'("Time per iteration : ",es12.5)')t2/iter @@ -790,7 +823,8 @@ contains ! ! get iteration parameters from standard input ! - subroutine get_parms(ctxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart,parms) + subroutine get_parms(ctxt,kmethd,ptype,afmt,idim,istopc,& + & itmax,itrace,irst,ipart,parms) type(psb_ctxt_type) :: ctxt character(len=*) :: kmethd, ptype, afmt integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst,ipart diff --git a/test/pargen/psb_d_pde3d.F90 b/test/pargen/psb_d_pde3d.F90 index e802736e3..62bb8b409 100644 --- a/test/pargen/psb_d_pde3d.F90 +++ b/test/pargen/psb_d_pde3d.F90 @@ -172,6 +172,9 @@ contains & f,amold,vmold,imold,partition,nrl,iv) use psb_base_mod use psb_util_mod +#if defined(OPENMP) + use omp_lib +#endif ! ! Discretizes the partial differential equation ! @@ -220,8 +223,7 @@ contains ! Process grid integer(psb_ipk_) :: np, iam integer(psb_ipk_) :: icoeff - integer(psb_lpk_), allocatable :: irow(:),icol(:),myidx(:) - real(psb_dpk_), allocatable :: val(:) + integer(psb_lpk_), allocatable :: myidx(:) ! deltah dimension of each grid cell ! deltat discretization time real(psb_dpk_) :: deltah, sqdeltah, deltah2 @@ -377,7 +379,6 @@ contains ! call psb_cdall(ctxt,desc_a,info,vl=myidx) - ! ! Specify process topology ! @@ -447,69 +448,79 @@ contains goto 9999 end if - ! we build an auxiliary matrix consisting of one row at a - ! time; just a small matrix. might be extended to generate - ! a bunch of rows per call. - ! - allocate(val(20*nb),irow(20*nb),& - &icol(20*nb),stat=info) - if (info /= psb_success_ ) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - - ! loop over rows belonging to current process in a block - ! distribution. - call psb_barrier(ctxt) t1 = psb_wtime() - do ii=1, nlr, nb - ib = min(nb,nlr-ii+1) - !ib = min(nb,mysz-ii+1) - icoeff = 1 - do k=1,ib - i=ii+k-1 - ! local matrix pointer - glob_row=myidx(i) - ! compute gridpoint coordinates - call idx2ijk(ix,iy,iz,glob_row,idim,idim,idim) - ! x, y, z coordinates - x = (ix-1)*deltah - y = (iy-1)*deltah - z = (iz-1)*deltah - zt(k) = f_(x,y,z) - ! internal point: build discretization - ! - ! term depending on (x-1,y,z) - ! - val(icoeff) = -a1(x,y,z)/sqdeltah-b1(x,y,z)/deltah2 - if (ix == 1) then - zt(k) = g(dzero,y,z)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix-1,iy,iz,idim,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - ! term depending on (x,y-1,z) - val(icoeff) = -a2(x,y,z)/sqdeltah-b2(x,y,z)/deltah2 - if (iy == 1) then - zt(k) = g(x,dzero,z)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix,iy-1,iz,idim,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - ! term depending on (x,y,z-1) - val(icoeff)=-a3(x,y,z)/sqdeltah-b3(x,y,z)/deltah2 - if (iz == 1) then - zt(k) = g(x,y,dzero)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix,iy,iz-1,idim,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif + !$omp parallel shared(deltah,myidx,a,desc_a) + ! + block + integer(psb_ipk_) :: i,j,k,ii,ib,icoeff, ix,iy,iz, ith,nth + integer(psb_lpk_) :: glob_row + integer(psb_lpk_), allocatable :: irow(:),icol(:) + real(psb_dpk_), allocatable :: val(:) + real(psb_dpk_) :: x,y,z, zt(nb) +#if defined(OPENMP) + nth = omp_get_num_threads() + ith = omp_get_thread_num() +#else + nth = 1 + ith = 0 +#endif + allocate(val(20*nb),irow(20*nb),& + &icol(20*nb),stat=info) + if (info /= psb_success_ ) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + !goto 9999 + endif + + !$omp do schedule(dynamic) + ! + do ii=1, nlr, nb + if(info /= psb_success_) cycle + ib = min(nb,nlr-ii+1) + !ib = min(nb,mysz-ii+1) + icoeff = 1 + do k=1,ib + i=ii+k-1 + ! local matrix pointer + glob_row=myidx(i) + ! compute gridpoint coordinates + call idx2ijk(ix,iy,iz,glob_row,idim,idim,idim) + ! x, y, z coordinates + x = (ix-1)*deltah + y = (iy-1)*deltah + z = (iz-1)*deltah + zt(k) = f_(x,y,z) + ! internal point: build discretization + ! + ! term depending on (x-1,y,z) + ! + val(icoeff) = -a1(x,y,z)/sqdeltah-b1(x,y,z)/deltah2 + if (ix == 1) then + zt(k) = g(dzero,y,z)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix-1,iy,iz,idim,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + ! term depending on (x,y-1,z) + val(icoeff) = -a2(x,y,z)/sqdeltah-b2(x,y,z)/deltah2 + if (iy == 1) then + zt(k) = g(x,dzero,z)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix,iy-1,iz,idim,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + ! term depending on (x,y,z-1) + val(icoeff)=-a3(x,y,z)/sqdeltah-b3(x,y,z)/deltah2 + if (iz == 1) then + zt(k) = g(x,y,dzero)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix,iy,iz-1,idim,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif ! term depending on (x,y,z) val(icoeff)=(2*done)*(a1(x,y,z)+a2(x,y,z)+a3(x,y,z))/sqdeltah & @@ -546,14 +557,22 @@ contains endif end do - call psb_spins(icoeff-1,irow,icol,val,a,desc_a,info) - if(info /= psb_success_) exit - call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),bv,desc_a,info) - if(info /= psb_success_) exit - zt(:)=dzero - call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),xv,desc_a,info) - if(info /= psb_success_) exit - end do +#if defined(OPENMP) +!!$ write(0,*) omp_get_thread_num(),' Check insertion ',& +!!$ & irow(1:icoeff-1),':',icol(1:icoeff-1) +#endif + call psb_spins(icoeff-1,irow,icol,val,a,desc_a,info) + if(info /= psb_success_) cycle + call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),bv,desc_a,info) + if(info /= psb_success_) cycle + zt(:)=dzero + call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),xv,desc_a,info) + if(info /= psb_success_) cycle + end do + !$omp end do + deallocate(val,irow,icol) + end block + !$omp end parallel tgen = psb_wtime()-t1 if(info /= psb_success_) then @@ -569,113 +588,6 @@ contains call psb_cdasb(desc_a,info,mold=imold) tcdasb = psb_wtime()-t1 - if (.false.) then - ! - ! Add extra rows to test remote build. - ! - block - integer(psb_ipk_) :: ks, i - ks = desc_a%get_local_cols()-desc_a%get_local_rows() - if (ks > 0) ks = max(1,ks / 10) - mysz = nlr+ks - call psb_realloc(mysz,myidx,info) - do i=nlr+1, mysz - myidx(i) = i - end do - call desc_a%l2gv1(myidx(nlr+1:mysz),info) - !write(0,*) iam,' Check on extra nodes ',nlr,mysz,':',myidx(nlr+1:mysz) - do ii= nlr+1, mysz, nb - ib = min(nb,mysz-ii+1) - icoeff = 1 - do k=1,ib - i=ii+k-1 - ! local matrix pointer - glob_row=myidx(i) - ! compute gridpoint coordinates - call idx2ijk(ix,iy,iz,glob_row,idim,idim,idim) - ! x, y, z coordinates - x = (ix-1)*deltah - y = (iy-1)*deltah - z = (iz-1)*deltah - zt(k) = f_(x,y,z) - ! internal point: build discretization - ! - ! term depending on (x-1,y,z) - ! - val(icoeff) = -a1(x,y,z)/sqdeltah-b1(x,y,z)/deltah2 - if (ix == 1) then - zt(k) = g(dzero,y,z)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix-1,iy,iz,idim,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - ! term depending on (x,y-1,z) - val(icoeff) = -a2(x,y,z)/sqdeltah-b2(x,y,z)/deltah2 - if (iy == 1) then - zt(k) = g(x,dzero,z)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix,iy-1,iz,idim,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - ! term depending on (x,y,z-1) - val(icoeff)=-a3(x,y,z)/sqdeltah-b3(x,y,z)/deltah2 - if (iz == 1) then - zt(k) = g(x,y,dzero)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix,iy,iz-1,idim,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - - ! term depending on (x,y,z) - val(icoeff)=(2*done)*(a1(x,y,z)+a2(x,y,z)+a3(x,y,z))/sqdeltah & - & + c(x,y,z) - call ijk2idx(icol(icoeff),ix,iy,iz,idim,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - ! term depending on (x,y,z+1) - val(icoeff)=-a3(x,y,z)/sqdeltah+b3(x,y,z)/deltah2 - if (iz == idim) then - zt(k) = g(x,y,done)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix,iy,iz+1,idim,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - ! term depending on (x,y+1,z) - val(icoeff)=-a2(x,y,z)/sqdeltah+b2(x,y,z)/deltah2 - if (iy == idim) then - zt(k) = g(x,done,z)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix,iy+1,iz,idim,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - ! term depending on (x+1,y,z) - val(icoeff)=-a1(x,y,z)/sqdeltah+b1(x,y,z)/deltah2 - if (ix==idim) then - zt(k) = g(done,y,z)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix+1,iy,iz,idim,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - - end do - call psb_spins(icoeff-1,irow,icol,val,a,desc_a,info) - if(info /= psb_success_) exit - call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),bv,desc_a,info) - if(info /= psb_success_) exit - zt(:)=dzero - call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),xv,desc_a,info) - if(info /= psb_success_) exit - end do - - end block - end if - call psb_barrier(ctxt) t1 = psb_wtime() if (info == psb_success_) then @@ -719,7 +631,7 @@ contains write(psb_out_unit,'("-total time : ",es12.5)') ttot end if - deallocate(val,irow,icol) + call psb_erractionrestore(err_act) return @@ -744,6 +656,9 @@ program psb_d_pde3d use psb_krylov_mod use psb_util_mod use psb_d_pde3d_mod +#if defined(OPENMP) + use omp_lib +#endif implicit none ! input parameters @@ -765,7 +680,7 @@ program psb_d_pde3d type(psb_d_vect_type) :: xxv,bv ! parallel environment type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: iam, np + integer(psb_ipk_) :: iam, np, nth ! solver parameters integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst, ipart @@ -790,7 +705,16 @@ program psb_d_pde3d call psb_init(ctxt) call psb_info(ctxt,iam,np) - +#if defined(OPENMP) + !$OMP parallel shared(nth) + !$OMP master + nth = omp_get_num_threads() + !$OMP end master + !$OMP end parallel +#else + nth = 1 +#endif + if (iam < 0) then ! This should not happen, but just in case call psb_exit(ctxt) @@ -914,6 +838,8 @@ program psb_d_pde3d if (iam == psb_root_) then write(psb_out_unit,'(" ")') write(psb_out_unit,'("Number of processes : ",i12)')np + write(psb_out_unit,'("Number of threads : ",i12)')nth + write(psb_out_unit,'("Total number of tasks : ",i12)')nth*np write(psb_out_unit,'("Linear system size : ",i12)') system_size write(psb_out_unit,'("Time to solve system : ",es12.5)')t2 write(psb_out_unit,'("Time per iteration : ",es12.5)')t2/iter diff --git a/test/pargen/psb_s_pde2d.F90 b/test/pargen/psb_s_pde2d.F90 index 664d5d080..f14d2cb49 100644 --- a/test/pargen/psb_s_pde2d.F90 +++ b/test/pargen/psb_s_pde2d.F90 @@ -156,6 +156,9 @@ contains & f,amold,vmold,imold,partition,nrl,iv) use psb_base_mod use psb_util_mod +#if defined(OPENMP) + use omp_lib +#endif ! ! Discretizes the partial differential equation ! @@ -192,7 +195,7 @@ contains type(psb_s_coo_sparse_mat) :: acoo type(psb_s_csr_sparse_mat) :: acsr real(psb_spk_) :: zt(nb),x,y,z - integer(psb_ipk_) :: nnz,nr,nlr,i,j,ii,ib,k, partition_ + integer(psb_ipk_) :: nnz,nr,nlr,i,j,ii,ib,k, partition_, mysz integer(psb_lpk_) :: m,n,glob_row,nt integer(psb_ipk_) :: ix,iy,iz,ia,indx_owner ! For 2D partition @@ -204,8 +207,7 @@ contains ! Process grid integer(psb_ipk_) :: np, iam integer(psb_ipk_) :: icoeff - integer(psb_lpk_), allocatable :: irow(:),icol(:),myidx(:) - real(psb_spk_), allocatable :: val(:) + integer(psb_lpk_), allocatable :: myidx(:) ! deltah dimension of each grid cell ! deltat discretization time real(psb_spk_) :: deltah, sqdeltah, deltah2 @@ -391,7 +393,6 @@ contains end if end block - case default write(psb_err_unit,*) iam, 'Initialization error: should not get here' info = -1 @@ -418,94 +419,114 @@ contains goto 9999 end if - ! we build an auxiliary matrix consisting of one row at a - ! time; just a small matrix. might be extended to generate - ! a bunch of rows per call. - ! - allocate(val(20*nb),irow(20*nb),& - &icol(20*nb),stat=info) - if (info /= psb_success_ ) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - - ! loop over rows belonging to current process in a block - ! distribution. call psb_barrier(ctxt) t1 = psb_wtime() - do ii=1, nlr,nb - ib = min(nb,nlr-ii+1) - icoeff = 1 - do k=1,ib - i=ii+k-1 - ! local matrix pointer - glob_row=myidx(i) - ! compute gridpoint coordinates - call idx2ijk(ix,iy,glob_row,idim,idim) - ! x, y coordinates - x = (ix-1)*deltah - y = (iy-1)*deltah - - zt(k) = f_(x,y) - ! internal point: build discretization - ! - ! term depending on (x-1,y) - ! - val(icoeff) = -a1(x,y)/sqdeltah-b1(x,y)/deltah2 - if (ix == 1) then - zt(k) = g(szero,y)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix-1,iy,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - ! term depending on (x,y-1) - val(icoeff) = -a2(x,y)/sqdeltah-b2(x,y)/deltah2 - if (iy == 1) then - zt(k) = g(x,szero)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix,iy-1,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - - ! term depending on (x,y) - val(icoeff)=(2*sone)*(a1(x,y) + a2(x,y))/sqdeltah + c(x,y) - call ijk2idx(icol(icoeff),ix,iy,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - ! term depending on (x,y+1) - val(icoeff)=-a2(x,y)/sqdeltah+b2(x,y)/deltah2 - if (iy == idim) then - zt(k) = g(x,sone)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix,iy+1,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - ! term depending on (x+1,y) - val(icoeff)=-a1(x,y)/sqdeltah+b1(x,y)/deltah2 - if (ix==idim) then - zt(k) = g(sone,y)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix+1,iy,idim,idim) + !$omp parallel shared(deltah,myidx,a,desc_a) + ! + block + integer(psb_ipk_) :: i,j,k,ii,ib,icoeff, ix,iy, ith,nth + integer(psb_lpk_) :: glob_row + integer(psb_lpk_), allocatable :: irow(:),icol(:) + real(psb_spk_), allocatable :: val(:) + real(psb_spk_) :: x,y, zt(nb) +#if defined(OPENMP) + nth = omp_get_num_threads() + ith = omp_get_thread_num() +#else + nth = 1 + ith = 0 +#endif + allocate(val(20*nb),irow(20*nb),& + &icol(20*nb),stat=info) + if (info /= psb_success_ ) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + !goto 9999 + endif + + !$omp do schedule(dynamic) + ! + do ii=1, nlr,nb + if(info /= psb_success_) cycle + ib = min(nb,nlr-ii+1) + icoeff = 1 + do k=1,ib + i=ii+k-1 + ! local matrix pointer + glob_row=myidx(i) + ! compute gridpoint coordinates + call idx2ijk(ix,iy,glob_row,idim,idim) + ! x, y coordinates + x = (ix-1)*deltah + y = (iy-1)*deltah + + zt(k) = f_(x,y) + ! internal point: build discretization + ! + ! term depending on (x-1,y) + ! + val(icoeff) = -a1(x,y)/sqdeltah-b1(x,y)/deltah2 + if (ix == 1) then + zt(k) = g(szero,y)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix-1,iy,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + ! term depending on (x,y-1) + val(icoeff) = -a2(x,y)/sqdeltah-b2(x,y)/deltah2 + if (iy == 1) then + zt(k) = g(x,szero)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix,iy-1,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + + ! term depending on (x,y) + val(icoeff)=(2*sone)*(a1(x,y) + a2(x,y))/sqdeltah + c(x,y) + call ijk2idx(icol(icoeff),ix,iy,idim,idim) irow(icoeff) = glob_row icoeff = icoeff+1 - endif - + ! term depending on (x,y+1) + val(icoeff)=-a2(x,y)/sqdeltah+b2(x,y)/deltah2 + if (iy == idim) then + zt(k) = g(x,sone)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix,iy+1,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + ! term depending on (x+1,y) + val(icoeff)=-a1(x,y)/sqdeltah+b1(x,y)/deltah2 + if (ix==idim) then + zt(k) = g(sone,y)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix+1,iy,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + + end do +#if defined(OPENMP) +!!$ write(0,*) omp_get_thread_num(),' Check insertion ',& +!!$ & irow(1:icoeff-1),':',icol(1:icoeff-1) +#endif + call psb_spins(icoeff-1,irow,icol,val,a,desc_a,info) + if(info /= psb_success_) cycle + call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),bv,desc_a,info) + if(info /= psb_success_) cycle + zt(:)=szero + call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),xv,desc_a,info) + if(info /= psb_success_) cycle end do - call psb_spins(icoeff-1,irow,icol,val,a,desc_a,info) - if(info /= psb_success_) exit - call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),bv,desc_a,info) - if(info /= psb_success_) exit - zt(:)=szero - call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),xv,desc_a,info) - if(info /= psb_success_) exit - end do - + !$omp end do + deallocate(val,irow,icol) + end block + !$omp end parallel + + tgen = psb_wtime()-t1 if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -514,8 +535,6 @@ contains goto 9999 end if - deallocate(val,irow,icol) - call psb_barrier(ctxt) t1 = psb_wtime() call psb_cdasb(desc_a,info,mold=imold) @@ -579,6 +598,9 @@ program psb_s_pde2d use psb_krylov_mod use psb_util_mod use psb_s_pde2d_mod +#if defined(OPENMP) + use omp_lib +#endif implicit none ! input parameters @@ -600,7 +622,7 @@ program psb_s_pde2d type(psb_s_vect_type) :: xxv,bv ! parallel environment type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: iam, np + integer(psb_ipk_) :: iam, np, nth ! solver parameters integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst, ipart @@ -625,7 +647,16 @@ program psb_s_pde2d call psb_init(ctxt) call psb_info(ctxt,iam,np) - +#if defined(OPENMP) + !$OMP parallel shared(nth) + !$OMP master + nth = omp_get_num_threads() + !$OMP end master + !$OMP end parallel +#else + nth = 1 +#endif + if (iam < 0) then ! This should not happen, but just in case call psb_exit(ctxt) @@ -750,6 +781,8 @@ program psb_s_pde2d if (iam == psb_root_) then write(psb_out_unit,'(" ")') write(psb_out_unit,'("Number of processes : ",i12)')np + write(psb_out_unit,'("Number of threads : ",i12)')nth + write(psb_out_unit,'("Total number of tasks : ",i12)')nth*np write(psb_out_unit,'("Linear system size : ",i12)') system_size write(psb_out_unit,'("Time to solve system : ",es12.5)')t2 write(psb_out_unit,'("Time per iteration : ",es12.5)')t2/iter @@ -790,7 +823,8 @@ contains ! ! get iteration parameters from standard input ! - subroutine get_parms(ctxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart,parms) + subroutine get_parms(ctxt,kmethd,ptype,afmt,idim,istopc,& + & itmax,itrace,irst,ipart,parms) type(psb_ctxt_type) :: ctxt character(len=*) :: kmethd, ptype, afmt integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst,ipart diff --git a/test/pargen/psb_s_pde3d.F90 b/test/pargen/psb_s_pde3d.F90 index 280a7c344..2938a4ffe 100644 --- a/test/pargen/psb_s_pde3d.F90 +++ b/test/pargen/psb_s_pde3d.F90 @@ -172,6 +172,9 @@ contains & f,amold,vmold,imold,partition,nrl,iv) use psb_base_mod use psb_util_mod +#if defined(OPENMP) + use omp_lib +#endif ! ! Discretizes the partial differential equation ! @@ -220,8 +223,7 @@ contains ! Process grid integer(psb_ipk_) :: np, iam integer(psb_ipk_) :: icoeff - integer(psb_lpk_), allocatable :: irow(:),icol(:),myidx(:) - real(psb_spk_), allocatable :: val(:) + integer(psb_lpk_), allocatable :: myidx(:) ! deltah dimension of each grid cell ! deltat discretization time real(psb_spk_) :: deltah, sqdeltah, deltah2 @@ -377,7 +379,6 @@ contains ! call psb_cdall(ctxt,desc_a,info,vl=myidx) - ! ! Specify process topology ! @@ -447,69 +448,79 @@ contains goto 9999 end if - ! we build an auxiliary matrix consisting of one row at a - ! time; just a small matrix. might be extended to generate - ! a bunch of rows per call. - ! - allocate(val(20*nb),irow(20*nb),& - &icol(20*nb),stat=info) - if (info /= psb_success_ ) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - - ! loop over rows belonging to current process in a block - ! distribution. - call psb_barrier(ctxt) t1 = psb_wtime() - do ii=1, nlr, nb - ib = min(nb,nlr-ii+1) - !ib = min(nb,mysz-ii+1) - icoeff = 1 - do k=1,ib - i=ii+k-1 - ! local matrix pointer - glob_row=myidx(i) - ! compute gridpoint coordinates - call idx2ijk(ix,iy,iz,glob_row,idim,idim,idim) - ! x, y, z coordinates - x = (ix-1)*deltah - y = (iy-1)*deltah - z = (iz-1)*deltah - zt(k) = f_(x,y,z) - ! internal point: build discretization - ! - ! term depending on (x-1,y,z) - ! - val(icoeff) = -a1(x,y,z)/sqdeltah-b1(x,y,z)/deltah2 - if (ix == 1) then - zt(k) = g(szero,y,z)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix-1,iy,iz,idim,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - ! term depending on (x,y-1,z) - val(icoeff) = -a2(x,y,z)/sqdeltah-b2(x,y,z)/deltah2 - if (iy == 1) then - zt(k) = g(x,szero,z)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix,iy-1,iz,idim,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - ! term depending on (x,y,z-1) - val(icoeff)=-a3(x,y,z)/sqdeltah-b3(x,y,z)/deltah2 - if (iz == 1) then - zt(k) = g(x,y,szero)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix,iy,iz-1,idim,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif + !$omp parallel shared(deltah,myidx,a,desc_a) + ! + block + integer(psb_ipk_) :: i,j,k,ii,ib,icoeff, ix,iy,iz, ith,nth + integer(psb_lpk_) :: glob_row + integer(psb_lpk_), allocatable :: irow(:),icol(:) + real(psb_spk_), allocatable :: val(:) + real(psb_spk_) :: x,y,z, zt(nb) +#if defined(OPENMP) + nth = omp_get_num_threads() + ith = omp_get_thread_num() +#else + nth = 1 + ith = 0 +#endif + allocate(val(20*nb),irow(20*nb),& + &icol(20*nb),stat=info) + if (info /= psb_success_ ) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + !goto 9999 + endif + + !$omp do schedule(dynamic) + ! + do ii=1, nlr, nb + if(info /= psb_success_) cycle + ib = min(nb,nlr-ii+1) + !ib = min(nb,mysz-ii+1) + icoeff = 1 + do k=1,ib + i=ii+k-1 + ! local matrix pointer + glob_row=myidx(i) + ! compute gridpoint coordinates + call idx2ijk(ix,iy,iz,glob_row,idim,idim,idim) + ! x, y, z coordinates + x = (ix-1)*deltah + y = (iy-1)*deltah + z = (iz-1)*deltah + zt(k) = f_(x,y,z) + ! internal point: build discretization + ! + ! term depending on (x-1,y,z) + ! + val(icoeff) = -a1(x,y,z)/sqdeltah-b1(x,y,z)/deltah2 + if (ix == 1) then + zt(k) = g(szero,y,z)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix-1,iy,iz,idim,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + ! term depending on (x,y-1,z) + val(icoeff) = -a2(x,y,z)/sqdeltah-b2(x,y,z)/deltah2 + if (iy == 1) then + zt(k) = g(x,szero,z)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix,iy-1,iz,idim,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + ! term depending on (x,y,z-1) + val(icoeff)=-a3(x,y,z)/sqdeltah-b3(x,y,z)/deltah2 + if (iz == 1) then + zt(k) = g(x,y,szero)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix,iy,iz-1,idim,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif ! term depending on (x,y,z) val(icoeff)=(2*sone)*(a1(x,y,z)+a2(x,y,z)+a3(x,y,z))/sqdeltah & @@ -546,14 +557,22 @@ contains endif end do - call psb_spins(icoeff-1,irow,icol,val,a,desc_a,info) - if(info /= psb_success_) exit - call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),bv,desc_a,info) - if(info /= psb_success_) exit - zt(:)=szero - call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),xv,desc_a,info) - if(info /= psb_success_) exit - end do +#if defined(OPENMP) +!!$ write(0,*) omp_get_thread_num(),' Check insertion ',& +!!$ & irow(1:icoeff-1),':',icol(1:icoeff-1) +#endif + call psb_spins(icoeff-1,irow,icol,val,a,desc_a,info) + if(info /= psb_success_) cycle + call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),bv,desc_a,info) + if(info /= psb_success_) cycle + zt(:)=szero + call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),xv,desc_a,info) + if(info /= psb_success_) cycle + end do + !$omp end do + deallocate(val,irow,icol) + end block + !$omp end parallel tgen = psb_wtime()-t1 if(info /= psb_success_) then @@ -569,113 +588,6 @@ contains call psb_cdasb(desc_a,info,mold=imold) tcdasb = psb_wtime()-t1 - if (.false.) then - ! - ! Add extra rows to test remote build. - ! - block - integer(psb_ipk_) :: ks, i - ks = desc_a%get_local_cols()-desc_a%get_local_rows() - if (ks > 0) ks = max(1,ks / 10) - mysz = nlr+ks - call psb_realloc(mysz,myidx,info) - do i=nlr+1, mysz - myidx(i) = i - end do - call desc_a%l2gv1(myidx(nlr+1:mysz),info) - !write(0,*) iam,' Check on extra nodes ',nlr,mysz,':',myidx(nlr+1:mysz) - do ii= nlr+1, mysz, nb - ib = min(nb,mysz-ii+1) - icoeff = 1 - do k=1,ib - i=ii+k-1 - ! local matrix pointer - glob_row=myidx(i) - ! compute gridpoint coordinates - call idx2ijk(ix,iy,iz,glob_row,idim,idim,idim) - ! x, y, z coordinates - x = (ix-1)*deltah - y = (iy-1)*deltah - z = (iz-1)*deltah - zt(k) = f_(x,y,z) - ! internal point: build discretization - ! - ! term depending on (x-1,y,z) - ! - val(icoeff) = -a1(x,y,z)/sqdeltah-b1(x,y,z)/deltah2 - if (ix == 1) then - zt(k) = g(szero,y,z)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix-1,iy,iz,idim,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - ! term depending on (x,y-1,z) - val(icoeff) = -a2(x,y,z)/sqdeltah-b2(x,y,z)/deltah2 - if (iy == 1) then - zt(k) = g(x,szero,z)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix,iy-1,iz,idim,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - ! term depending on (x,y,z-1) - val(icoeff)=-a3(x,y,z)/sqdeltah-b3(x,y,z)/deltah2 - if (iz == 1) then - zt(k) = g(x,y,szero)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix,iy,iz-1,idim,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - - ! term depending on (x,y,z) - val(icoeff)=(2*sone)*(a1(x,y,z)+a2(x,y,z)+a3(x,y,z))/sqdeltah & - & + c(x,y,z) - call ijk2idx(icol(icoeff),ix,iy,iz,idim,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - ! term depending on (x,y,z+1) - val(icoeff)=-a3(x,y,z)/sqdeltah+b3(x,y,z)/deltah2 - if (iz == idim) then - zt(k) = g(x,y,sone)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix,iy,iz+1,idim,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - ! term depending on (x,y+1,z) - val(icoeff)=-a2(x,y,z)/sqdeltah+b2(x,y,z)/deltah2 - if (iy == idim) then - zt(k) = g(x,sone,z)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix,iy+1,iz,idim,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - ! term depending on (x+1,y,z) - val(icoeff)=-a1(x,y,z)/sqdeltah+b1(x,y,z)/deltah2 - if (ix==idim) then - zt(k) = g(sone,y,z)*(-val(icoeff)) + zt(k) - else - call ijk2idx(icol(icoeff),ix+1,iy,iz,idim,idim,idim) - irow(icoeff) = glob_row - icoeff = icoeff+1 - endif - - end do - call psb_spins(icoeff-1,irow,icol,val,a,desc_a,info) - if(info /= psb_success_) exit - call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),bv,desc_a,info) - if(info /= psb_success_) exit - zt(:)=szero - call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),xv,desc_a,info) - if(info /= psb_success_) exit - end do - - end block - end if - call psb_barrier(ctxt) t1 = psb_wtime() if (info == psb_success_) then @@ -719,7 +631,7 @@ contains write(psb_out_unit,'("-total time : ",es12.5)') ttot end if - deallocate(val,irow,icol) + call psb_erractionrestore(err_act) return @@ -744,6 +656,9 @@ program psb_s_pde3d use psb_krylov_mod use psb_util_mod use psb_s_pde3d_mod +#if defined(OPENMP) + use omp_lib +#endif implicit none ! input parameters @@ -765,7 +680,7 @@ program psb_s_pde3d type(psb_s_vect_type) :: xxv,bv ! parallel environment type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: iam, np + integer(psb_ipk_) :: iam, np, nth ! solver parameters integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst, ipart @@ -790,7 +705,16 @@ program psb_s_pde3d call psb_init(ctxt) call psb_info(ctxt,iam,np) - +#if defined(OPENMP) + !$OMP parallel shared(nth) + !$OMP master + nth = omp_get_num_threads() + !$OMP end master + !$OMP end parallel +#else + nth = 1 +#endif + if (iam < 0) then ! This should not happen, but just in case call psb_exit(ctxt) @@ -914,6 +838,8 @@ program psb_s_pde3d if (iam == psb_root_) then write(psb_out_unit,'(" ")') write(psb_out_unit,'("Number of processes : ",i12)')np + write(psb_out_unit,'("Number of threads : ",i12)')nth + write(psb_out_unit,'("Total number of tasks : ",i12)')nth*np write(psb_out_unit,'("Linear system size : ",i12)') system_size write(psb_out_unit,'("Time to solve system : ",es12.5)')t2 write(psb_out_unit,'("Time per iteration : ",es12.5)')t2/iter diff --git a/test/pargen/runs/ppde.inp b/test/pargen/runs/ppde.inp index 44dac085a..cf7179ac9 100644 --- a/test/pargen/runs/ppde.inp +++ b/test/pargen/runs/ppde.inp @@ -8,7 +8,7 @@ CSR Storage format for matrix A: CSR COO 0008 MAXIT 10 ITRACE 002 IRST restart for RGMRES and BiCGSTABL -ILU Block Solver ILU,ILUT,INVK,AINVT,AORTH +INVK Block Solver ILU,ILUT,INVK,AINVT,AORTH NONE If ILU : MILU or NONE othewise ignored NONE Scaling if ILUT: NONE, MAXVAL otherwise ignored 0 Level of fill for forward factorization diff --git a/util/Makefile b/util/Makefile index 3f087cbd5..9b70855f5 100644 --- a/util/Makefile +++ b/util/Makefile @@ -11,7 +11,7 @@ BASEOBJS= psb_blockpart_mod.o psb_metispart_mod.o psb_partidx_mod.o \ psb_hbio_mod.o psb_mmio_mod.o psb_mat_dist_mod.o \ psb_s_mat_dist_mod.o psb_d_mat_dist_mod.o psb_c_mat_dist_mod.o psb_z_mat_dist_mod.o \ psb_renum_mod.o psb_gps_mod.o \ - psb_s_renum_mod.o psb_d_renum_mod.o psb_c_renum_mod.o psb_z_renum_mod.o + psb_s_renum_mod.o psb_d_renum_mod.o psb_c_renum_mod.o psb_z_renum_mod.o IMPLOBJS= psb_s_hbio_impl.o psb_d_hbio_impl.o \ psb_c_hbio_impl.o psb_z_hbio_impl.o \ psb_s_mmio_impl.o psb_d_mmio_impl.o \