From e8903bc28be6d0a9165f5e0279ef980f6f9fa791 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 21 Nov 2022 08:59:59 -0500 Subject: [PATCH 01/63] Fix VL(:) initialization when CHECK_=.false. --- base/tools/psb_cd_inloc.f90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/base/tools/psb_cd_inloc.f90 b/base/tools/psb_cd_inloc.f90 index f8d609c4b..e8b9578ec 100644 --- a/base/tools/psb_cd_inloc.f90 +++ b/base/tools/psb_cd_inloc.f90 @@ -275,6 +275,8 @@ subroutine psb_cd_inloc(v, ctxt, desc, info, globalcheck,idx,usehash) if (debug_size) & & write(debug_unit,*) me,' ',trim(name),': After sort ',nlu + else + nlu = loc_row end if call psb_nullify_desc(desc) if (do_timings) then From e6d1a1a085bdc093dabb015d6bf23842615dd6f1 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 7 Dec 2022 10:45:10 +0100 Subject: [PATCH 02/63] Fix white spaces in configry --- compile | 0 config/pac.m4 | 51 +++++++++++++++++++++++++++----------------- configure | 59 ++++++++++++++++++++++++++++++--------------------- 3 files changed, 66 insertions(+), 44 deletions(-) create mode 100644 compile diff --git a/compile b/compile new file mode 100644 index 000000000..e69de29bb 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..9e371ab9c 100755 --- a/configure +++ b/configure @@ -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. */ @@ -8912,7 +8912,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 +9041,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 +9139,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 +9183,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 +9223,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 +9257,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 +9294,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 +9328,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 +9365,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 +9382,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 +9419,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 +9453,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 +9516,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 +9555,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 +9591,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 +9654,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 +9699,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 +9755,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 +9765,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 +10228,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 +10499,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; } From beefe9aa1a6030e1d97827ad74a44ce19fa253b3 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 31 Jan 2023 08:55:00 -0500 Subject: [PATCH 03/63] Missing "compile" for configure. --- compile | 0 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100644 compile diff --git a/compile b/compile new file mode 100644 index 000000000..e69de29bb From afdbac67276a033ebe24b0b52b873ebfed753b5c Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 6 Feb 2023 19:00:07 +0100 Subject: [PATCH 04/63] Swicth csr_impl to F90 --- ...{psb_c_csr_impl.f90 => psb_c_csr_impl.F90} | 339 +++++++++--------- ...{psb_d_csr_impl.f90 => psb_d_csr_impl.F90} | 339 +++++++++--------- ...{psb_s_csr_impl.f90 => psb_s_csr_impl.F90} | 339 +++++++++--------- ...{psb_z_csr_impl.f90 => psb_z_csr_impl.F90} | 339 +++++++++--------- test/pargen/runs/ppde.inp | 2 +- 5 files changed, 685 insertions(+), 673 deletions(-) rename base/serial/impl/{psb_c_csr_impl.f90 => psb_c_csr_impl.F90} (96%) rename base/serial/impl/{psb_d_csr_impl.f90 => psb_d_csr_impl.F90} (96%) rename base/serial/impl/{psb_s_csr_impl.f90 => psb_s_csr_impl.F90} (96%) rename base/serial/impl/{psb_z_csr_impl.f90 => psb_z_csr_impl.F90} (96%) diff --git a/base/serial/impl/psb_c_csr_impl.f90 b/base/serial/impl/psb_c_csr_impl.F90 similarity index 96% rename from base/serial/impl/psb_c_csr_impl.f90 rename to base/serial/impl/psb_c_csr_impl.F90 index 88510e538..87b0872bb 100644 --- a/base/serial/impl/psb_c_csr_impl.f90 +++ b/base/serial/impl/psb_c_csr_impl.F90 @@ -2837,6 +2837,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 @@ -2851,13 +2854,11 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_) :: debug_level, debug_unit 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. - +#if defined(OPENMP) + 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 +#endif info = psb_success_ debug_unit = psb_get_debug_unit() @@ -2902,94 +2903,93 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) 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 +#if defined(OPENMP) + 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 +#endif call a%set_host() - - + end subroutine psb_c_cp_csr_from_coo @@ -3089,6 +3089,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 @@ -3102,12 +3105,12 @@ 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. +#if defined(OPENMP) + 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 +#endif info = psb_success_ @@ -3135,74 +3138,74 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) a%irp(:) = 0 -!!$ 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 +#if defined(OPENMP) + !$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 @@ -3214,7 +3217,7 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) ip = ip + ncl end do a%irp(nr+1) = ip -!!$ end if +#endif call a%set_host() diff --git a/base/serial/impl/psb_d_csr_impl.f90 b/base/serial/impl/psb_d_csr_impl.F90 similarity index 96% rename from base/serial/impl/psb_d_csr_impl.f90 rename to base/serial/impl/psb_d_csr_impl.F90 index a927b1a92..3aadde201 100644 --- a/base/serial/impl/psb_d_csr_impl.f90 +++ b/base/serial/impl/psb_d_csr_impl.F90 @@ -2837,6 +2837,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 @@ -2851,13 +2854,11 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_) :: debug_level, debug_unit 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. - +#if defined(OPENMP) + 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 +#endif info = psb_success_ debug_unit = psb_get_debug_unit() @@ -2902,94 +2903,93 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) 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 +#if defined(OPENMP) + 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 +#endif call a%set_host() - - + end subroutine psb_d_cp_csr_from_coo @@ -3089,6 +3089,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 @@ -3102,12 +3105,12 @@ 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. +#if defined(OPENMP) + 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 +#endif info = psb_success_ @@ -3135,74 +3138,74 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) a%irp(:) = 0 -!!$ 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 +#if defined(OPENMP) + !$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 @@ -3214,7 +3217,7 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) ip = ip + ncl end do a%irp(nr+1) = ip -!!$ end if +#endif call a%set_host() diff --git a/base/serial/impl/psb_s_csr_impl.f90 b/base/serial/impl/psb_s_csr_impl.F90 similarity index 96% rename from base/serial/impl/psb_s_csr_impl.f90 rename to base/serial/impl/psb_s_csr_impl.F90 index b2d9dd488..a554e13be 100644 --- a/base/serial/impl/psb_s_csr_impl.f90 +++ b/base/serial/impl/psb_s_csr_impl.F90 @@ -2837,6 +2837,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 @@ -2851,13 +2854,11 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_) :: debug_level, debug_unit 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. - +#if defined(OPENMP) + 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 +#endif info = psb_success_ debug_unit = psb_get_debug_unit() @@ -2902,94 +2903,93 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) 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 +#if defined(OPENMP) + 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 +#endif call a%set_host() - - + end subroutine psb_s_cp_csr_from_coo @@ -3089,6 +3089,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 @@ -3102,12 +3105,12 @@ 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. +#if defined(OPENMP) + 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 +#endif info = psb_success_ @@ -3135,74 +3138,74 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) a%irp(:) = 0 -!!$ 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 +#if defined(OPENMP) + !$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 @@ -3214,7 +3217,7 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) ip = ip + ncl end do a%irp(nr+1) = ip -!!$ end if +#endif call a%set_host() diff --git a/base/serial/impl/psb_z_csr_impl.f90 b/base/serial/impl/psb_z_csr_impl.F90 similarity index 96% rename from base/serial/impl/psb_z_csr_impl.f90 rename to base/serial/impl/psb_z_csr_impl.F90 index ba2d322fc..b2b0d3d13 100644 --- a/base/serial/impl/psb_z_csr_impl.f90 +++ b/base/serial/impl/psb_z_csr_impl.F90 @@ -2837,6 +2837,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 @@ -2851,13 +2854,11 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_) :: debug_level, debug_unit 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. - +#if defined(OPENMP) + 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 +#endif info = psb_success_ debug_unit = psb_get_debug_unit() @@ -2902,94 +2903,93 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) 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 +#if defined(OPENMP) + 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 +#endif call a%set_host() - - + end subroutine psb_z_cp_csr_from_coo @@ -3089,6 +3089,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 @@ -3102,12 +3105,12 @@ 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. +#if defined(OPENMP) + 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 +#endif info = psb_success_ @@ -3135,74 +3138,74 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) a%irp(:) = 0 -!!$ 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 +#if defined(OPENMP) + !$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 @@ -3214,7 +3217,7 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) ip = ip + ncl end do a%irp(nr+1) = ip -!!$ end if +#endif call a%set_host() diff --git a/test/pargen/runs/ppde.inp b/test/pargen/runs/ppde.inp index f4b45430e..996585dd0 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 0100 MAXIT 05 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 From 784cc65e518374dfaa618be2f6d731030b2f58a4 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 10 Feb 2023 07:45:44 -0500 Subject: [PATCH 05/63] Temporarily revert hash_map_mod waiting for a proper fix --- base/modules/desc/psb_hash_map_mod.f90 | 871 ++++++++++++++++--------- 1 file changed, 547 insertions(+), 324 deletions(-) diff --git a/base/modules/desc/psb_hash_map_mod.f90 b/base/modules/desc/psb_hash_map_mod.f90 index 06e68451a..528450ae0 100644 --- a/base/modules/desc/psb_hash_map_mod.f90 +++ b/base/modules/desc/psb_hash_map_mod.f90 @@ -659,49 +659,410 @@ contains !$ use_openmp = .true. - info = psb_success_ - name = 'hash_g2l_ins' - call psb_erractionsave(err_act) + if (.true.) then + info = psb_success_ + name = 'hash_g2l_ins' + call psb_erractionsave(err_act) - ctxt = idxmap%get_ctxt() - call psb_info(ctxt, me, np) + ctxt = idxmap%get_ctxt() + call psb_info(ctxt, me, np) - is = size(idx) + is = size(idx) - if (present(mask)) then - if (size(mask) < size(idx)) then - info = -1 - return + if (present(mask)) then + if (size(mask) < size(idx)) then + info = -1 + return + end if + end if + if (present(lidx)) then + if (size(lidx) < size(idx)) then + info = -1 + return + end if end if - end if - if (present(lidx)) then - if (size(lidx) < size(idx)) then + + mglob = idxmap%get_gr() + nrow = idxmap%get_lr() + if (idxmap%is_bld()) then + + if (present(lidx)) then + if (present(mask)) then + do i = 1, is + ncol = idxmap%get_lc() + if (mask(i)) then + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob) ) then + idx(i) = -1 + cycle + endif + call hash_inner_cnv(ip,lip,idxmap%hashvmask,& + & idxmap%hashv,idxmap%glb_lc,ncol) + if (lip < 0) then + tlip = lip + nxt = lidx(i) + if (nxt <= nrow) then + idx(i) = -1 + cycle + endif + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + if (info >=0) then + if (nxt == tlip) then + ncol = max(ncol,nxt) + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& + & pad=-1_psb_lpk_,addsz=laddsz) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + &a_err='psb_ensure_size',i_err=(/info/)) + goto 9999 + end if + idxmap%loc_to_glob(nxt) = ip + call idxmap%set_lc(ncol) + endif + info = psb_success_ + else + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='SearchInsKeyVal',i_err=(/info/)) + goto 9999 + end if + end if + idx(i) = lip + info = psb_success_ + else + idx(i) = -1 + end if + enddo + + else if (.not.present(mask)) then + + do i = 1, is + ncol = idxmap%get_lc() + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle + endif + call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& + & idxmap%glb_lc,ncol) + if (lip < 0) then + nxt = lidx(i) + if (nxt <= nrow) then + idx(i) = -1 + cycle + endif + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + lip = tlip + + if (info >=0) then + if (nxt == lip) then + ncol = max(nxt,ncol) + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-1_psb_lpk_,addsz=laddsz) + if (info /= psb_success_) then + info=1 + call psb_errpush(psb_err_from_subroutine_ai_,name,& + &a_err='psb_ensure_size',i_err=(/info/)) + goto 9999 + end if + idxmap%loc_to_glob(nxt) = ip + call idxmap%set_lc(ncol) + endif + info = psb_success_ + else + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='SearchInsKeyVal',i_err=(/info/)) + goto 9999 + end if + end if + idx(i) = lip + info = psb_success_ + enddo + + end if + + else if (.not.present(lidx)) then + + if (present(mask)) then + do i = 1, is + ncol = idxmap%get_lc() + if (mask(i)) then + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle + endif + nxt = ncol + 1 + call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& + & idxmap%glb_lc,ncol) + if (lip < 0) then + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + lip = tlip + end if + + if (info >=0) then + if (nxt == lip) then + ncol = nxt + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& + & pad=-1_psb_lpk_,addsz=laddsz) + if (info /= psb_success_) then + info=1 + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='psb_ensure_size',i_err=(/info/)) + goto 9999 + end if + idxmap%loc_to_glob(nxt) = ip + call idxmap%set_lc(ncol) + endif + info = psb_success_ + else + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='SearchInsKeyVal',i_err=(/info/)) + goto 9999 + end if + idx(i) = lip + info = psb_success_ + else + idx(i) = -1 + end if + enddo + + else if (.not.present(mask)) then + + do i = 1, is + ncol = idxmap%get_lc() + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle + endif + nxt = ncol + 1 + call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& + & idxmap%glb_lc,ncol) + if (lip < 0) then + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + lip = tlip + end if + + if (info >=0) then + if (nxt == lip) then + ncol = nxt + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& + & pad=-1_psb_lpk_,addsz=laddsz) + if (info /= psb_success_) then + info=1 + ch_err='psb_ensure_size' + call psb_errpush(psb_err_from_subroutine_ai_,name,& + &a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) + goto 9999 + end if + idxmap%loc_to_glob(nxt) = ip + call idxmap%set_lc(ncol) + endif + info = psb_success_ + else + ch_err='SearchInsKeyVal' + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) + goto 9999 + end if + idx(i) = lip + info = psb_success_ + enddo + + + end if + end if + else + ! Wrong state + idx = -1 info = -1 - return end if - end if + else - mglob = idxmap%get_gr() - nrow = idxmap%get_lr() + info = psb_success_ + name = 'hash_g2l_ins' + call psb_erractionsave(err_act) - if (idxmap%is_bld()) then - if (use_openmp) then - !$ call OMP_init_lock(ins_lck) - isLoopValid = .true. - ncol = idxmap%get_lc() + ctxt = idxmap%get_ctxt() + call psb_info(ctxt, me, np) + + is = size(idx) + + if (present(mask)) then + if (size(mask) < size(idx)) then + info = -1 + return + end if end if - if (present(lidx)) then - if (present(mask)) then - if (use_openmp) then - !$OMP PARALLEL DO default(none) schedule(STATIC) & - !$OMP shared(name,is,mask,lidx,idx,mglob,idxmap,ncol,nrow,ins_lck,laddsz) & - !$OMP private(i,ip,lip,tlip,nxt,info) & - !$OMP reduction(.AND.:isLoopValid) - do i = 1, is + if (present(lidx)) then + if (size(lidx) < size(idx)) then + info = -1 + return + end if + end if + + mglob = idxmap%get_gr() + nrow = idxmap%get_lr() + + if (idxmap%is_bld()) then + if (use_openmp) then + !$ call OMP_init_lock(ins_lck) + isLoopValid = .true. + ncol = idxmap%get_lc() + end if + + if (present(lidx)) then + if (present(mask)) then + if (use_openmp) then + !$OMP PARALLEL DO default(none) schedule(STATIC) & + !$OMP shared(name,is,mask,lidx,idx,mglob,idxmap,ncol,nrow,ins_lck,laddsz) & + !$OMP private(i,ip,lip,tlip,nxt,info) & + !$OMP reduction(.AND.:isLoopValid) + do i = 1, is + + if (mask(i)) then + ip = idx(i) + + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle + endif + + ! At first, we check the index presence in 'idxmap'. Usually + ! the index is found. If it is not found, we repeat the checking, + ! but inside a critical region. + call hash_inner_cnv(ip,lip,idxmap%hashvmask,& + & idxmap%hashv,idxmap%glb_lc,ncol) + + if (lip < 0) then + tlip = lip + nxt = lidx(i) + + if (nxt <= nrow) then + idx(i) = -1 + cycle + endif + + ! We check again if the index is already in 'idxmap', this + ! time inside a critical region (we assume that the index + ! is often already existing). + !$ call OMP_set_lock(ins_lck) + call hash_inner_cnv(ip,lip,idxmap%hashvmask,& + & idxmap%hashv,idxmap%glb_lc,ncol) + ! Index not found + if (lip < 0) then + ! Locking system to handle concurrent hashmap read/write. + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + + if (info >= 0) then + ! 'nxt' is not equal to 'tlip' when the key is already inside + ! the hash map. In that case 'tlip' is the value corresponding + ! to the existing mapping. + if (nxt == tlip) then + + ncol = MAX(ncol,nxt) + !$ call OMP_unset_lock(ins_lck) + + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& + & pad=-1_psb_lpk_,addsz=laddsz) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + &a_err='psb_ensure_size',i_err=(/info/)) + + isLoopValid = .false. + cycle + end if + + idxmap%loc_to_glob(nxt) = ip + else + !$ call OMP_unset_lock(ins_lck) + end if + + info = psb_success_ + + else + !$ call OMP_unset_lock(ins_lck) + + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='SearchInsKeyVal',i_err=(/info/)) + + isLoopValid = .false. + cycle + end if + else + !$ call OMP_unset_lock(ins_lck) + end if + end if + + idx(i) = lip + info = psb_success_ + else + idx(i) = -1 + end if + end do + !$OMP END PARALLEL DO + + call idxmap%set_lc(ncol) - if (mask(i)) then + if (.not. isLoopValid) then + goto 9999 + end if + + else + do i = 1, is + ncol = idxmap%get_lc() + if (mask(i)) then + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob) ) then + idx(i) = -1 + cycle + endif + call hash_inner_cnv(ip,lip,idxmap%hashvmask,& + & idxmap%hashv,idxmap%glb_lc,ncol) + if (lip < 0) then + tlip = lip + nxt = lidx(i) + if (nxt <= nrow) then + idx(i) = -1 + cycle + endif + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + if (info >=0) then + if (nxt == tlip) then + ncol = max(ncol,nxt) + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& + & pad=-1_psb_lpk_,addsz=laddsz) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + &a_err='psb_ensure_size',i_err=(/info/)) + goto 9999 + end if + idxmap%loc_to_glob(nxt) = ip + call idxmap%set_lc(ncol) + endif + info = psb_success_ + else + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='SearchInsKeyVal',i_err=(/info/)) + goto 9999 + end if + end if + idx(i) = lip + info = psb_success_ + else + idx(i) = -1 + end if + enddo + end if + else if (.not.present(mask)) then + if (use_openmp) then + !$OMP PARALLEL DO default(none) schedule(STATIC) & + !$OMP shared(name,is,idx,lidx,mglob,idxmap,ncol,nrow,ins_lck,laddsz) & + !$OMP private(i,ip,lip,tlip,nxt,info) & + !$OMP reduction(.AND.:isLoopValid) + do i = 1, is ip = idx(i) if ((ip < 1 ).or.(ip>mglob)) then @@ -709,9 +1070,8 @@ contains cycle endif - ! At first, we check the index presence in 'idxmap'. Usually - ! the index is found. If it is not found, we repeat the checking, - ! but inside a critical region. + ! In OMP logic the index research limit is turned off. It is + ! a correct way to fit the subroutine? call hash_inner_cnv(ip,lip,idxmap%hashvmask,& & idxmap%hashv,idxmap%glb_lc,ncol) @@ -729,11 +1089,12 @@ contains ! is often already existing). !$ call OMP_set_lock(ins_lck) call hash_inner_cnv(ip,lip,idxmap%hashvmask,& - & idxmap%hashv,idxmap%glb_lc,ncol) - ! Index not found + & idxmap%hashv,idxmap%glb_lc,ncol) + if (lip < 0) then - ! Locking system to handle concurrent hashmap read/write. + ! Locking system to handle concurrent write/access. Under checking! call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + !$ call OMP_unset_lock(ins_lck) if (info >= 0) then ! 'nxt' is not equal to 'tlip' when the key is already inside @@ -744,12 +1105,13 @@ contains ncol = MAX(ncol,nxt) !$ call OMP_unset_lock(ins_lck) + ! Under checking! call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& & pad=-1_psb_lpk_,addsz=laddsz) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_ai_,name,& - &a_err='psb_ensure_size',i_err=(/info/)) + &a_err='psb_ensure_size',i_err=(/info/)) isLoopValid = .false. cycle @@ -761,7 +1123,6 @@ contains end if info = psb_success_ - else !$ call OMP_unset_lock(ins_lck) @@ -778,43 +1139,40 @@ contains idx(i) = lip info = psb_success_ - else - idx(i) = -1 - end if - end do - !$OMP END PARALLEL DO + end do + !$OMP END PARALLEL DO - call idxmap%set_lc(ncol) + call idxmap%set_lc(ncol) - if (.not. isLoopValid) then - goto 9999 - end if + if (.not. isLoopValid) then + goto 9999 + end if - else - do i = 1, is - ncol = idxmap%get_lc() - if (mask(i)) then - ip = idx(i) - if ((ip < 1 ).or.(ip>mglob) ) then + else + do i = 1, is + ncol = idxmap%get_lc() + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob)) then idx(i) = -1 cycle endif - call hash_inner_cnv(ip,lip,idxmap%hashvmask,& - & idxmap%hashv,idxmap%glb_lc,ncol) - if (lip < 0) then - tlip = lip + call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& + & idxmap%glb_lc,ncol) + if (lip < 0) then nxt = lidx(i) if (nxt <= nrow) then idx(i) = -1 cycle endif call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + lip = tlip + if (info >=0) then - if (nxt == tlip) then - ncol = max(ncol,nxt) - call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& - & pad=-1_psb_lpk_,addsz=laddsz) + if (nxt == lip) then + ncol = max(nxt,ncol) + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-1_psb_lpk_,addsz=laddsz) if (info /= psb_success_) then + info=1 call psb_errpush(psb_err_from_subroutine_ai_,name,& &a_err='psb_ensure_size',i_err=(/info/)) goto 9999 @@ -831,50 +1189,58 @@ contains end if idx(i) = lip info = psb_success_ - else - idx(i) = -1 - end if - enddo + enddo + end if end if - else if (.not.present(mask)) then - if (use_openmp) then - !$OMP PARALLEL DO default(none) schedule(STATIC) & - !$OMP shared(name,is,idx,lidx,mglob,idxmap,ncol,nrow,ins_lck,laddsz) & - !$OMP private(i,ip,lip,tlip,nxt,info) & - !$OMP reduction(.AND.:isLoopValid) - do i = 1, is - ip = idx(i) - if ((ip < 1 ).or.(ip>mglob)) then - idx(i) = -1 - cycle - endif + else if (.not.present(lidx)) then - ! In OMP logic the index research limit is turned off. It is - ! a correct way to fit the subroutine? - call hash_inner_cnv(ip,lip,idxmap%hashvmask,& - & idxmap%hashv,idxmap%glb_lc,ncol) + if (present(mask)) then + if (use_openmp) then + !$OMP PARALLEL DO default(none) schedule(STATIC) & + !$OMP shared(name,is,idx,mask,mglob,idxmap,ncol,nrow,ins_lck,laddsz) & + !$OMP private(i,ip,lip,tlip,nxt,info) & + !$OMP reduction(.AND.:isLoopValid) + do i = 1, is - if (lip < 0) then - tlip = lip - nxt = lidx(i) + ncol = idxmap%get_lc() + info = 0 + if (mask(i)) then + ip = idx(i) - if (nxt <= nrow) then - idx(i) = -1 - cycle - endif + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle + endif - ! We check again if the index is already in 'idxmap', this - ! time inside a critical region (we assume that the index - ! is often already existing). - !$ call OMP_set_lock(ins_lck) - call hash_inner_cnv(ip,lip,idxmap%hashvmask,& - & idxmap%hashv,idxmap%glb_lc,ncol) + nxt = ncol + 1 + ! At first, we check the index presence in 'idxmap'. Usually + ! the index is found. If it is not found, we repeat the checking, + ! but inside a critical region. + call hash_inner_cnv(ip,lip,idxmap%hashvmask,& + & idxmap%hashv,idxmap%glb_lc,ncol) - if (lip < 0) then - ! Locking system to handle concurrent write/access. Under checking! - call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) - !$ call OMP_unset_lock(ins_lck) + if (lip < 0) then + + ! We check again if the index is already in 'idxmap', this + ! time inside a critical region (we assume that the index + ! is often already existing). + !$ call OMP_set_lock(ins_lck) + call hash_inner_cnv(ip,lip,idxmap%hashvmask,& + & idxmap%hashv,idxmap%glb_lc,ncol) + + ! Index not found + if (lip < 0) then + ! Locking system to handle concurrent hashmap write/access. + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + lip = tlip + else + !$ call OMP_unset_lock(ins_lck) + end if + + idx(i) = lip + info = psb_success_ + end if if (info >= 0) then ! 'nxt' is not equal to 'tlip' when the key is already inside @@ -885,13 +1251,12 @@ contains ncol = MAX(ncol,nxt) !$ call OMP_unset_lock(ins_lck) - ! Under checking! call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& & pad=-1_psb_lpk_,addsz=laddsz) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_ai_,name,& - &a_err='psb_ensure_size',i_err=(/info/)) + &a_err='psb_ensure_size',i_err=(/info/)) isLoopValid = .false. cycle @@ -912,78 +1277,71 @@ contains isLoopValid = .false. cycle end if + else - !$ call OMP_unset_lock(ins_lck) + idx(i) = -1 end if - end if - - idx(i) = lip - info = psb_success_ - end do - !$OMP END PARALLEL DO + end do + !$OMP END PARALLEL DO - call idxmap%set_lc(ncol) + call idxmap%set_lc(ncol) - if (.not. isLoopValid) then - goto 9999 - end if + if (.not. isLoopValid) then + goto 9999 + end if - else - do i = 1, is - ncol = idxmap%get_lc() - ip = idx(i) - if ((ip < 1 ).or.(ip>mglob)) then - idx(i) = -1 - cycle - endif - call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& - & idxmap%glb_lc,ncol) - if (lip < 0) then - nxt = lidx(i) - if (nxt <= nrow) then - idx(i) = -1 - cycle - endif - call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) - lip = tlip - - if (info >=0) then - if (nxt == lip) then - ncol = max(nxt,ncol) - call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-1_psb_lpk_,addsz=laddsz) - if (info /= psb_success_) then - info=1 - call psb_errpush(psb_err_from_subroutine_ai_,name,& - &a_err='psb_ensure_size',i_err=(/info/)) - goto 9999 - end if - idxmap%loc_to_glob(nxt) = ip - call idxmap%set_lc(ncol) + else + do i = 1, is + ncol = idxmap%get_lc() + if (mask(i)) then + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle endif + nxt = ncol + 1 + call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& + & idxmap%glb_lc,ncol) + if (lip < 0) then + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + lip = tlip + end if + + if (info >=0) then + if (nxt == lip) then + ncol = nxt + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& + & pad=-1_psb_lpk_,addsz=laddsz) + if (info /= psb_success_) then + info=1 + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='psb_ensure_size',i_err=(/info/)) + goto 9999 + end if + idxmap%loc_to_glob(nxt) = ip + call idxmap%set_lc(ncol) + endif + info = psb_success_ + else + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='SearchInsKeyVal',i_err=(/info/)) + goto 9999 + end if + idx(i) = lip info = psb_success_ else - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='SearchInsKeyVal',i_err=(/info/)) - goto 9999 + idx(i) = -1 end if - end if - idx(i) = lip - info = psb_success_ - enddo - end if - end if - - else if (.not.present(lidx)) then - - if (present(mask)) then - if (use_openmp) then - !$OMP PARALLEL DO default(none) schedule(STATIC) & - !$OMP shared(name,is,idx,mask,mglob,idxmap,ncol,nrow,ins_lck,laddsz) & - !$OMP private(i,ip,lip,tlip,nxt,info) & - !$OMP reduction(.AND.:isLoopValid) - do i = 1, is + enddo + end if + else if (.not.present(mask)) then + if (use_openmp) then + !$OMP PARALLEL DO default(none) schedule(STATIC) & + !$OMP shared(name,is,idx,mglob,idxmap,ncol,nrow,ins_lck,laddsz) & + !$OMP private(i,ip,lip,tlip,nxt,info) & + !$OMP reduction(.AND.:isLoopValid) + do i = 1, is - if (mask(i)) then ip = idx(i) if ((ip < 1 ).or.(ip>mglob)) then @@ -1004,7 +1362,7 @@ contains ! is often already existing). !$ call OMP_set_lock(ins_lck) call hash_inner_cnv(ip,lip,idxmap%hashvmask,& - & idxmap%hashv,idxmap%glb_lc,ncol) + & idxmap%hashv,idxmap%glb_lc,ncol) ! Index not found if (lip < 0) then @@ -1024,7 +1382,6 @@ contains ! the hash map. In that case 'tlip' is the value corresponding ! to the existing mapping. if (nxt == tlip) then - ncol = MAX(ncol,nxt) !$ call OMP_unset_lock(ins_lck) @@ -1033,9 +1390,9 @@ contains if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_ai_,name,& - &a_err='psb_ensure_size',i_err=(/info/)) + &a_err='psb_ensure_size',i_err=(/info/)) - isLoopValid = .false. + !$ isLoopValid = .false. cycle end if @@ -1045,6 +1402,7 @@ contains end if info = psb_success_ + else !$ call OMP_unset_lock(ins_lck) @@ -1054,23 +1412,18 @@ contains isLoopValid = .false. cycle end if + end do + !$OMP END PARALLEL DO - else - idx(i) = -1 - end if - end do - !$OMP END PARALLEL DO + call idxmap%set_lc(ncol) - call idxmap%set_lc(ncol) - - if (.not. isLoopValid) then - goto 9999 - end if + if (.not. isLoopValid) then + goto 9999 + end if - else - do i = 1, is - ncol = idxmap%get_lc() - if (mask(i)) then + else + do i = 1, is + ncol = idxmap%get_lc() ip = idx(i) if ((ip < 1 ).or.(ip>mglob)) then idx(i) = -1 @@ -1091,8 +1444,9 @@ contains & pad=-1_psb_lpk_,addsz=laddsz) if (info /= psb_success_) then info=1 + ch_err='psb_ensure_size' call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='psb_ensure_size',i_err=(/info/)) + &a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) goto 9999 end if idxmap%loc_to_glob(nxt) = ip @@ -1100,159 +1454,28 @@ contains endif info = psb_success_ else + ch_err='SearchInsKeyVal' call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='SearchInsKeyVal',i_err=(/info/)) + & a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) goto 9999 end if idx(i) = lip info = psb_success_ - else - idx(i) = -1 - end if - enddo - end if - else if (.not.present(mask)) then - if (use_openmp) then - !$OMP PARALLEL DO default(none) schedule(STATIC) & - !$OMP shared(name,is,idx,mglob,idxmap,ncol,nrow,ins_lck,laddsz) & - !$OMP private(i,ip,lip,tlip,nxt,info) & - !$OMP reduction(.AND.:isLoopValid) - do i = 1, is - - ip = idx(i) - - if ((ip < 1 ).or.(ip>mglob)) then - idx(i) = -1 - cycle - endif - - ! At first, we check the index presence in 'idxmap'. Usually - ! the index is found. If it is not found, we repeat the checking, - ! but inside a critical region. - call hash_inner_cnv(ip,lip,idxmap%hashvmask,& - & idxmap%hashv,idxmap%glb_lc,ncol) - - if (lip < 0) then - - ! We check again if the index is already in 'idxmap', this - ! time inside a critical region (we assume that the index - ! is often already existing). - !$ call OMP_set_lock(ins_lck) - call hash_inner_cnv(ip,lip,idxmap%hashvmask,& - & idxmap%hashv,idxmap%glb_lc,ncol) - - ! Index not found - if (lip < 0) then - ! Locking system to handle concurrent hashmap write/access. - call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) - lip = tlip - else - !$ call OMP_unset_lock(ins_lck) - end if - - idx(i) = lip - info = psb_success_ - end if - - if (info >= 0) then - ! 'nxt' is not equal to 'tlip' when the key is already inside - ! the hash map. In that case 'tlip' is the value corresponding - ! to the existing mapping. - if (nxt == tlip) then - ncol = MAX(ncol,nxt) - !$ call OMP_unset_lock(ins_lck) - - call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& - & pad=-1_psb_lpk_,addsz=laddsz) - - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_ai_,name,& - &a_err='psb_ensure_size',i_err=(/info/)) - - !$ isLoopValid = .false. - cycle - end if - - idxmap%loc_to_glob(nxt) = ip - else - !$ call OMP_unset_lock(ins_lck) - end if - - info = psb_success_ - - else - !$ call OMP_unset_lock(ins_lck) - - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='SearchInsKeyVal',i_err=(/info/)) - - isLoopValid = .false. - cycle - end if - end do - !$OMP END PARALLEL DO - - call idxmap%set_lc(ncol) - - if (.not. isLoopValid) then - goto 9999 + enddo end if - - else - do i = 1, is - ncol = idxmap%get_lc() - ip = idx(i) - if ((ip < 1 ).or.(ip>mglob)) then - idx(i) = -1 - cycle - endif - nxt = ncol + 1 - call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& - & idxmap%glb_lc,ncol) - if (lip < 0) then - call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) - lip = tlip - end if - - if (info >=0) then - if (nxt == lip) then - ncol = nxt - call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& - & pad=-1_psb_lpk_,addsz=laddsz) - if (info /= psb_success_) then - info=1 - ch_err='psb_ensure_size' - call psb_errpush(psb_err_from_subroutine_ai_,name,& - &a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) - goto 9999 - end if - idxmap%loc_to_glob(nxt) = ip - call idxmap%set_lc(ncol) - endif - info = psb_success_ - else - ch_err='SearchInsKeyVal' - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) - goto 9999 - end if - idx(i) = lip - info = psb_success_ - enddo end if end if - end if - if (use_openmp) then - !$ call OMP_destroy_lock(ins_lck) - end if + if (use_openmp) then + !$ call OMP_destroy_lock(ins_lck) + end if - else - ! Wrong state - idx = -1 - info = -1 + else + ! Wrong state + idx = -1 + info = -1 + end if end if - call psb_erractionrestore(err_act) return From 49d37911caa43599512a6a57974da83be5dd0ec9 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 10 Feb 2023 17:14:47 +0100 Subject: [PATCH 06/63] Work on psb_hash_map_mod --- ..._hash_map_mod.f90 => psb_hash_map_mod.F90} | 512 +++++++++--------- 1 file changed, 257 insertions(+), 255 deletions(-) rename base/modules/desc/{psb_hash_map_mod.f90 => psb_hash_map_mod.F90} (97%) diff --git a/base/modules/desc/psb_hash_map_mod.f90 b/base/modules/desc/psb_hash_map_mod.F90 similarity index 97% rename from base/modules/desc/psb_hash_map_mod.f90 rename to base/modules/desc/psb_hash_map_mod.F90 index 528450ae0..efb3ed10f 100644 --- a/base/modules/desc/psb_hash_map_mod.f90 +++ b/base/modules/desc/psb_hash_map_mod.F90 @@ -636,7 +636,9 @@ contains use psb_realloc_mod use psb_sort_mod use psb_penv_mod - !$ use omp_lib +#ifdef OPENMP + use omp_lib +#endif implicit none @@ -655,230 +657,12 @@ contains logical :: use_openmp = .false. logical, volatile :: isLoopValid - !$ integer(kind = OMP_lock_kind) :: ins_lck - - !$ use_openmp = .true. - - if (.true.) then - info = psb_success_ - name = 'hash_g2l_ins' - call psb_erractionsave(err_act) - - ctxt = idxmap%get_ctxt() - call psb_info(ctxt, me, np) - - is = size(idx) - - if (present(mask)) then - if (size(mask) < size(idx)) then - info = -1 - return - end if - end if - if (present(lidx)) then - if (size(lidx) < size(idx)) then - info = -1 - return - end if - end if - - - mglob = idxmap%get_gr() - nrow = idxmap%get_lr() - if (idxmap%is_bld()) then - - if (present(lidx)) then - if (present(mask)) then - do i = 1, is - ncol = idxmap%get_lc() - if (mask(i)) then - ip = idx(i) - if ((ip < 1 ).or.(ip>mglob) ) then - idx(i) = -1 - cycle - endif - call hash_inner_cnv(ip,lip,idxmap%hashvmask,& - & idxmap%hashv,idxmap%glb_lc,ncol) - if (lip < 0) then - tlip = lip - nxt = lidx(i) - if (nxt <= nrow) then - idx(i) = -1 - cycle - endif - call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) - if (info >=0) then - if (nxt == tlip) then - ncol = max(ncol,nxt) - call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& - & pad=-1_psb_lpk_,addsz=laddsz) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_ai_,name,& - &a_err='psb_ensure_size',i_err=(/info/)) - goto 9999 - end if - idxmap%loc_to_glob(nxt) = ip - call idxmap%set_lc(ncol) - endif - info = psb_success_ - else - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='SearchInsKeyVal',i_err=(/info/)) - goto 9999 - end if - end if - idx(i) = lip - info = psb_success_ - else - idx(i) = -1 - end if - enddo - - else if (.not.present(mask)) then - - do i = 1, is - ncol = idxmap%get_lc() - ip = idx(i) - if ((ip < 1 ).or.(ip>mglob)) then - idx(i) = -1 - cycle - endif - call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& - & idxmap%glb_lc,ncol) - if (lip < 0) then - nxt = lidx(i) - if (nxt <= nrow) then - idx(i) = -1 - cycle - endif - call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) - lip = tlip - - if (info >=0) then - if (nxt == lip) then - ncol = max(nxt,ncol) - call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-1_psb_lpk_,addsz=laddsz) - if (info /= psb_success_) then - info=1 - call psb_errpush(psb_err_from_subroutine_ai_,name,& - &a_err='psb_ensure_size',i_err=(/info/)) - goto 9999 - end if - idxmap%loc_to_glob(nxt) = ip - call idxmap%set_lc(ncol) - endif - info = psb_success_ - else - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='SearchInsKeyVal',i_err=(/info/)) - goto 9999 - end if - end if - idx(i) = lip - info = psb_success_ - enddo - - end if - - else if (.not.present(lidx)) then - - if (present(mask)) then - do i = 1, is - ncol = idxmap%get_lc() - if (mask(i)) then - ip = idx(i) - if ((ip < 1 ).or.(ip>mglob)) then - idx(i) = -1 - cycle - endif - nxt = ncol + 1 - call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& - & idxmap%glb_lc,ncol) - if (lip < 0) then - call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) - lip = tlip - end if - - if (info >=0) then - if (nxt == lip) then - ncol = nxt - call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& - & pad=-1_psb_lpk_,addsz=laddsz) - if (info /= psb_success_) then - info=1 - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='psb_ensure_size',i_err=(/info/)) - goto 9999 - end if - idxmap%loc_to_glob(nxt) = ip - call idxmap%set_lc(ncol) - endif - info = psb_success_ - else - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='SearchInsKeyVal',i_err=(/info/)) - goto 9999 - end if - idx(i) = lip - info = psb_success_ - else - idx(i) = -1 - end if - enddo - - else if (.not.present(mask)) then - - do i = 1, is - ncol = idxmap%get_lc() - ip = idx(i) - if ((ip < 1 ).or.(ip>mglob)) then - idx(i) = -1 - cycle - endif - nxt = ncol + 1 - call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& - & idxmap%glb_lc,ncol) - if (lip < 0) then - call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) - lip = tlip - end if - - if (info >=0) then - if (nxt == lip) then - ncol = nxt - call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& - & pad=-1_psb_lpk_,addsz=laddsz) - if (info /= psb_success_) then - info=1 - ch_err='psb_ensure_size' - call psb_errpush(psb_err_from_subroutine_ai_,name,& - &a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) - goto 9999 - end if - idxmap%loc_to_glob(nxt) = ip - call idxmap%set_lc(ncol) - endif - info = psb_success_ - else - ch_err='SearchInsKeyVal' - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) - goto 9999 - end if - idx(i) = lip - info = psb_success_ - enddo - - - end if - end if - else - ! Wrong state - idx = -1 - info = -1 - end if - else +#ifdef OPENMP + integer(kind = OMP_lock_kind) :: ins_lck +#endif + if (use_openmp) then +#ifdef OPENMP info = psb_success_ name = 'hash_g2l_ins' call psb_erractionsave(err_act) @@ -905,13 +689,12 @@ 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() - end if - + if (idxmap%is_bld()) then + + call OMP_init_lock(ins_lck) + isLoopValid = .true. + ncol = idxmap%get_lc() + if (present(lidx)) then if (present(mask)) then if (use_openmp) then @@ -947,7 +730,7 @@ contains ! We check again if the index is already in 'idxmap', this ! time inside a critical region (we assume that the index ! is often already existing). - !$ call OMP_set_lock(ins_lck) + call OMP_set_lock(ins_lck) call hash_inner_cnv(ip,lip,idxmap%hashvmask,& & idxmap%hashv,idxmap%glb_lc,ncol) ! Index not found @@ -962,7 +745,7 @@ contains if (nxt == tlip) then ncol = MAX(ncol,nxt) - !$ call OMP_unset_lock(ins_lck) + call OMP_unset_lock(ins_lck) call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& & pad=-1_psb_lpk_,addsz=laddsz) @@ -977,13 +760,13 @@ contains idxmap%loc_to_glob(nxt) = ip else - !$ call OMP_unset_lock(ins_lck) + call OMP_unset_lock(ins_lck) end if info = psb_success_ else - !$ call OMP_unset_lock(ins_lck) + call OMP_unset_lock(ins_lck) call psb_errpush(psb_err_from_subroutine_ai_,name,& & a_err='SearchInsKeyVal',i_err=(/info/)) @@ -992,7 +775,7 @@ contains cycle end if else - !$ call OMP_unset_lock(ins_lck) + call OMP_unset_lock(ins_lck) end if end if @@ -1056,7 +839,9 @@ contains end if enddo end if + else if (.not.present(mask)) then + if (use_openmp) then !$OMP PARALLEL DO default(none) schedule(STATIC) & !$OMP shared(name,is,idx,lidx,mglob,idxmap,ncol,nrow,ins_lck,laddsz) & @@ -1087,14 +872,14 @@ contains ! We check again if the index is already in 'idxmap', this ! time inside a critical region (we assume that the index ! is often already existing). - !$ call OMP_set_lock(ins_lck) + call OMP_set_lock(ins_lck) call hash_inner_cnv(ip,lip,idxmap%hashvmask,& & idxmap%hashv,idxmap%glb_lc,ncol) if (lip < 0) then ! Locking system to handle concurrent write/access. Under checking! call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) - !$ call OMP_unset_lock(ins_lck) + call OMP_unset_lock(ins_lck) if (info >= 0) then ! 'nxt' is not equal to 'tlip' when the key is already inside @@ -1103,7 +888,7 @@ contains if (nxt == tlip) then ncol = MAX(ncol,nxt) - !$ call OMP_unset_lock(ins_lck) + call OMP_unset_lock(ins_lck) ! Under checking! call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& @@ -1119,12 +904,12 @@ contains idxmap%loc_to_glob(nxt) = ip else - !$ call OMP_unset_lock(ins_lck) + call OMP_unset_lock(ins_lck) end if info = psb_success_ else - !$ call OMP_unset_lock(ins_lck) + call OMP_unset_lock(ins_lck) call psb_errpush(psb_err_from_subroutine_ai_,name,& & a_err='SearchInsKeyVal',i_err=(/info/)) @@ -1133,7 +918,7 @@ contains cycle end if else - !$ call OMP_unset_lock(ins_lck) + call OMP_unset_lock(ins_lck) end if end if @@ -1225,7 +1010,7 @@ contains ! We check again if the index is already in 'idxmap', this ! time inside a critical region (we assume that the index ! is often already existing). - !$ call OMP_set_lock(ins_lck) + call OMP_set_lock(ins_lck) call hash_inner_cnv(ip,lip,idxmap%hashvmask,& & idxmap%hashv,idxmap%glb_lc,ncol) @@ -1235,7 +1020,7 @@ contains call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) lip = tlip else - !$ call OMP_unset_lock(ins_lck) + call OMP_unset_lock(ins_lck) end if idx(i) = lip @@ -1249,7 +1034,7 @@ contains if (nxt == tlip) then ncol = MAX(ncol,nxt) - !$ call OMP_unset_lock(ins_lck) + call OMP_unset_lock(ins_lck) call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& & pad=-1_psb_lpk_,addsz=laddsz) @@ -1264,12 +1049,12 @@ contains idxmap%loc_to_glob(nxt) = ip else - !$ call OMP_unset_lock(ins_lck) + call OMP_unset_lock(ins_lck) end if info = psb_success_ else - !$ call OMP_unset_lock(ins_lck) + call OMP_unset_lock(ins_lck) call psb_errpush(psb_err_from_subroutine_ai_,name,& & a_err='SearchInsKeyVal',i_err=(/info/)) @@ -1360,7 +1145,7 @@ contains ! We check again if the index is already in 'idxmap', this ! time inside a critical region (we assume that the index ! is often already existing). - !$ call OMP_set_lock(ins_lck) + call OMP_set_lock(ins_lck) call hash_inner_cnv(ip,lip,idxmap%hashvmask,& & idxmap%hashv,idxmap%glb_lc,ncol) @@ -1370,7 +1155,7 @@ contains call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) lip = tlip else - !$ call OMP_unset_lock(ins_lck) + call OMP_unset_lock(ins_lck) end if idx(i) = lip @@ -1383,7 +1168,7 @@ contains ! to the existing mapping. if (nxt == tlip) then ncol = MAX(ncol,nxt) - !$ call OMP_unset_lock(ins_lck) + call OMP_unset_lock(ins_lck) call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& & pad=-1_psb_lpk_,addsz=laddsz) @@ -1392,19 +1177,19 @@ contains call psb_errpush(psb_err_from_subroutine_ai_,name,& &a_err='psb_ensure_size',i_err=(/info/)) - !$ isLoopValid = .false. + isLoopValid = .false. cycle end if idxmap%loc_to_glob(nxt) = ip else - !$ call OMP_unset_lock(ins_lck) + call OMP_unset_lock(ins_lck) end if info = psb_success_ else - !$ call OMP_unset_lock(ins_lck) + call OMP_unset_lock(ins_lck) call psb_errpush(psb_err_from_subroutine_ai_,name,& & a_err='SearchInsKeyVal',i_err=(/info/)) @@ -1466,10 +1251,227 @@ contains end if end if - if (use_openmp) then - !$ call OMP_destroy_lock(ins_lck) + call OMP_destroy_lock(ins_lck) + + else + ! Wrong state + idx = -1 + info = -1 + end if +#endif + else if (.not.use_openmp) then + info = psb_success_ + name = 'hash_g2l_ins' + call psb_erractionsave(err_act) + + ctxt = idxmap%get_ctxt() + call psb_info(ctxt, me, np) + + is = size(idx) + + if (present(mask)) then + if (size(mask) < size(idx)) then + info = -1 + return end if + end if + if (present(lidx)) then + if (size(lidx) < size(idx)) then + info = -1 + return + end if + end if + + + mglob = idxmap%get_gr() + nrow = idxmap%get_lr() + if (idxmap%is_bld()) then + + if (present(lidx)) then + if (present(mask)) then + do i = 1, is + ncol = idxmap%get_lc() + if (mask(i)) then + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob) ) then + idx(i) = -1 + cycle + endif + call hash_inner_cnv(ip,lip,idxmap%hashvmask,& + & idxmap%hashv,idxmap%glb_lc,ncol) + if (lip < 0) then + tlip = lip + nxt = lidx(i) + if (nxt <= nrow) then + idx(i) = -1 + cycle + endif + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + if (info >=0) then + if (nxt == tlip) then + ncol = max(ncol,nxt) + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& + & pad=-1_psb_lpk_,addsz=laddsz) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + &a_err='psb_ensure_size',i_err=(/info/)) + goto 9999 + end if + idxmap%loc_to_glob(nxt) = ip + call idxmap%set_lc(ncol) + endif + info = psb_success_ + else + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='SearchInsKeyVal',i_err=(/info/)) + goto 9999 + end if + end if + idx(i) = lip + info = psb_success_ + else + idx(i) = -1 + end if + enddo + + else if (.not.present(mask)) then + + do i = 1, is + ncol = idxmap%get_lc() + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle + endif + call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& + & idxmap%glb_lc,ncol) + if (lip < 0) then + nxt = lidx(i) + if (nxt <= nrow) then + idx(i) = -1 + cycle + endif + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + lip = tlip + + if (info >=0) then + if (nxt == lip) then + ncol = max(nxt,ncol) + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-1_psb_lpk_,addsz=laddsz) + if (info /= psb_success_) then + info=1 + call psb_errpush(psb_err_from_subroutine_ai_,name,& + &a_err='psb_ensure_size',i_err=(/info/)) + goto 9999 + end if + idxmap%loc_to_glob(nxt) = ip + call idxmap%set_lc(ncol) + endif + info = psb_success_ + else + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='SearchInsKeyVal',i_err=(/info/)) + goto 9999 + end if + end if + idx(i) = lip + info = psb_success_ + enddo + + end if + + else if (.not.present(lidx)) then + + if (present(mask)) then + do i = 1, is + ncol = idxmap%get_lc() + if (mask(i)) then + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle + endif + nxt = ncol + 1 + call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& + & idxmap%glb_lc,ncol) + if (lip < 0) then + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + lip = tlip + end if + + if (info >=0) then + if (nxt == lip) then + ncol = nxt + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& + & pad=-1_psb_lpk_,addsz=laddsz) + if (info /= psb_success_) then + info=1 + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='psb_ensure_size',i_err=(/info/)) + goto 9999 + end if + idxmap%loc_to_glob(nxt) = ip + call idxmap%set_lc(ncol) + endif + info = psb_success_ + else + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='SearchInsKeyVal',i_err=(/info/)) + goto 9999 + end if + idx(i) = lip + info = psb_success_ + else + idx(i) = -1 + end if + enddo + + else if (.not.present(mask)) then + + do i = 1, is + ncol = idxmap%get_lc() + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle + endif + nxt = ncol + 1 + call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& + & idxmap%glb_lc,ncol) + if (lip < 0) then + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + lip = tlip + end if + if (info >=0) then + if (nxt == lip) then + ncol = nxt + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& + & pad=-1_psb_lpk_,addsz=laddsz) + if (info /= psb_success_) then + info=1 + ch_err='psb_ensure_size' + call psb_errpush(psb_err_from_subroutine_ai_,name,& + &a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) + goto 9999 + end if + idxmap%loc_to_glob(nxt) = ip + call idxmap%set_lc(ncol) + endif + info = psb_success_ + else + ch_err='SearchInsKeyVal' + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) + goto 9999 + end if + idx(i) = lip + info = psb_success_ + enddo + + + end if + end if else ! Wrong state idx = -1 From bb4e80f647b1ad51f391313c193e6a5952faacfd Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 10 Feb 2023 17:57:56 +0100 Subject: [PATCH 07/63] Bit of cleanup in psb_hash_map_mod --- base/modules/desc/psb_hash_map_mod.F90 | 523 ++++++++----------------- 1 file changed, 172 insertions(+), 351 deletions(-) diff --git a/base/modules/desc/psb_hash_map_mod.F90 b/base/modules/desc/psb_hash_map_mod.F90 index efb3ed10f..e5ab6385d 100644 --- a/base/modules/desc/psb_hash_map_mod.F90 +++ b/base/modules/desc/psb_hash_map_mod.F90 @@ -690,164 +690,20 @@ contains nrow = idxmap%get_lr() if (idxmap%is_bld()) then - + call OMP_init_lock(ins_lck) isLoopValid = .true. ncol = idxmap%get_lc() - + if (present(lidx)) then if (present(mask)) then - if (use_openmp) then - !$OMP PARALLEL DO default(none) schedule(STATIC) & - !$OMP shared(name,is,mask,lidx,idx,mglob,idxmap,ncol,nrow,ins_lck,laddsz) & - !$OMP private(i,ip,lip,tlip,nxt,info) & - !$OMP reduction(.AND.:isLoopValid) - do i = 1, is - - if (mask(i)) then - ip = idx(i) - - if ((ip < 1 ).or.(ip>mglob)) then - idx(i) = -1 - cycle - endif - - ! At first, we check the index presence in 'idxmap'. Usually - ! the index is found. If it is not found, we repeat the checking, - ! but inside a critical region. - call hash_inner_cnv(ip,lip,idxmap%hashvmask,& - & idxmap%hashv,idxmap%glb_lc,ncol) - - if (lip < 0) then - tlip = lip - nxt = lidx(i) - - if (nxt <= nrow) then - idx(i) = -1 - cycle - endif - - ! We check again if the index is already in 'idxmap', this - ! time inside a critical region (we assume that the index - ! is often already existing). - call OMP_set_lock(ins_lck) - call hash_inner_cnv(ip,lip,idxmap%hashvmask,& - & idxmap%hashv,idxmap%glb_lc,ncol) - ! Index not found - if (lip < 0) then - ! Locking system to handle concurrent hashmap read/write. - call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) - - if (info >= 0) then - ! 'nxt' is not equal to 'tlip' when the key is already inside - ! the hash map. In that case 'tlip' is the value corresponding - ! to the existing mapping. - if (nxt == tlip) then - - ncol = MAX(ncol,nxt) - call OMP_unset_lock(ins_lck) - - call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& - & pad=-1_psb_lpk_,addsz=laddsz) - - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_ai_,name,& - &a_err='psb_ensure_size',i_err=(/info/)) - - isLoopValid = .false. - cycle - end if - - idxmap%loc_to_glob(nxt) = ip - else - call OMP_unset_lock(ins_lck) - end if - - info = psb_success_ - - else - call OMP_unset_lock(ins_lck) - - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='SearchInsKeyVal',i_err=(/info/)) - - isLoopValid = .false. - cycle - end if - else - call OMP_unset_lock(ins_lck) - end if - end if - - idx(i) = lip - info = psb_success_ - else - idx(i) = -1 - end if - end do - !$OMP END PARALLEL DO - - call idxmap%set_lc(ncol) - - if (.not. isLoopValid) then - goto 9999 - end if - - else - do i = 1, is - ncol = idxmap%get_lc() - if (mask(i)) then - ip = idx(i) - if ((ip < 1 ).or.(ip>mglob) ) then - idx(i) = -1 - cycle - endif - call hash_inner_cnv(ip,lip,idxmap%hashvmask,& - & idxmap%hashv,idxmap%glb_lc,ncol) - if (lip < 0) then - tlip = lip - nxt = lidx(i) - if (nxt <= nrow) then - idx(i) = -1 - cycle - endif - call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) - if (info >=0) then - if (nxt == tlip) then - ncol = max(ncol,nxt) - call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& - & pad=-1_psb_lpk_,addsz=laddsz) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_ai_,name,& - &a_err='psb_ensure_size',i_err=(/info/)) - goto 9999 - end if - idxmap%loc_to_glob(nxt) = ip - call idxmap%set_lc(ncol) - endif - info = psb_success_ - else - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='SearchInsKeyVal',i_err=(/info/)) - goto 9999 - end if - end if - idx(i) = lip - info = psb_success_ - else - idx(i) = -1 - end if - enddo - end if - - else if (.not.present(mask)) then + !$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 (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 + if (mask(i)) then ip = idx(i) if ((ip < 1 ).or.(ip>mglob)) then @@ -855,14 +711,15 @@ contains cycle endif - ! 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. call hash_inner_cnv(ip,lip,idxmap%hashvmask,& & idxmap%hashv,idxmap%glb_lc,ncol) if (lip < 0) then tlip = lip - nxt = lidx(i) + nxt = lidx(i) if (nxt <= nrow) then idx(i) = -1 @@ -872,14 +729,13 @@ contains ! We check again if the index is already in 'idxmap', this ! time inside a critical region (we assume that the index ! is often already existing). - call OMP_set_lock(ins_lck) + call OMP_set_lock(ins_lck) call hash_inner_cnv(ip,lip,idxmap%hashvmask,& & idxmap%hashv,idxmap%glb_lc,ncol) - + ! Index not found if (lip < 0) then - ! Locking system to handle concurrent write/access. Under checking! + ! Locking system to handle concurrent hashmap read/write. call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) - call OMP_unset_lock(ins_lck) if (info >= 0) then ! 'nxt' is not equal to 'tlip' when the key is already inside @@ -890,7 +746,6 @@ contains ncol = MAX(ncol,nxt) call OMP_unset_lock(ins_lck) - ! Under checking! call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& & pad=-1_psb_lpk_,addsz=laddsz) @@ -904,10 +759,11 @@ contains idxmap%loc_to_glob(nxt) = ip else - call OMP_unset_lock(ins_lck) + call OMP_unset_lock(ins_lck) end if info = psb_success_ + else call OMP_unset_lock(ins_lck) @@ -924,108 +780,58 @@ contains 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 + end do + !$OMP END PARALLEL DO - else - do i = 1, is - ncol = idxmap%get_lc() - ip = idx(i) - if ((ip < 1 ).or.(ip>mglob)) then - idx(i) = -1 - cycle - endif - call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& - & idxmap%glb_lc,ncol) - if (lip < 0) then - nxt = lidx(i) - if (nxt <= nrow) then - idx(i) = -1 - cycle - endif - call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) - lip = tlip + call idxmap%set_lc(ncol) - 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 + if (.not. isLoopValid) then + goto 9999 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 - - ncol = idxmap%get_lc() - info = 0 - if (mask(i)) then - ip = idx(i) - - if ((ip < 1 ).or.(ip>mglob)) then - idx(i) = -1 - cycle - endif + else if (.not.present(mask)) then - nxt = ncol + 1 - ! At first, we check the index presence in 'idxmap'. Usually - ! the index is found. If it is not found, we repeat the checking, - ! but inside a critical region. - call hash_inner_cnv(ip,lip,idxmap%hashvmask,& - & idxmap%hashv,idxmap%glb_lc,ncol) + !$OMP PARALLEL DO default(none) schedule(STATIC) & + !$OMP shared(name,is,idx,lidx,mglob,idxmap,ncol,nrow,ins_lck,laddsz) & + !$OMP private(i,ip,lip,tlip,nxt,info) & + !$OMP reduction(.AND.:isLoopValid) + do i = 1, is + ip = idx(i) - if (lip < 0) then + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle + endif - ! We check again if the index is already in 'idxmap', this - ! 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 + ! In OMP logic the index research limit is turned off. It is + ! a correct way to fit the subroutine? + call hash_inner_cnv(ip,lip,idxmap%hashvmask,& + & idxmap%hashv,idxmap%glb_lc,ncol) - idx(i) = lip - info = psb_success_ - end if + 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 + ! Locking system to handle concurrent write/access. Under checking! + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + call OMP_unset_lock(ins_lck) if (info >= 0) then ! 'nxt' is not equal to 'tlip' when the key is already inside @@ -1036,6 +842,7 @@ contains ncol = MAX(ncol,nxt) call OMP_unset_lock(ins_lck) + ! Under checking! call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& & pad=-1_psb_lpk_,addsz=laddsz) @@ -1062,71 +869,36 @@ contains isLoopValid = .false. cycle 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 end if - else - do i = 1, is - ncol = idxmap%get_lc() - if (mask(i)) then - ip = idx(i) - if ((ip < 1 ).or.(ip>mglob)) then - idx(i) = -1 - cycle - endif - 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 + idx(i) = lip + info = psb_success_ + end do + !$OMP END PARALLEL DO - if (info >=0) then - if (nxt == lip) then - ncol = nxt - call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& - & pad=-1_psb_lpk_,addsz=laddsz) - if (info /= psb_success_) then - info=1 - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='psb_ensure_size',i_err=(/info/)) - goto 9999 - end if - idxmap%loc_to_glob(nxt) = ip - call idxmap%set_lc(ncol) - endif - info = psb_success_ - else - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='SearchInsKeyVal',i_err=(/info/)) - goto 9999 - end if - idx(i) = lip - info = psb_success_ - else - idx(i) = -1 - end if - enddo + call idxmap%set_lc(ncol) + + 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,mglob,idxmap,ncol,nrow,ins_lck,laddsz) & - !$OMP private(i,ip,lip,tlip,nxt,info) & - !$OMP reduction(.AND.:isLoopValid) - do i = 1, is + end if + + else if (.not.present(lidx)) then + + if (present(mask)) then + !$OMP PARALLEL DO default(none) schedule(STATIC) & + !$OMP shared(name,is,idx,mask,mglob,idxmap,ncol,nrow,ins_lck,laddsz) & + !$OMP private(i,ip,lip,tlip,nxt,info) & + !$OMP reduction(.AND.:isLoopValid) + do i = 1, is + + ncol = idxmap%get_lc() + info = 0 + if (mask(i)) then ip = idx(i) if ((ip < 1 ).or.(ip>mglob)) then @@ -1134,6 +906,7 @@ contains cycle endif + nxt = ncol + 1 ! At first, we check the index presence in 'idxmap'. Usually ! the index is found. If it is not found, we repeat the checking, ! but inside a critical region. @@ -1167,6 +940,7 @@ contains ! the hash map. In that case 'tlip' is the value corresponding ! to the existing mapping. if (nxt == tlip) then + ncol = MAX(ncol,nxt) call OMP_unset_lock(ins_lck) @@ -1187,7 +961,6 @@ contains end if info = psb_success_ - else call OMP_unset_lock(ins_lck) @@ -1197,57 +970,105 @@ contains isLoopValid = .false. cycle 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 + end do + !$OMP END PARALLEL DO - else - do i = 1, is - ncol = idxmap%get_lc() - ip = idx(i) - if ((ip < 1 ).or.(ip>mglob)) then - idx(i) = -1 - cycle - endif - nxt = ncol + 1 - call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& - & idxmap%glb_lc,ncol) + call idxmap%set_lc(ncol) + + if (.not. isLoopValid) then + goto 9999 + end if + + else if (.not.present(mask)) then + !$OMP PARALLEL DO default(none) schedule(STATIC) & + !$OMP shared(name,is,idx,mglob,idxmap,ncol,nrow,ins_lck,laddsz) & + !$OMP private(i,ip,lip,tlip,nxt,info) & + !$OMP reduction(.AND.:isLoopValid) + do i = 1, is + + ip = idx(i) + + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle + endif + + ! At first, we check the index presence in 'idxmap'. Usually + ! the index is found. If it is not found, we repeat the checking, + ! but inside a critical region. + call hash_inner_cnv(ip,lip,idxmap%hashvmask,& + & idxmap%hashv,idxmap%glb_lc,ncol) + + if (lip < 0) then + + ! We check again if the index is already in 'idxmap', this + ! time inside a critical region (we assume that the index + ! is often already existing). + call OMP_set_lock(ins_lck) + call hash_inner_cnv(ip,lip,idxmap%hashvmask,& + & idxmap%hashv,idxmap%glb_lc,ncol) + + ! Index not found if (lip < 0) then + ! Locking system to handle concurrent hashmap write/access. call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) lip = tlip + else + call OMP_unset_lock(ins_lck) end if - if (info >=0) then - if (nxt == lip) then - ncol = nxt - call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& - & pad=-1_psb_lpk_,addsz=laddsz) - if (info /= psb_success_) then - info=1 - ch_err='psb_ensure_size' - call psb_errpush(psb_err_from_subroutine_ai_,name,& - &a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) - goto 9999 - end if - idxmap%loc_to_glob(nxt) = ip - call idxmap%set_lc(ncol) - endif - info = psb_success_ + idx(i) = lip + info = psb_success_ + end if + + if (info >= 0) then + ! 'nxt' is not equal to 'tlip' when the key is already inside + ! the hash map. In that case 'tlip' is the value corresponding + ! to the existing mapping. + if (nxt == tlip) then + ncol = MAX(ncol,nxt) + call OMP_unset_lock(ins_lck) + + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& + & pad=-1_psb_lpk_,addsz=laddsz) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + &a_err='psb_ensure_size',i_err=(/info/)) + + isLoopValid = .false. + cycle + end if + + idxmap%loc_to_glob(nxt) = ip else - 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 + call OMP_unset_lock(ins_lck) end if - idx(i) = lip + info = psb_success_ - enddo + + else + call OMP_unset_lock(ins_lck) + + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='SearchInsKeyVal',i_err=(/info/)) + + isLoopValid = .false. + cycle + end if + end do + !$OMP END PARALLEL DO + + call idxmap%set_lc(ncol) + + if (.not. isLoopValid) then + goto 9999 end if + end if end if From ed7862a848f5b0c220baa011845c82e5d48f9ced Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 14 Feb 2023 13:04:58 +0100 Subject: [PATCH 08/63] Fix OpenMP g2lv1_ins --- base/modules/desc/psb_hash_map_mod.F90 | 405 ++++++++++--------------- 1 file changed, 168 insertions(+), 237 deletions(-) diff --git a/base/modules/desc/psb_hash_map_mod.F90 b/base/modules/desc/psb_hash_map_mod.F90 index e5ab6385d..5f32b2e13 100644 --- a/base/modules/desc/psb_hash_map_mod.F90 +++ b/base/modules/desc/psb_hash_map_mod.F90 @@ -654,88 +654,97 @@ contains type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: me, np character(len=20) :: name,ch_err - logical :: use_openmp = .false. - - logical, volatile :: isLoopValid + logical, allocatable :: mask_(:) + logical :: use_openmp = .true. #ifdef OPENMP integer(kind = OMP_lock_kind) :: ins_lck #endif + logical, volatile :: isLoopValid + info = psb_success_ + name = 'hash_g2l_ins' + call psb_erractionsave(err_act) - if (use_openmp) then -#ifdef OPENMP - info = psb_success_ - name = 'hash_g2l_ins' - call psb_erractionsave(err_act) - - ctxt = idxmap%get_ctxt() - call psb_info(ctxt, me, np) + ctxt = idxmap%get_ctxt() + call psb_info(ctxt, me, np) - is = size(idx) + is = size(idx) - if (present(mask)) then - if (size(mask) < size(idx)) then - info = -1 - return - end if + if (present(mask)) then + if (size(mask) < size(idx)) then + info = -1 + return end if + end if - if (present(lidx)) then - if (size(lidx) < size(idx)) then - info = -1 - return - end if + if (present(lidx)) then + if (size(lidx) < size(idx)) then + info = -1 + return end if + end if + + mglob = idxmap%get_gr() + nrow = idxmap%get_lr() - mglob = idxmap%get_gr() - nrow = idxmap%get_lr() + if (use_openmp) then +#ifdef OPENMP + call OMP_init_lock(ins_lck) if (idxmap%is_bld()) then - call OMP_init_lock(ins_lck) isLoopValid = .true. ncol = idxmap%get_lc() + if (present(mask)) then + !write(0,*) 'present mask' + mask_ = mask + else + allocate(mask_(size(idx))) + mask_ = .true. + end if if (present(lidx)) then + !write(0,*) 'present lidx' if (present(mask)) then - !$OMP PARALLEL DO default(none) schedule(STATIC) & - !$OMP shared(name,is,mask,lidx,idx,mglob,idxmap,ncol,nrow,ins_lck,laddsz) & + + !$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) + !$OMP reduction(.AND.:isLoopValid) do i = 1, is - + info = 0 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) ! At first, we check the index presence in 'idxmap'. Usually ! the index is found. If it is not found, we repeat the checking, ! but inside a critical region. call hash_inner_cnv(ip,lip,idxmap%hashvmask,& & idxmap%hashv,idxmap%glb_lc,ncol) - if (lip < 0) then - tlip = lip - nxt = lidx(i) - - if (nxt <= nrow) then - idx(i) = -1 - cycle - endif + 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) + ncol = idxmap%get_lc() + nxt = lidx(i) call hash_inner_cnv(ip,lip,idxmap%hashvmask,& & idxmap%hashv,idxmap%glb_lc,ncol) - ! Index not found - if (lip < 0) then - ! Locking system to handle concurrent hashmap read/write. + + 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 ! 'nxt' is not equal to 'tlip' when the key is already inside @@ -744,7 +753,6 @@ 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) @@ -754,84 +762,68 @@ contains &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) end if + else + idx(i) = lip end if - - idx(i) = lip - info = psb_success_ else idx(i) = -1 end if + end do !$OMP END PARALLEL DO - call idxmap%set_lc(ncol) - if (.not. isLoopValid) then goto 9999 end if + else - - else if (.not.present(mask)) 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) + !$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 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. 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 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) + 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 - ! Locking system to handle concurrent write/access. Under checking! + if (lip > 0) then + idx(i) = lip + else if (lip < 0) then call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) - call OMP_unset_lock(ins_lck) + lip = tlip if (info >= 0) then ! 'nxt' is not equal to 'tlip' when the key is already inside @@ -840,9 +832,7 @@ contains 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) @@ -851,62 +841,48 @@ contains &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) 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 end if - end if - else if (.not.present(lidx)) then - - if (present(mask)) then - !$OMP PARALLEL DO default(none) schedule(STATIC) & - !$OMP shared(name,is,idx,mask,mglob,idxmap,ncol,nrow,ins_lck,laddsz) & + !write(0,*) 'not present lidx' + 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) do i = 1, is - - ncol = idxmap%get_lc() info = 0 if (mask(i)) then ip = idx(i) - if ((ip < 1 ).or.(ip>mglob)) then idx(i) = -1 cycle endif + call OMP_set_lock(ins_lck) + ncol = idxmap%get_lc() + call OMP_unset_lock(ins_lck) - nxt = ncol + 1 ! At first, we check the index presence in 'idxmap'. Usually ! the index is found. If it is not found, we repeat the checking, ! but inside a critical region. @@ -914,198 +890,153 @@ contains & 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). - call OMP_set_lock(ins_lck) + ! is often already existing, so this lock is relatively rare). + ncol = idxmap%get_lc() + nxt = ncol + 1 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. + 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 - 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 + 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) + ncol = MAX(ncol,nxt) - call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& - & pad=-1_psb_lpk_,addsz=laddsz) + 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/)) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + &a_err='psb_ensure_size',i_err=(/info/)) - isLoopValid = .false. - cycle + isLoopValid = .false. + idx(i) = -1 + else + idx(i) = lip + idxmap%loc_to_glob(nxt) = ip + call idxmap%set_lc(ncol) + end if + end if + else + idx(i) = -1 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) = lip end if - else idx(i) = -1 end if + end do !$OMP END PARALLEL DO - call idxmap%set_lc(ncol) - if (.not. isLoopValid) then goto 9999 end if - - else if (.not.present(mask)) then - !$OMP PARALLEL DO default(none) schedule(STATIC) & - !$OMP shared(name,is,idx,mglob,idxmap,ncol,nrow,ins_lck,laddsz) & + 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 reduction(.AND.:isLoopValid) do i = 1, is - + info = 0 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). - call OMP_set_lock(ins_lck) + ncol = idxmap%get_lc() + nxt = ncol + 1 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. + 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 - 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 - 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) + ncol = MAX(ncol,nxt) - call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& - & pad=-1_psb_lpk_,addsz=laddsz) + 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/)) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + &a_err='psb_ensure_size',i_err=(/info/)) - isLoopValid = .false. - cycle + isLoopValid = .false. + idx(i) = -1 + else + idx(i) = lip + idxmap%loc_to_glob(nxt) = ip + call idxmap%set_lc(ncol) + end if + end if + else + idx(i) = -1 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) = lip end if + end do !$OMP END PARALLEL DO - call idxmap%set_lc(ncol) - if (.not. isLoopValid) then goto 9999 end if end if end if - - call OMP_destroy_lock(ins_lck) - else ! Wrong state idx = -1 info = -1 end if + call OMP_destroy_lock(ins_lck) + #endif else if (.not.use_openmp) then - info = psb_success_ - name = 'hash_g2l_ins' - call psb_erractionsave(err_act) - - ctxt = idxmap%get_ctxt() - call psb_info(ctxt, me, np) - is = size(idx) - - if (present(mask)) then - if (size(mask) < size(idx)) then - info = -1 - return - end if - end if - if (present(lidx)) then - if (size(lidx) < size(idx)) then - info = -1 - return - end if - end if - - - mglob = idxmap%get_gr() - nrow = idxmap%get_lr() if (idxmap%is_bld()) then if (present(lidx)) then @@ -1205,14 +1136,14 @@ contains if (present(mask)) then do i = 1, is - ncol = idxmap%get_lc() if (mask(i)) then - ip = idx(i) + 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 From c05b32c20219fa613fe94064d2cb9cba5057abd4 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Wed, 29 Mar 2023 14:41:35 +0200 Subject: [PATCH 09/63] Reset status for csr_impl. --- base/internals/psi_bld_tmphalo.f90 | 1 + base/modules/desc/psb_hash_map_mod.F90 | 2 +- base/modules/desc/psb_hash_mod.F90 | 26 +++++++++------ base/serial/impl/psb_c_csr_impl.F90 | 44 ++++++++++++++++++-------- base/serial/impl/psb_d_csr_impl.F90 | 44 ++++++++++++++++++-------- base/serial/impl/psb_s_csr_impl.F90 | 44 ++++++++++++++++++-------- base/serial/impl/psb_z_csr_impl.F90 | 44 ++++++++++++++++++-------- 7 files changed, 139 insertions(+), 66 deletions(-) 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/desc/psb_hash_map_mod.F90 b/base/modules/desc/psb_hash_map_mod.F90 index 5f32b2e13..82e1f012b 100644 --- a/base/modules/desc/psb_hash_map_mod.F90 +++ b/base/modules/desc/psb_hash_map_mod.F90 @@ -655,7 +655,7 @@ contains integer(psb_ipk_) :: me, np character(len=20) :: name,ch_err logical, allocatable :: mask_(:) - logical :: use_openmp = .true. + logical :: use_openmp = .false. #ifdef OPENMP integer(kind = OMP_lock_kind) :: ins_lck #endif diff --git a/base/modules/desc/psb_hash_mod.F90 b/base/modules/desc/psb_hash_mod.F90 index 42911e3ff..0c6826705 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 @@ -409,6 +409,7 @@ contains info = HashDuplicate return end if + !$OMP CRITICAL if (hash%table(hk,1) == HashFreeEntry) then if (hash%nk == hash%hsize -1) then ! @@ -420,19 +421,22 @@ 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 + !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 (info /= HashOk) return + if (val > 0) return hk = hk - hd if (hk < 0) hk = hk + hsize end do @@ -448,7 +452,7 @@ contains info = HashOK hsize = hash%hsize hmask = hash%hmask - + hk = iand(psb_hashval(key),hmask) if (hk == 0) then hd = 1 @@ -460,7 +464,7 @@ contains info = HashOutOfMemory return end if - + val = -1 hash%nsrch = hash%nsrch + 1 do hash%nacc = hash%nacc + 1 @@ -469,6 +473,7 @@ contains info = HashDuplicate return end if + !$OMP CRITICAL if (hash%table(hk,1) == HashFreeEntry) then if (hash%nk == hash%hsize -1) then ! @@ -480,19 +485,22 @@ 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 + !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 (info /= HashOk) return + if (val > 0) return hk = hk - hd if (hk < 0) hk = hk + hsize end do diff --git a/base/serial/impl/psb_c_csr_impl.F90 b/base/serial/impl/psb_c_csr_impl.F90 index fa5f2edf7..a78691368 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 @@ -2862,6 +2874,8 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='c_cp_csr_from_coo' + logical :: use_openmp = .false. + #if defined(OPENMP) integer(psb_ipk_), allocatable :: sum(:) integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s,j @@ -2983,21 +2997,22 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) !$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 + + 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 #endif call a%set_host() - + + end subroutine psb_c_cp_csr_from_coo @@ -3113,6 +3128,7 @@ 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. #if defined(OPENMP) integer(psb_ipk_), allocatable :: sum(:) @@ -3120,7 +3136,6 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) integer(psb_ipk_) :: nxt_val,old_val,saved_elem #endif - info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -3214,6 +3229,7 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) !$OMP END PARALLEL #else + do k=1,nza i = itemp(k) a%irp(i) = a%irp(i) + 1 diff --git a/base/serial/impl/psb_d_csr_impl.F90 b/base/serial/impl/psb_d_csr_impl.F90 index faf422ae3..a2ddad30e 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 @@ -2862,6 +2874,8 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='d_cp_csr_from_coo' + logical :: use_openmp = .false. + #if defined(OPENMP) integer(psb_ipk_), allocatable :: sum(:) integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s,j @@ -2983,21 +2997,22 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) !$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 + + 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 #endif call a%set_host() - + + end subroutine psb_d_cp_csr_from_coo @@ -3113,6 +3128,7 @@ 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. #if defined(OPENMP) integer(psb_ipk_), allocatable :: sum(:) @@ -3120,7 +3136,6 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) integer(psb_ipk_) :: nxt_val,old_val,saved_elem #endif - info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -3214,6 +3229,7 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) !$OMP END PARALLEL #else + do k=1,nza i = itemp(k) a%irp(i) = a%irp(i) + 1 diff --git a/base/serial/impl/psb_s_csr_impl.F90 b/base/serial/impl/psb_s_csr_impl.F90 index 446e67910..a8c67c10d 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 @@ -2862,6 +2874,8 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='s_cp_csr_from_coo' + logical :: use_openmp = .false. + #if defined(OPENMP) integer(psb_ipk_), allocatable :: sum(:) integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s,j @@ -2983,21 +2997,22 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) !$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 + + 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 #endif call a%set_host() - + + end subroutine psb_s_cp_csr_from_coo @@ -3113,6 +3128,7 @@ 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. #if defined(OPENMP) integer(psb_ipk_), allocatable :: sum(:) @@ -3120,7 +3136,6 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) integer(psb_ipk_) :: nxt_val,old_val,saved_elem #endif - info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -3214,6 +3229,7 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) !$OMP END PARALLEL #else + do k=1,nza i = itemp(k) a%irp(i) = a%irp(i) + 1 diff --git a/base/serial/impl/psb_z_csr_impl.F90 b/base/serial/impl/psb_z_csr_impl.F90 index 5ec579d51..6344b2683 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 @@ -2862,6 +2874,8 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='z_cp_csr_from_coo' + logical :: use_openmp = .false. + #if defined(OPENMP) integer(psb_ipk_), allocatable :: sum(:) integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s,j @@ -2983,21 +2997,22 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) !$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 + + 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 #endif call a%set_host() - + + end subroutine psb_z_cp_csr_from_coo @@ -3113,6 +3128,7 @@ 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. #if defined(OPENMP) integer(psb_ipk_), allocatable :: sum(:) @@ -3120,7 +3136,6 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) integer(psb_ipk_) :: nxt_val,old_val,saved_elem #endif - info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -3214,6 +3229,7 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) !$OMP END PARALLEL #else + do k=1,nza i = itemp(k) a%irp(i) = a%irp(i) + 1 From e6a70410e05db64a8bc641c232e6a8e2c72dd644 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Thu, 30 Mar 2023 15:50:21 +0200 Subject: [PATCH 10/63] Make sure to use install -p --- configure | 2 +- configure.ac | 2 +- install-sh | 692 ++++++++++++++++++++++++++++++++++++--------------- 3 files changed, 493 insertions(+), 203 deletions(-) diff --git a/configure b/configure index 9e371ab9c..97b3eb794 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 diff --git a/configure.ac b/configure.ac index 60191cdbf..d9923a6ec 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";; 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: From 98945f36b5131107a2ebe81ffedda78443b808ba Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 31 Mar 2023 13:37:20 +0200 Subject: [PATCH 11/63] Fix nrm2 with overlap --- base/psblas/psb_cnrm2.f90 | 6 +++--- base/psblas/psb_dnrm2.f90 | 6 +++--- base/psblas/psb_snrm2.f90 | 6 +++--- base/psblas/psb_znrm2.f90 | 6 +++--- 4 files changed, 12 insertions(+), 12 deletions(-) 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 From 0f1603a2e959c18d9365b228de02db9eb063bc13 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Thu, 13 Apr 2023 16:40:29 +0200 Subject: [PATCH 12/63] The current version of test/omp seems to be working. To be completed --- base/modules/desc/psb_hash_map_mod.F90 | 30 +- base/serial/impl/psb_d_coo_impl.F90 | 38 +- base/tools/psb_dspins.F90 | 35 +- test/omp/Makefile | 56 ++ test/omp/psb_tomp.F90 | 1062 ++++++++++++++++++++++++ test/pargen/psb_d_pde3d.F90 | 1 + 6 files changed, 1193 insertions(+), 29 deletions(-) create mode 100644 test/omp/Makefile create mode 100644 test/omp/psb_tomp.F90 diff --git a/base/modules/desc/psb_hash_map_mod.F90 b/base/modules/desc/psb_hash_map_mod.F90 index 82e1f012b..af9cdf61d 100644 --- a/base/modules/desc/psb_hash_map_mod.F90 +++ b/base/modules/desc/psb_hash_map_mod.F90 @@ -1036,7 +1036,12 @@ contains #endif else if (.not.use_openmp) then - +#ifdef OPENMP + ! $ omp parallel + ! $ omp critical + !write(0,*) 'In cnv: ',omp_get_num_threads() +#endif + isLoopValid = .true. if (idxmap%is_bld()) then if (present(lidx)) then @@ -1067,7 +1072,7 @@ contains if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_ai_,name,& &a_err='psb_ensure_size',i_err=(/info/)) - goto 9999 + isLoopValid = .false. end if idxmap%loc_to_glob(nxt) = ip call idxmap%set_lc(ncol) @@ -1076,7 +1081,7 @@ contains else call psb_errpush(psb_err_from_subroutine_ai_,name,& & a_err='SearchInsKeyVal',i_err=(/info/)) - goto 9999 + isLoopValid = .false. end if end if idx(i) = lip @@ -1114,7 +1119,7 @@ contains info=1 call psb_errpush(psb_err_from_subroutine_ai_,name,& &a_err='psb_ensure_size',i_err=(/info/)) - goto 9999 + isLoopValid = .false. end if idxmap%loc_to_glob(nxt) = ip call idxmap%set_lc(ncol) @@ -1123,7 +1128,7 @@ contains else call psb_errpush(psb_err_from_subroutine_ai_,name,& & a_err='SearchInsKeyVal',i_err=(/info/)) - goto 9999 + isLoopValid = .false. end if end if idx(i) = lip @@ -1160,7 +1165,7 @@ contains info=1 call psb_errpush(psb_err_from_subroutine_ai_,name,& & a_err='psb_ensure_size',i_err=(/info/)) - goto 9999 + isLoopValid = .false. end if idxmap%loc_to_glob(nxt) = ip call idxmap%set_lc(ncol) @@ -1169,7 +1174,7 @@ 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_ @@ -1205,7 +1210,8 @@ contains ch_err='psb_ensure_size' call psb_errpush(psb_err_from_subroutine_ai_,name,& &a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) - goto 9999 + isLoopValid = .false. + end if idxmap%loc_to_glob(nxt) = ip call idxmap%set_lc(ncol) @@ -1215,7 +1221,7 @@ contains 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 + isLoopValid = .false. end if idx(i) = lip info = psb_success_ @@ -1229,6 +1235,12 @@ contains idx = -1 info = -1 end if +#ifdef OPENMP + ! $ omp end critical + ! $ omp end parallel + +#endif + if (.not. isLoopValid) goto 9999 end if call psb_erractionrestore(err_act) return diff --git a/base/serial/impl/psb_d_coo_impl.F90 b/base/serial/impl/psb_d_coo_impl.F90 index 24b486e22..f4f4f0dc3 100644 --- a/base/serial/impl/psb_d_coo_impl.F90 +++ b/base/serial/impl/psb_d_coo_impl.F90 @@ -2818,6 +2818,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 @@ -2829,7 +2832,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, debug_level, debug_unit, nzaold info = psb_success_ debug_unit = psb_get_debug_unit() @@ -2862,9 +2865,11 @@ 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 + + !$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))) @@ -2872,16 +2877,23 @@ 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) +#if defined(OPENMP) + !write(0,*) 'From thread ',omp_get_thread_num(),nzaold,nz,nza,a%get_nzeros() +#endif 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() @@ -2933,9 +2945,9 @@ contains ! the serial version: each element is stored in data ! structures but the invalid ones are stored as '-1' values. ! These values will be filtered in a future fixing process. - !$OMP PARALLEL DO default(none) schedule(STATIC) & - !$OMP shared(nz,imin,imax,jmin,jmax,ia,ja,val,ia1,ia2,aspk,nza) & - !$OMP private(ir,ic,i) + ! $ OMP PARALLEL DO default(none) schedule(STATIC) & + ! $ OMP shared(nz,imin,imax,jmin,jmax,ia,ja,val,ia1,ia2,aspk,nza) & + ! $ OMP private(ir,ic,i) do i=1,nz ir = ia(i) ic = ja(i) @@ -2949,9 +2961,9 @@ contains aspk(nza+i) = -1 end if end do - !$OMP END PARALLEL DO + ! $OMP END PARALLEL DO - nza = nza + nz + !nza = nza + nz #else do i=1, nz ir = ia(i) diff --git a/base/tools/psb_dspins.F90 b/base/tools/psb_dspins.F90 index 2a70ab83a..9c4f137f1 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... @@ -82,7 +85,9 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) ctxt = desc_a%get_context() call psb_info(ctxt, me, np) - +#if defined(OPENMP) + !write(0,*) name,omp_get_num_threads(),omp_get_thread_num() +#endif if (nz < 0) then info = 1111 call psb_errpush(info,name) @@ -131,15 +136,26 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) & a_err='allocate',i_err=(/info/)) goto 9999 end if - - call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) +#if defined(OPENMP) + !$omp parallel private(ila,jla,nrow,ncol) +#endif + + call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) +#if defined(OPENMP) + !$omp critical +#endif if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& & mask=(ila(1:nz)>0)) - +!!$ write(0,*) omp_get_thread_num(),'Check g2l: ',ila(1:nz),':',& +!!$ & jla(1:nz),':',ja(1:nz) +#if defined(OPENMP) + !$omp end critical +#endif + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_ai_,name,& & a_err='psb_cdins',i_err=(/info/)) - goto 9999 + !goto 9999 end if nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() @@ -149,7 +165,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 @@ -175,8 +191,13 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) else info = psb_err_invalid_a_and_cd_state_ call psb_errpush(info,name) - goto 9999 + !goto 9999 end if + +#if defined(OPENMP) + !$omp end parallel +#endif + endif else if (desc_a%is_asb()) then 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..8681c3965 --- /dev/null +++ b/test/omp/psb_tomp.F90 @@ -0,0 +1,1062 @@ +! +! 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 private(i,ii,ib,icoeff,glob_row,x,y,z,zt,ix,iy,iz) + ! shared(deltah,myidx,a,desc_a,nb) + ! 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. + ! + block + integer(psb_lpk_), allocatable :: irow(:),icol(:) + real(psb_dpk_), allocatable :: val(:) + + 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 + ! + 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 a%print('a.mtx',head='Test') + 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(2000_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 + ! + ! 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,'(" ")') + ! + ! 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_pde3d.F90 b/test/pargen/psb_d_pde3d.F90 index d4eeccf24..0f9df354a 100644 --- a/test/pargen/psb_d_pde3d.F90 +++ b/test/pargen/psb_d_pde3d.F90 @@ -799,6 +799,7 @@ program psb_d_pde3d if(psb_errstatus_fatal()) goto 9999 name='pde3d90' call psb_set_errverbosity(itwo) + call psb_cd_set_large_threshold(2000_psb_ipk_) ! ! Hello world ! From eb11e5e053daeaddef8c0f4d4eca48cdf85f0872 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 14 Apr 2023 17:48:15 +0200 Subject: [PATCH 13/63] Put CRITICAL(name) in G2L_INS --- base/modules/desc/psb_gen_block_map_mod.F90 | 1 + ...list_map_mod.f90 => psb_glist_map_mod.F90} | 0 base/modules/desc/psb_hash_map_mod.F90 | 91 ++++++++----------- base/modules/desc/psb_hash_mod.F90 | 49 +++++----- ..._list_map_mod.f90 => psb_list_map_mod.F90} | 59 +++++++++++- ..._repl_map_mod.f90 => psb_repl_map_mod.F90} | 0 6 files changed, 125 insertions(+), 75 deletions(-) rename base/modules/desc/{psb_glist_map_mod.f90 => psb_glist_map_mod.F90} (100%) rename base/modules/desc/{psb_list_map_mod.f90 => psb_list_map_mod.F90} (92%) rename base/modules/desc/{psb_repl_map_mod.f90 => psb_repl_map_mod.F90} (100%) diff --git a/base/modules/desc/psb_gen_block_map_mod.F90 b/base/modules/desc/psb_gen_block_map_mod.F90 index dfb47b61a..2c20a547f 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 index af9cdf61d..0f9af7ef2 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 @@ -437,7 +434,6 @@ contains end if end if - end subroutine hash_g2lv1 subroutine hash_g2lv2(idxin,idxout,idxmap,info,mask,owned) @@ -460,7 +456,6 @@ contains is = size(idxin) im = min(is,size(idxout)) - info = 0 ctxt = idxmap%get_ctxt() call psb_info(ctxt,iam,np) @@ -567,7 +562,6 @@ contains end if end if - end subroutine hash_g2lv2 @@ -688,14 +682,13 @@ contains if (use_openmp) then #ifdef OPENMP - call OMP_init_lock(ins_lck) + !call OMP_init_lock(ins_lck) if (idxmap%is_bld()) then isLoopValid = .true. ncol = idxmap%get_lc() if (present(mask)) then - !write(0,*) 'present mask' mask_ = mask else allocate(mask_(size(idx))) @@ -703,13 +696,12 @@ contains end if if (present(lidx)) then - !write(0,*) 'present lidx' 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,lidx) & - !$OMP private(i,ip,lip,tlip,nxt,info) & - !$OMP reduction(.AND.:isLoopValid) + ! $ 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 (mask(i)) then @@ -718,9 +710,9 @@ contains idx(i) = -1 cycle endif - call OMP_set_lock(ins_lck) + !call OMP_set_lock(ins_lck) ncol = idxmap%get_lc() - call OMP_unset_lock(ins_lck) + !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, @@ -728,7 +720,7 @@ contains call hash_inner_cnv(ip,lip,idxmap%hashvmask,& & idxmap%hashv,idxmap%glb_lc,ncol) if (lip < 0) then - call OMP_set_lock(ins_lck) + !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 @@ -772,7 +764,7 @@ contains else idx(i) = -1 end if - call OMP_unset_lock(ins_lck) + !call OMP_unset_lock(ins_lck) end if else idx(i) = lip @@ -782,17 +774,17 @@ contains end if end do - !$OMP END PARALLEL DO + ! $ OMP END PARALLEL DO 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,lidx) & - !$OMP private(i,ip,lip,tlip,nxt,info) & - !$OMP reduction(.AND.:isLoopValid) + ! $ 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 ip = idx(i) @@ -800,9 +792,9 @@ contains idx(i) = -1 cycle endif - call OMP_set_lock(ins_lck) + !call OMP_set_lock(ins_lck) ncol = idxmap%get_lc() - call OMP_unset_lock(ins_lck) + !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, @@ -810,7 +802,7 @@ contains call hash_inner_cnv(ip,lip,idxmap%hashvmask,& & idxmap%hashv,idxmap%glb_lc,ncol) if (lip < 0) then - call OMP_set_lock(ins_lck) + !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). @@ -851,26 +843,25 @@ contains else idx(i) = -1 end if - call OMP_unset_lock(ins_lck) + !call OMP_unset_lock(ins_lck) end if else idx(i) = lip end if end do - !$OMP END PARALLEL DO + ! $ OMP END PARALLEL DO if (.not. isLoopValid) then goto 9999 end if end if else if (.not.present(lidx)) then - !write(0,*) 'not present lidx' 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 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) do i = 1, is info = 0 if (mask(i)) then @@ -879,9 +870,9 @@ contains idx(i) = -1 cycle endif - call OMP_set_lock(ins_lck) + !call OMP_set_lock(ins_lck) ncol = idxmap%get_lc() - call OMP_unset_lock(ins_lck) + !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, @@ -890,7 +881,7 @@ contains & idxmap%hashv,idxmap%glb_lc,ncol) if (lip < 0) then - call OMP_set_lock(ins_lck) + !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, so this lock is relatively rare). @@ -932,7 +923,7 @@ contains else idx(i) = -1 end if - call OMP_unset_lock(ins_lck) + !call OMP_unset_lock(ins_lck) end if else idx(i) = lip @@ -942,16 +933,16 @@ contains end if end do - !$OMP END PARALLEL DO + ! $ OMP END PARALLEL DO 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 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) do i = 1, is info = 0 ip = idx(i) @@ -959,9 +950,9 @@ contains idx(i) = -1 cycle endif - call OMP_set_lock(ins_lck) + !call OMP_set_lock(ins_lck) ncol = idxmap%get_lc() - call OMP_unset_lock(ins_lck) + !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, @@ -969,7 +960,7 @@ contains call hash_inner_cnv(ip,lip,idxmap%hashvmask,& & idxmap%hashv,idxmap%glb_lc,ncol) if (lip < 0) then - call OMP_set_lock(ins_lck) + !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). @@ -1011,7 +1002,7 @@ contains else idx(i) = -1 end if - call OMP_unset_lock(ins_lck) + !call OMP_unset_lock(ins_lck) end if else @@ -1019,7 +1010,7 @@ contains end if end do - !$OMP END PARALLEL DO + ! $ OMP END PARALLEL DO if (.not. isLoopValid) then goto 9999 @@ -1032,7 +1023,7 @@ contains idx = -1 info = -1 end if - call OMP_destroy_lock(ins_lck) + !call OMP_destroy_lock(ins_lck) #endif else if (.not.use_openmp) then @@ -1139,9 +1130,9 @@ contains else if (.not.present(lidx)) then - if (present(mask)) then + if (present(mask)) then do i = 1, is - if (mask(i)) then + if (mask(i)) then ip = idx(i) if ((ip < 1 ).or.(ip>mglob)) then idx(i) = -1 @@ -1182,7 +1173,6 @@ contains idx(i) = -1 end if enddo - else if (.not.present(mask)) then do i = 1, is @@ -1227,7 +1217,6 @@ contains info = psb_success_ enddo - end if end if else diff --git a/base/modules/desc/psb_hash_mod.F90 b/base/modules/desc/psb_hash_mod.F90 index 0c6826705..c3c5ba20b 100644 --- a/base/modules/desc/psb_hash_mod.F90 +++ b/base/modules/desc/psb_hash_mod.F90 @@ -409,34 +409,39 @@ contains info = HashDuplicate return end if - !$OMP CRITICAL - 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) + 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 + !$omp end critical(hashsearchins) if (info /= HashOk) return - if (val > 0) 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 92% rename from base/modules/desc/psb_list_map_mod.f90 rename to base/modules/desc/psb_list_map_mod.F90 index 3e3c8e253..5961d5c2a 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 @@ -644,7 +643,20 @@ contains 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 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) info = -4 + idxmap%local_cols = max(ix,idxmap%local_cols) + idxmap%loc_to_glob(ix) = idxin(i) + idxmap%glob_to_loc(idxin(i)) = ix + 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 @@ -654,6 +666,7 @@ contains 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 @@ -668,6 +681,19 @@ contains 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) info = -4 + idxmap%local_cols = max(ix,idxmap%local_cols) + idxmap%loc_to_glob(ix) = idxin(i) + idxmap%glob_to_loc(idxin(i)) = ix + 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 @@ -677,6 +703,7 @@ contains 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 @@ -692,7 +719,20 @@ contains 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) info = -4 + idxmap%local_cols = ix + idxmap%loc_to_glob(ix) = idxin(i) + idxmap%glob_to_loc(idxin(i)) = ix + 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 @@ -702,6 +742,7 @@ contains 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 @@ -716,6 +757,19 @@ contains 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) info = -4 + idxmap%local_cols = ix + idxmap%loc_to_glob(ix) = idxin(i) + idxmap%glob_to_loc(idxin(i)) = ix + 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 @@ -725,6 +779,7 @@ contains 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 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 From 8459ea28f5359e55b0e51db837dd34c5fdee5873 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 14 Apr 2023 18:25:43 +0200 Subject: [PATCH 14/63] Modified matrix build procedures with OpenMP --- base/serial/impl/psb_c_coo_impl.F90 | 33 ++++++++++++++++-------- base/serial/impl/psb_c_csr_impl.F90 | 29 ++++++++++----------- base/serial/impl/psb_d_coo_impl.F90 | 13 +++++----- base/serial/impl/psb_d_csr_impl.F90 | 29 ++++++++++----------- base/serial/impl/psb_s_coo_impl.F90 | 33 ++++++++++++++++-------- base/serial/impl/psb_s_csr_impl.F90 | 29 ++++++++++----------- base/serial/impl/psb_z_coo_impl.F90 | 33 ++++++++++++++++-------- base/serial/impl/psb_z_csr_impl.F90 | 29 ++++++++++----------- base/tools/psb_cspins.F90 | 39 ++++++++++++++++++++++------- base/tools/psb_dspins.F90 | 18 ++++++------- base/tools/psb_sspins.F90 | 39 ++++++++++++++++++++++------- base/tools/psb_zspins.F90 | 39 ++++++++++++++++++++++------- test/omp/psb_tomp.F90 | 18 +++++++++---- test/pargen/psb_d_pde3d.F90 | 1 - 14 files changed, 236 insertions(+), 146 deletions(-) diff --git a/base/serial/impl/psb_c_coo_impl.F90 b/base/serial/impl/psb_c_coo_impl.F90 index 830b74008..c9be113ed 100644 --- a/base/serial/impl/psb_c_coo_impl.F90 +++ b/base/serial/impl/psb_c_coo_impl.F90 @@ -2818,6 +2818,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 @@ -2829,7 +2832,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() @@ -2861,10 +2864,11 @@ 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 + + !$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))) @@ -2872,16 +2876,23 @@ 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) +#if defined(OPENMP) + !write(0,*) 'From thread ',omp_get_thread_num(),nzaold,nz,nza,a%get_nzeros() +#endif 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() @@ -2951,7 +2962,7 @@ contains end do !$OMP END PARALLEL DO - nza = nza + nz + !nza = nza + nz #else do i=1, nz ir = ia(i) diff --git a/base/serial/impl/psb_c_csr_impl.F90 b/base/serial/impl/psb_c_csr_impl.F90 index a78691368..fc56e9d8f 100644 --- a/base/serial/impl/psb_c_csr_impl.F90 +++ b/base/serial/impl/psb_c_csr_impl.F90 @@ -2997,22 +2997,21 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) !$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 + + 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 #endif call a%set_host() - - + end subroutine psb_c_cp_csr_from_coo @@ -3128,7 +3127,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. #if defined(OPENMP) integer(psb_ipk_), allocatable :: sum(:) @@ -3229,7 +3227,6 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) !$OMP END PARALLEL #else - do k=1,nza i = itemp(k) a%irp(i) = a%irp(i) + 1 diff --git a/base/serial/impl/psb_d_coo_impl.F90 b/base/serial/impl/psb_d_coo_impl.F90 index f4f4f0dc3..bb845f4b2 100644 --- a/base/serial/impl/psb_d_coo_impl.F90 +++ b/base/serial/impl/psb_d_coo_impl.F90 @@ -2832,7 +2832,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, nzaold + integer(psb_ipk_) :: nza, i,j,k, nzl, isza, nzaold, debug_level, debug_unit info = psb_success_ debug_unit = psb_get_debug_unit() @@ -2864,7 +2864,6 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) if (nz == 0) return - if (a%is_bld()) then !$omp critical @@ -2890,7 +2889,7 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) call psb_inner_ins(nz,ia,ja,val,nzaold,a%ia,a%ja,a%val,isza,& & imin,imax,jmin,jmax,info) call a%set_sorted(.false.) - + else if (a%is_upd()) then nza = a%get_nzeros() isza = a%get_size() @@ -2945,9 +2944,9 @@ contains ! the serial version: each element is stored in data ! structures but the invalid ones are stored as '-1' values. ! These values will be filtered in a future fixing process. - ! $ OMP PARALLEL DO default(none) schedule(STATIC) & - ! $ OMP shared(nz,imin,imax,jmin,jmax,ia,ja,val,ia1,ia2,aspk,nza) & - ! $ OMP private(ir,ic,i) + !$OMP PARALLEL DO default(none) schedule(STATIC) & + !$OMP shared(nz,imin,imax,jmin,jmax,ia,ja,val,ia1,ia2,aspk,nza) & + !$OMP private(ir,ic,i) do i=1,nz ir = ia(i) ic = ja(i) @@ -2961,7 +2960,7 @@ contains aspk(nza+i) = -1 end if end do - ! $OMP END PARALLEL DO + !$OMP END PARALLEL DO !nza = nza + nz #else diff --git a/base/serial/impl/psb_d_csr_impl.F90 b/base/serial/impl/psb_d_csr_impl.F90 index a2ddad30e..1e579aaaf 100644 --- a/base/serial/impl/psb_d_csr_impl.F90 +++ b/base/serial/impl/psb_d_csr_impl.F90 @@ -2997,22 +2997,21 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) !$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 + + 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 #endif call a%set_host() - - + end subroutine psb_d_cp_csr_from_coo @@ -3128,7 +3127,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. #if defined(OPENMP) integer(psb_ipk_), allocatable :: sum(:) @@ -3229,7 +3227,6 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) !$OMP END PARALLEL #else - do k=1,nza i = itemp(k) a%irp(i) = a%irp(i) + 1 diff --git a/base/serial/impl/psb_s_coo_impl.F90 b/base/serial/impl/psb_s_coo_impl.F90 index be4218dea..0b2016844 100644 --- a/base/serial/impl/psb_s_coo_impl.F90 +++ b/base/serial/impl/psb_s_coo_impl.F90 @@ -2818,6 +2818,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 @@ -2829,7 +2832,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() @@ -2861,10 +2864,11 @@ 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 + + !$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))) @@ -2872,16 +2876,23 @@ 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) +#if defined(OPENMP) + !write(0,*) 'From thread ',omp_get_thread_num(),nzaold,nz,nza,a%get_nzeros() +#endif 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() @@ -2951,7 +2962,7 @@ contains end do !$OMP END PARALLEL DO - nza = nza + nz + !nza = nza + nz #else do i=1, nz ir = ia(i) diff --git a/base/serial/impl/psb_s_csr_impl.F90 b/base/serial/impl/psb_s_csr_impl.F90 index a8c67c10d..4eeaaf5d4 100644 --- a/base/serial/impl/psb_s_csr_impl.F90 +++ b/base/serial/impl/psb_s_csr_impl.F90 @@ -2997,22 +2997,21 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) !$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 + + 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 #endif call a%set_host() - - + end subroutine psb_s_cp_csr_from_coo @@ -3128,7 +3127,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. #if defined(OPENMP) integer(psb_ipk_), allocatable :: sum(:) @@ -3229,7 +3227,6 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) !$OMP END PARALLEL #else - do k=1,nza i = itemp(k) a%irp(i) = a%irp(i) + 1 diff --git a/base/serial/impl/psb_z_coo_impl.F90 b/base/serial/impl/psb_z_coo_impl.F90 index 4f99cb5cc..14410f23d 100644 --- a/base/serial/impl/psb_z_coo_impl.F90 +++ b/base/serial/impl/psb_z_coo_impl.F90 @@ -2818,6 +2818,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 @@ -2829,7 +2832,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() @@ -2861,10 +2864,11 @@ 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 + + !$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))) @@ -2872,16 +2876,23 @@ 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) +#if defined(OPENMP) + !write(0,*) 'From thread ',omp_get_thread_num(),nzaold,nz,nza,a%get_nzeros() +#endif 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() @@ -2951,7 +2962,7 @@ contains end do !$OMP END PARALLEL DO - nza = nza + nz + !nza = nza + nz #else do i=1, nz ir = ia(i) diff --git a/base/serial/impl/psb_z_csr_impl.F90 b/base/serial/impl/psb_z_csr_impl.F90 index 6344b2683..3e1dacb95 100644 --- a/base/serial/impl/psb_z_csr_impl.F90 +++ b/base/serial/impl/psb_z_csr_impl.F90 @@ -2997,22 +2997,21 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) !$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 + + 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 #endif call a%set_host() - - + end subroutine psb_z_cp_csr_from_coo @@ -3128,7 +3127,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. #if defined(OPENMP) integer(psb_ipk_), allocatable :: sum(:) @@ -3229,7 +3227,6 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) !$OMP END PARALLEL #else - do k=1,nza i = itemp(k) a%irp(i) = a%irp(i) + 1 diff --git a/base/tools/psb_cspins.F90 b/base/tools/psb_cspins.F90 index 27cfbd8e0..0a65fb5cb 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... @@ -70,7 +73,7 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ integer(psb_ipk_), allocatable :: ila(:),jla(:) - integer(psb_ipk_) :: i,k + integer(psb_ipk_) :: i,k, ith, nth integer(psb_lpk_) :: nnl integer(psb_lpk_), allocatable :: lila(:),ljla(:) complex(psb_spk_), allocatable :: lval(:) @@ -82,7 +85,13 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) ctxt = desc_a%get_context() call psb_info(ctxt, me, np) - +#if defined(OPENMP) + nth = omp_get_num_threads() + ith = omp_get_thread_num() +#else + nth = 1 + ith = 0 +#endif if (nz < 0) then info = 1111 call psb_errpush(info,name) @@ -131,15 +140,23 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) & a_err='allocate',i_err=(/info/)) goto 9999 end if - - call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) +#if defined(OPENMP) + !$omp parallel private(ila,jla,nrow,ncol) +#endif + call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) +#if defined(OPENMP) + !$omp critical(cSPINS) +#endif if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& & mask=(ila(1:nz)>0)) - +#if defined(OPENMP) + !$omp end critical(cSPINS) +#endif + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_ai_,name,& & a_err='psb_cdins',i_err=(/info/)) - goto 9999 + !goto 9999 end if nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() @@ -149,13 +166,12 @@ 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) if (nnl > 0) then - !write(0,*) 'Check on insert ',nnl allocate(lila(nnl),ljla(nnl),lval(nnl)) k = 0 do i=1,nz @@ -175,8 +191,13 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) else info = psb_err_invalid_a_and_cd_state_ call psb_errpush(info,name) - goto 9999 + !goto 9999 end if + +#if defined(OPENMP) + !$omp end parallel +#endif + if (info /= 0) goto 9999 endif else if (desc_a%is_asb()) then diff --git a/base/tools/psb_dspins.F90 b/base/tools/psb_dspins.F90 index 9c4f137f1..6f700bcc1 100644 --- a/base/tools/psb_dspins.F90 +++ b/base/tools/psb_dspins.F90 @@ -73,7 +73,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ integer(psb_ipk_), allocatable :: ila(:),jla(:) - integer(psb_ipk_) :: i,k + integer(psb_ipk_) :: i,k, ith, nth integer(psb_lpk_) :: nnl integer(psb_lpk_), allocatable :: lila(:),ljla(:) real(psb_dpk_), allocatable :: lval(:) @@ -86,7 +86,11 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) ctxt = desc_a%get_context() call psb_info(ctxt, me, np) #if defined(OPENMP) - !write(0,*) name,omp_get_num_threads(),omp_get_thread_num() + nth = omp_get_num_threads() + ith = omp_get_thread_num() +#else + nth = 1 + ith = 0 #endif if (nz < 0) then info = 1111 @@ -139,17 +143,14 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) #if defined(OPENMP) !$omp parallel private(ila,jla,nrow,ncol) #endif - call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) #if defined(OPENMP) - !$omp critical + !$omp critical(dSPINS) #endif if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& & mask=(ila(1:nz)>0)) -!!$ write(0,*) omp_get_thread_num(),'Check g2l: ',ila(1:nz),':',& -!!$ & jla(1:nz),':',ja(1:nz) #if defined(OPENMP) - !$omp end critical + !$omp end critical(dSPINS) #endif if (info /= psb_success_) then @@ -171,7 +172,6 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) 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 @@ -197,7 +197,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) #if defined(OPENMP) !$omp end parallel #endif - + if (info /= 0) goto 9999 endif else if (desc_a%is_asb()) then diff --git a/base/tools/psb_sspins.F90 b/base/tools/psb_sspins.F90 index aee7a9004..1e7f9037e 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... @@ -70,7 +73,7 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ integer(psb_ipk_), allocatable :: ila(:),jla(:) - integer(psb_ipk_) :: i,k + integer(psb_ipk_) :: i,k, ith, nth integer(psb_lpk_) :: nnl integer(psb_lpk_), allocatable :: lila(:),ljla(:) real(psb_spk_), allocatable :: lval(:) @@ -82,7 +85,13 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) ctxt = desc_a%get_context() call psb_info(ctxt, me, np) - +#if defined(OPENMP) + nth = omp_get_num_threads() + ith = omp_get_thread_num() +#else + nth = 1 + ith = 0 +#endif if (nz < 0) then info = 1111 call psb_errpush(info,name) @@ -131,15 +140,23 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) & a_err='allocate',i_err=(/info/)) goto 9999 end if - - call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) +#if defined(OPENMP) + !$omp parallel private(ila,jla,nrow,ncol) +#endif + call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) +#if defined(OPENMP) + !$omp critical(sSPINS) +#endif if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& & mask=(ila(1:nz)>0)) - +#if defined(OPENMP) + !$omp end critical(sSPINS) +#endif + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_ai_,name,& & a_err='psb_cdins',i_err=(/info/)) - goto 9999 + !goto 9999 end if nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() @@ -149,13 +166,12 @@ 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) if (nnl > 0) then - !write(0,*) 'Check on insert ',nnl allocate(lila(nnl),ljla(nnl),lval(nnl)) k = 0 do i=1,nz @@ -175,8 +191,13 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) else info = psb_err_invalid_a_and_cd_state_ call psb_errpush(info,name) - goto 9999 + !goto 9999 end if + +#if defined(OPENMP) + !$omp end parallel +#endif + if (info /= 0) goto 9999 endif else if (desc_a%is_asb()) then diff --git a/base/tools/psb_zspins.F90 b/base/tools/psb_zspins.F90 index abe64251d..40c0783b5 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... @@ -70,7 +73,7 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ integer(psb_ipk_), allocatable :: ila(:),jla(:) - integer(psb_ipk_) :: i,k + integer(psb_ipk_) :: i,k, ith, nth integer(psb_lpk_) :: nnl integer(psb_lpk_), allocatable :: lila(:),ljla(:) complex(psb_dpk_), allocatable :: lval(:) @@ -82,7 +85,13 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) ctxt = desc_a%get_context() call psb_info(ctxt, me, np) - +#if defined(OPENMP) + nth = omp_get_num_threads() + ith = omp_get_thread_num() +#else + nth = 1 + ith = 0 +#endif if (nz < 0) then info = 1111 call psb_errpush(info,name) @@ -131,15 +140,23 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) & a_err='allocate',i_err=(/info/)) goto 9999 end if - - call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) +#if defined(OPENMP) + !$omp parallel private(ila,jla,nrow,ncol) +#endif + call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) +#if defined(OPENMP) + !$omp critical(zSPINS) +#endif if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& & mask=(ila(1:nz)>0)) - +#if defined(OPENMP) + !$omp end critical(zSPINS) +#endif + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_ai_,name,& & a_err='psb_cdins',i_err=(/info/)) - goto 9999 + !goto 9999 end if nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() @@ -149,13 +166,12 @@ 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) if (nnl > 0) then - !write(0,*) 'Check on insert ',nnl allocate(lila(nnl),ljla(nnl),lval(nnl)) k = 0 do i=1,nz @@ -175,8 +191,13 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) else info = psb_err_invalid_a_and_cd_state_ call psb_errpush(info,name) - goto 9999 + !goto 9999 end if + +#if defined(OPENMP) + !$omp end parallel +#endif + if (info /= 0) goto 9999 endif else if (desc_a%is_asb()) then diff --git a/test/omp/psb_tomp.F90 b/test/omp/psb_tomp.F90 index 8681c3965..7965a5f49 100644 --- a/test/omp/psb_tomp.F90 +++ b/test/omp/psb_tomp.F90 @@ -451,16 +451,24 @@ contains call psb_barrier(ctxt) t1 = psb_wtime() - !$omp parallel private(i,ii,ib,icoeff,glob_row,x,y,z,zt,ix,iy,iz) - ! shared(deltah,myidx,a,desc_a,nb) + !$omp parallel shared(deltah,myidx,a,desc_a) ! 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. ! 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 @@ -473,7 +481,7 @@ contains ! loop over rows belonging to current process in a block ! distribution. - !$omp do + !$omp do schedule(dynamic,4) ! do ii=1, nlr, nb if (info /= 0) cycle @@ -723,7 +731,7 @@ program psb_d_pde3d if(psb_errstatus_fatal()) goto 9999 name='pde3d90' call psb_set_errverbosity(itwo) - call psb_cd_set_large_threshold(2000_psb_ipk_) + !call psb_cd_set_large_threshold(2000_psb_ipk_) ! ! Hello world ! diff --git a/test/pargen/psb_d_pde3d.F90 b/test/pargen/psb_d_pde3d.F90 index 0f9df354a..d4eeccf24 100644 --- a/test/pargen/psb_d_pde3d.F90 +++ b/test/pargen/psb_d_pde3d.F90 @@ -799,7 +799,6 @@ program psb_d_pde3d if(psb_errstatus_fatal()) goto 9999 name='pde3d90' call psb_set_errverbosity(itwo) - call psb_cd_set_large_threshold(2000_psb_ipk_) ! ! Hello world ! From f068d73ef1ef33b8bb5ca162573edee5950dc4ef Mon Sep 17 00:00:00 2001 From: sfilippone Date: Sun, 16 Apr 2023 11:30:09 +0200 Subject: [PATCH 15/63] First working version --- base/modules/desc/psb_hash_map_mod.F90 | 20 ++++++++++++++------ base/tools/psb_cspins.F90 | 4 ++-- base/tools/psb_dspins.F90 | 4 ++-- base/tools/psb_sspins.F90 | 4 ++-- base/tools/psb_zspins.F90 | 4 ++-- test/omp/psb_tomp.F90 | 4 ++-- 6 files changed, 24 insertions(+), 16 deletions(-) diff --git a/base/modules/desc/psb_hash_map_mod.F90 b/base/modules/desc/psb_hash_map_mod.F90 index 0f9af7ef2..eac8cc7ab 100644 --- a/base/modules/desc/psb_hash_map_mod.F90 +++ b/base/modules/desc/psb_hash_map_mod.F90 @@ -649,7 +649,7 @@ contains integer(psb_ipk_) :: me, np character(len=20) :: name,ch_err logical, allocatable :: mask_(:) - logical :: use_openmp = .false. + logical :: use_openmp = .true. #ifdef OPENMP integer(kind = OMP_lock_kind) :: ins_lck #endif @@ -681,7 +681,7 @@ contains nrow = idxmap%get_lr() if (use_openmp) then -#ifdef OPENMP +#ifdef OPENMP !call OMP_init_lock(ins_lck) if (idxmap%is_bld()) then @@ -697,6 +697,7 @@ contains if (present(lidx)) then if (present(mask)) then + !$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) & @@ -775,11 +776,13 @@ contains 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) & @@ -851,7 +854,8 @@ contains end do ! $ OMP END PARALLEL DO - + !$omp end critical(hash_g2l_ins) + if (.not. isLoopValid) then goto 9999 end if @@ -861,7 +865,9 @@ contains ! $ 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 reduction(.AND.:isLoopValid) + !$omp critical(hash_g2l_ins) + do i = 1, is info = 0 if (mask(i)) then @@ -934,7 +940,8 @@ contains end do ! $ OMP END PARALLEL DO - + !$omp end critical(hash_g2l_ins) + if (.not. isLoopValid) then goto 9999 end if @@ -943,6 +950,7 @@ contains ! $ 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 ip = idx(i) @@ -1011,6 +1019,7 @@ contains end do ! $ OMP END PARALLEL DO + !$omp end critical(hash_g2l_ins) if (.not. isLoopValid) then goto 9999 @@ -1024,7 +1033,6 @@ contains info = -1 end if !call OMP_destroy_lock(ins_lck) - #endif else if (.not.use_openmp) then #ifdef OPENMP diff --git a/base/tools/psb_cspins.F90 b/base/tools/psb_cspins.F90 index 0a65fb5cb..cfa88c550 100644 --- a/base/tools/psb_cspins.F90 +++ b/base/tools/psb_cspins.F90 @@ -145,12 +145,12 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) #endif call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) #if defined(OPENMP) - !$omp critical(cSPINS) + !$omp critical(cspins) #endif if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& & mask=(ila(1:nz)>0)) #if defined(OPENMP) - !$omp end critical(cSPINS) + !$omp end critical(cspins) #endif if (info /= psb_success_) then diff --git a/base/tools/psb_dspins.F90 b/base/tools/psb_dspins.F90 index 6f700bcc1..0ba710968 100644 --- a/base/tools/psb_dspins.F90 +++ b/base/tools/psb_dspins.F90 @@ -145,12 +145,12 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) #endif call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) #if defined(OPENMP) - !$omp critical(dSPINS) + !$omp critical(dspins) #endif if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& & mask=(ila(1:nz)>0)) #if defined(OPENMP) - !$omp end critical(dSPINS) + !$omp end critical(dspins) #endif if (info /= psb_success_) then diff --git a/base/tools/psb_sspins.F90 b/base/tools/psb_sspins.F90 index 1e7f9037e..71cd293a8 100644 --- a/base/tools/psb_sspins.F90 +++ b/base/tools/psb_sspins.F90 @@ -145,12 +145,12 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) #endif call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) #if defined(OPENMP) - !$omp critical(sSPINS) + !$omp critical(sspins) #endif if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& & mask=(ila(1:nz)>0)) #if defined(OPENMP) - !$omp end critical(sSPINS) + !$omp end critical(sspins) #endif if (info /= psb_success_) then diff --git a/base/tools/psb_zspins.F90 b/base/tools/psb_zspins.F90 index 40c0783b5..be24a0473 100644 --- a/base/tools/psb_zspins.F90 +++ b/base/tools/psb_zspins.F90 @@ -145,12 +145,12 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) #endif call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) #if defined(OPENMP) - !$omp critical(zSPINS) + !$omp critical(zspins) #endif if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& & mask=(ila(1:nz)>0)) #if defined(OPENMP) - !$omp end critical(zSPINS) + !$omp end critical(zspins) #endif if (info /= psb_success_) then diff --git a/test/omp/psb_tomp.F90 b/test/omp/psb_tomp.F90 index 7965a5f49..0a13a41b0 100644 --- a/test/omp/psb_tomp.F90 +++ b/test/omp/psb_tomp.F90 @@ -639,7 +639,7 @@ contains write(psb_out_unit,'("-total time : ",es12.5)') ttot end if - !call a%print('a.mtx',head='Test') + call a%print('a.mtx',head='Test') call psb_erractionrestore(err_act) return @@ -731,7 +731,7 @@ program psb_d_pde3d if(psb_errstatus_fatal()) goto 9999 name='pde3d90' call psb_set_errverbosity(itwo) - !call psb_cd_set_large_threshold(2000_psb_ipk_) + call psb_cd_set_large_threshold(2000_psb_ipk_) ! ! Hello world ! From 5a5712b4f079c242c5ae3938deb5826dc54ac388 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Sun, 16 Apr 2023 12:02:54 +0200 Subject: [PATCH 16/63] Rely on CRITICAL inside G2L_INS implementation --- base/tools/psb_cspins.F90 | 6 ------ base/tools/psb_dspins.F90 | 6 ------ base/tools/psb_sspins.F90 | 6 ------ base/tools/psb_zspins.F90 | 6 ------ test/omp/psb_tomp.F90 | 2 +- 5 files changed, 1 insertion(+), 25 deletions(-) diff --git a/base/tools/psb_cspins.F90 b/base/tools/psb_cspins.F90 index cfa88c550..66e03ed9d 100644 --- a/base/tools/psb_cspins.F90 +++ b/base/tools/psb_cspins.F90 @@ -144,14 +144,8 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) !$omp parallel private(ila,jla,nrow,ncol) #endif call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) -#if defined(OPENMP) - !$omp critical(cspins) -#endif if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& & mask=(ila(1:nz)>0)) -#if defined(OPENMP) - !$omp end critical(cspins) -#endif if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_ai_,name,& diff --git a/base/tools/psb_dspins.F90 b/base/tools/psb_dspins.F90 index 0ba710968..2e11c5110 100644 --- a/base/tools/psb_dspins.F90 +++ b/base/tools/psb_dspins.F90 @@ -144,14 +144,8 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) !$omp parallel private(ila,jla,nrow,ncol) #endif call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) -#if defined(OPENMP) - !$omp critical(dspins) -#endif if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& & mask=(ila(1:nz)>0)) -#if defined(OPENMP) - !$omp end critical(dspins) -#endif if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_ai_,name,& diff --git a/base/tools/psb_sspins.F90 b/base/tools/psb_sspins.F90 index 71cd293a8..90fa9e2da 100644 --- a/base/tools/psb_sspins.F90 +++ b/base/tools/psb_sspins.F90 @@ -144,14 +144,8 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) !$omp parallel private(ila,jla,nrow,ncol) #endif call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) -#if defined(OPENMP) - !$omp critical(sspins) -#endif if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& & mask=(ila(1:nz)>0)) -#if defined(OPENMP) - !$omp end critical(sspins) -#endif if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_ai_,name,& diff --git a/base/tools/psb_zspins.F90 b/base/tools/psb_zspins.F90 index be24a0473..74e2d5dc7 100644 --- a/base/tools/psb_zspins.F90 +++ b/base/tools/psb_zspins.F90 @@ -144,14 +144,8 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) !$omp parallel private(ila,jla,nrow,ncol) #endif call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) -#if defined(OPENMP) - !$omp critical(zspins) -#endif if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,& & mask=(ila(1:nz)>0)) -#if defined(OPENMP) - !$omp end critical(zspins) -#endif if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_ai_,name,& diff --git a/test/omp/psb_tomp.F90 b/test/omp/psb_tomp.F90 index 0a13a41b0..468eeb5ad 100644 --- a/test/omp/psb_tomp.F90 +++ b/test/omp/psb_tomp.F90 @@ -731,7 +731,7 @@ program psb_d_pde3d if(psb_errstatus_fatal()) goto 9999 name='pde3d90' call psb_set_errverbosity(itwo) - call psb_cd_set_large_threshold(2000_psb_ipk_) + call psb_cd_set_large_threshold(125000_psb_ipk_) ! ! Hello world ! From 6ba7d9315933c0da85de59cefe610644bbff0d02 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Sun, 16 Apr 2023 12:03:16 +0200 Subject: [PATCH 17/63] Fix CRITICAL in LIST%G2L_INS --- base/modules/desc/psb_list_map_mod.F90 | 207 ++++++++++++++++++------- 1 file changed, 148 insertions(+), 59 deletions(-) diff --git a/base/modules/desc/psb_list_map_mod.F90 b/base/modules/desc/psb_list_map_mod.F90 index 5961d5c2a..6b61cf52e 100644 --- a/base/modules/desc/psb_list_map_mod.F90 +++ b/base/modules/desc/psb_list_map_mod.F90 @@ -500,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 @@ -524,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 @@ -548,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 @@ -572,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 @@ -640,32 +713,36 @@ 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 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) info = -4 - idxmap%local_cols = max(ix,idxmap%local_cols) - idxmap%loc_to_glob(ix) = idxin(i) - idxmap%glob_to_loc(idxin(i)) = ix - end if - !$OMP END CRITICAL(LISTINS) + !$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 @@ -678,6 +755,7 @@ 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 @@ -687,10 +765,13 @@ contains if (ix < 0) then ix = lidx(i) call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) - if (info /= 0) info = -4 - idxmap%local_cols = max(ix,idxmap%local_cols) - idxmap%loc_to_glob(ix) = idxin(i) - idxmap%glob_to_loc(idxin(i)) = ix + 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 @@ -698,11 +779,11 @@ contains 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 @@ -716,6 +797,7 @@ 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)) @@ -726,10 +808,13 @@ contains if (ix < 0) then ix = idxmap%local_cols + 1 call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) - if (info /= 0) info = -4 - idxmap%local_cols = ix - idxmap%loc_to_glob(ix) = idxin(i) - idxmap%glob_to_loc(idxin(i)) = ix + 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 @@ -737,11 +822,11 @@ contains 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 @@ -754,6 +839,7 @@ 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 @@ -763,10 +849,13 @@ contains if (ix < 0) then ix = idxmap%local_cols + 1 call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) - if (info /= 0) info = -4 - idxmap%local_cols = ix - idxmap%loc_to_glob(ix) = idxin(i) - idxmap%glob_to_loc(idxin(i)) = ix + 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 @@ -774,11 +863,11 @@ contains 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 From dbd55321f83b3f40d075999756050748138cb957 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Mon, 17 Apr 2023 21:00:20 +0200 Subject: [PATCH 18/63] Fixed CSR mv and cp _from_coo with OpenMP. --- base/serial/impl/psb_c_csr_impl.F90 | 200 +++++++++++++--------------- base/serial/impl/psb_d_csr_impl.F90 | 200 +++++++++++++--------------- base/serial/impl/psb_s_csr_impl.F90 | 200 +++++++++++++--------------- base/serial/impl/psb_z_csr_impl.F90 | 200 +++++++++++++--------------- test/omp/psb_tomp.F90 | 11 +- 5 files changed, 394 insertions(+), 417 deletions(-) diff --git a/base/serial/impl/psb_c_csr_impl.F90 b/base/serial/impl/psb_c_csr_impl.F90 index fc56e9d8f..e091e020f 100644 --- a/base/serial/impl/psb_c_csr_impl.F90 +++ b/base/serial/impl/psb_c_csr_impl.F90 @@ -2877,7 +2877,7 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) logical :: use_openmp = .false. #if defined(OPENMP) - integer(psb_ipk_), allocatable :: sum(:) + integer(psb_ipk_), allocatable :: suma(:) integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s,j integer(psb_ipk_) :: nxt_val,old_val,saved_elem,maxthreads #endif @@ -2923,81 +2923,74 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) endif - a%irp(:) = 0 #if defined(OPENMP) - 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 shared(suma,nthreads,nr,a,itemp,nza) & + !$OMP private(ithread,work,i,first_idx,last_idx,s) + + !$OMP WORKSHARE + a%irp(:) = 0 + !$OMP END WORKSHARE + !$OMP DO schedule(STATIC) & - !$OMP private(k,i) + !$OMP private(k) do k=1,nza i = itemp(k) - a%irp(i) = a%irp(i) + 1 + !$OMP ATOMIC UPDATE + a%irp(i+1) = a%irp(i+1) + 1 + !$OMP END ATOMIC end do !$OMP END DO - + !$OMP SINGLE nthreads = omp_get_num_threads() + allocate(suma(nthreads+1)) + suma(:) = 0 + !suma(1) = 1 !$OMP END SINGLE - ithread = omp_get_thread_num() - - work = nr/nthreads - if (ithread < MOD(nr,nthreads)) then + + + work = (nr+1)/nthreads + if (ithread < MOD((nr+1),nthreads)) then work = work + 1 first_idx = ithread*work + 1 else - first_idx = ithread*work + MOD(nr,nthreads) + 1 + first_idx = ithread*work + MOD((nr+1),nthreads) + 1 end if - - last_idx = first_idx + work - 1 - + + last_idx = min(first_idx + work - 1,nr+1) s = 0 - do i=first_idx,last_idx - s = s + a%irp(i) - end do - if (work > 0) then - sum(ithread+2) = s + if (first_idx<=last_idx) then + suma(ithread+2) = suma(ithread+2) + a%irp(first_idx) + do i=first_idx+1,last_idx + suma(ithread+2) = suma(ithread+2) + a%irp(i) + a%irp(i) = a%irp(i)+a%irp(i-1) + end do end if - !$OMP BARRIER - !$OMP SINGLE do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) + suma(i) = suma(i) + suma(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 END SINGLE + !$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 + + !$OMP DO SCHEDULE(STATIC) + do i=1,nr+1 + a%irp(i) = suma(ithread+1) + a%irp(i) +1 end do - + !$OMP END DO + !$OMP SINGLE + a%irp(1) = 1 + !$OMP END SINGLE + !$OMP END PARALLEL #else - + a%irp(:) = 0 do k=1,nza i = itemp(k) a%irp(i) = a%irp(i) + 1 @@ -3010,6 +3003,7 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) end do a%irp(nr+1) = ip #endif + call a%set_host() end subroutine psb_c_cp_csr_from_coo @@ -3129,7 +3123,7 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) character(len=20) :: name='mv_from_coo' #if defined(OPENMP) - integer(psb_ipk_), allocatable :: sum(:) + integer(psb_ipk_), allocatable :: suma(:) integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s integer(psb_ipk_) :: nxt_val,old_val,saved_elem #endif @@ -3156,90 +3150,88 @@ 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(none) & + !$OMP shared(suma,nthreads,nr,a,itemp,nza) & + !$OMP private(ithread,work,i,first_idx,last_idx,s) + + !$OMP WORKSHARE a%irp(:) = 0 + !$OMP END WORKSHARE -#if defined(OPENMP) - !$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) + !$OMP private(k) do k=1,nza i = itemp(k) - a%irp(i) = a%irp(i) + 1 + !$OMP ATOMIC UPDATE + a%irp(i+1) = a%irp(i+1) + 1 + !$OMP END ATOMIC end do !$OMP END DO - + !$OMP SINGLE nthreads = omp_get_num_threads() - allocate(sum(nthreads+1)) - sum(:) = 0 - sum(1) = 1 + allocate(suma(nthreads+1)) + suma(:) = 0 + !suma(1) = 1 !$OMP END SINGLE - ithread = omp_get_thread_num() - work = nr/nthreads - if (ithread < MOD(nr,nthreads)) then + + work = (nr+1)/nthreads + if (ithread < MOD((nr+1),nthreads)) then work = work + 1 first_idx = ithread*work + 1 else - first_idx = ithread*work + MOD(nr,nthreads) + 1 + first_idx = ithread*work + MOD((nr+1),nthreads) + 1 end if - last_idx = first_idx + work - 1 - + last_idx = min(first_idx + work - 1,nr+1) s = 0 - do i=first_idx,last_idx - s = s + a%irp(i) - end do - if (work > 0) then - sum(ithread+2) = s + if (first_idx<=last_idx) then + suma(ithread+2) = suma(ithread+2) + a%irp(first_idx) + do i=first_idx+1,last_idx + suma(ithread+2) = suma(ithread+2) + a%irp(i) + a%irp(i) = a%irp(i)+a%irp(i-1) + end do end if - !$OMP BARRIER - !$OMP SINGLE do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) + suma(i) = suma(i) + suma(i-1) end do - !$OMP END SINGLE + !$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 + !$OMP BARRIER - 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 + !$OMP DO SCHEDULE(STATIC) + do i=1,nr+1 + a%irp(i) = suma(ithread+1) + a%irp(i) +1 end do + !$OMP END DO + !$OMP SINGLE + a%irp(1) = 1 + !$OMP END SINGLE !$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 + a%irp(:) = 0 + 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 #endif - + + !write(0,*) name,' Check:',a%irp(nr+1),all(a%irp(1:nr) < a%irp(nr+1)) + !write(0,*) name,a%irp(:) call a%set_host() end subroutine psb_c_mv_csr_from_coo diff --git a/base/serial/impl/psb_d_csr_impl.F90 b/base/serial/impl/psb_d_csr_impl.F90 index 1e579aaaf..e6b9f9582 100644 --- a/base/serial/impl/psb_d_csr_impl.F90 +++ b/base/serial/impl/psb_d_csr_impl.F90 @@ -2877,7 +2877,7 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) logical :: use_openmp = .false. #if defined(OPENMP) - integer(psb_ipk_), allocatable :: sum(:) + integer(psb_ipk_), allocatable :: suma(:) integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s,j integer(psb_ipk_) :: nxt_val,old_val,saved_elem,maxthreads #endif @@ -2923,81 +2923,74 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) endif - a%irp(:) = 0 #if defined(OPENMP) - 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 shared(suma,nthreads,nr,a,itemp,nza) & + !$OMP private(ithread,work,i,first_idx,last_idx,s) + + !$OMP WORKSHARE + a%irp(:) = 0 + !$OMP END WORKSHARE + !$OMP DO schedule(STATIC) & - !$OMP private(k,i) + !$OMP private(k) do k=1,nza i = itemp(k) - a%irp(i) = a%irp(i) + 1 + !$OMP ATOMIC UPDATE + a%irp(i+1) = a%irp(i+1) + 1 + !$OMP END ATOMIC end do !$OMP END DO - + !$OMP SINGLE nthreads = omp_get_num_threads() + allocate(suma(nthreads+1)) + suma(:) = 0 + !suma(1) = 1 !$OMP END SINGLE - ithread = omp_get_thread_num() - - work = nr/nthreads - if (ithread < MOD(nr,nthreads)) then + + + work = (nr+1)/nthreads + if (ithread < MOD((nr+1),nthreads)) then work = work + 1 first_idx = ithread*work + 1 else - first_idx = ithread*work + MOD(nr,nthreads) + 1 + first_idx = ithread*work + MOD((nr+1),nthreads) + 1 end if - - last_idx = first_idx + work - 1 - + + last_idx = min(first_idx + work - 1,nr+1) s = 0 - do i=first_idx,last_idx - s = s + a%irp(i) - end do - if (work > 0) then - sum(ithread+2) = s + if (first_idx<=last_idx) then + suma(ithread+2) = suma(ithread+2) + a%irp(first_idx) + do i=first_idx+1,last_idx + suma(ithread+2) = suma(ithread+2) + a%irp(i) + a%irp(i) = a%irp(i)+a%irp(i-1) + end do end if - !$OMP BARRIER - !$OMP SINGLE do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) + suma(i) = suma(i) + suma(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 END SINGLE + !$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 + + !$OMP DO SCHEDULE(STATIC) + do i=1,nr+1 + a%irp(i) = suma(ithread+1) + a%irp(i) +1 end do - + !$OMP END DO + !$OMP SINGLE + a%irp(1) = 1 + !$OMP END SINGLE + !$OMP END PARALLEL #else - + a%irp(:) = 0 do k=1,nza i = itemp(k) a%irp(i) = a%irp(i) + 1 @@ -3010,6 +3003,7 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) end do a%irp(nr+1) = ip #endif + call a%set_host() end subroutine psb_d_cp_csr_from_coo @@ -3129,7 +3123,7 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) character(len=20) :: name='mv_from_coo' #if defined(OPENMP) - integer(psb_ipk_), allocatable :: sum(:) + integer(psb_ipk_), allocatable :: suma(:) integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s integer(psb_ipk_) :: nxt_val,old_val,saved_elem #endif @@ -3156,90 +3150,88 @@ 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(none) & + !$OMP shared(suma,nthreads,nr,a,itemp,nza) & + !$OMP private(ithread,work,i,first_idx,last_idx,s) + + !$OMP WORKSHARE a%irp(:) = 0 + !$OMP END WORKSHARE -#if defined(OPENMP) - !$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) + !$OMP private(k) do k=1,nza i = itemp(k) - a%irp(i) = a%irp(i) + 1 + !$OMP ATOMIC UPDATE + a%irp(i+1) = a%irp(i+1) + 1 + !$OMP END ATOMIC end do !$OMP END DO - + !$OMP SINGLE nthreads = omp_get_num_threads() - allocate(sum(nthreads+1)) - sum(:) = 0 - sum(1) = 1 + allocate(suma(nthreads+1)) + suma(:) = 0 + !suma(1) = 1 !$OMP END SINGLE - ithread = omp_get_thread_num() - work = nr/nthreads - if (ithread < MOD(nr,nthreads)) then + + work = (nr+1)/nthreads + if (ithread < MOD((nr+1),nthreads)) then work = work + 1 first_idx = ithread*work + 1 else - first_idx = ithread*work + MOD(nr,nthreads) + 1 + first_idx = ithread*work + MOD((nr+1),nthreads) + 1 end if - last_idx = first_idx + work - 1 - + last_idx = min(first_idx + work - 1,nr+1) s = 0 - do i=first_idx,last_idx - s = s + a%irp(i) - end do - if (work > 0) then - sum(ithread+2) = s + if (first_idx<=last_idx) then + suma(ithread+2) = suma(ithread+2) + a%irp(first_idx) + do i=first_idx+1,last_idx + suma(ithread+2) = suma(ithread+2) + a%irp(i) + a%irp(i) = a%irp(i)+a%irp(i-1) + end do end if - !$OMP BARRIER - !$OMP SINGLE do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) + suma(i) = suma(i) + suma(i-1) end do - !$OMP END SINGLE + !$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 + !$OMP BARRIER - 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 + !$OMP DO SCHEDULE(STATIC) + do i=1,nr+1 + a%irp(i) = suma(ithread+1) + a%irp(i) +1 end do + !$OMP END DO + !$OMP SINGLE + a%irp(1) = 1 + !$OMP END SINGLE !$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 + a%irp(:) = 0 + 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 #endif - + + !write(0,*) name,' Check:',a%irp(nr+1),all(a%irp(1:nr) < a%irp(nr+1)) + !write(0,*) name,a%irp(:) call a%set_host() end subroutine psb_d_mv_csr_from_coo diff --git a/base/serial/impl/psb_s_csr_impl.F90 b/base/serial/impl/psb_s_csr_impl.F90 index 4eeaaf5d4..73f5484ab 100644 --- a/base/serial/impl/psb_s_csr_impl.F90 +++ b/base/serial/impl/psb_s_csr_impl.F90 @@ -2877,7 +2877,7 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) logical :: use_openmp = .false. #if defined(OPENMP) - integer(psb_ipk_), allocatable :: sum(:) + integer(psb_ipk_), allocatable :: suma(:) integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s,j integer(psb_ipk_) :: nxt_val,old_val,saved_elem,maxthreads #endif @@ -2923,81 +2923,74 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) endif - a%irp(:) = 0 #if defined(OPENMP) - 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 shared(suma,nthreads,nr,a,itemp,nza) & + !$OMP private(ithread,work,i,first_idx,last_idx,s) + + !$OMP WORKSHARE + a%irp(:) = 0 + !$OMP END WORKSHARE + !$OMP DO schedule(STATIC) & - !$OMP private(k,i) + !$OMP private(k) do k=1,nza i = itemp(k) - a%irp(i) = a%irp(i) + 1 + !$OMP ATOMIC UPDATE + a%irp(i+1) = a%irp(i+1) + 1 + !$OMP END ATOMIC end do !$OMP END DO - + !$OMP SINGLE nthreads = omp_get_num_threads() + allocate(suma(nthreads+1)) + suma(:) = 0 + !suma(1) = 1 !$OMP END SINGLE - ithread = omp_get_thread_num() - - work = nr/nthreads - if (ithread < MOD(nr,nthreads)) then + + + work = (nr+1)/nthreads + if (ithread < MOD((nr+1),nthreads)) then work = work + 1 first_idx = ithread*work + 1 else - first_idx = ithread*work + MOD(nr,nthreads) + 1 + first_idx = ithread*work + MOD((nr+1),nthreads) + 1 end if - - last_idx = first_idx + work - 1 - + + last_idx = min(first_idx + work - 1,nr+1) s = 0 - do i=first_idx,last_idx - s = s + a%irp(i) - end do - if (work > 0) then - sum(ithread+2) = s + if (first_idx<=last_idx) then + suma(ithread+2) = suma(ithread+2) + a%irp(first_idx) + do i=first_idx+1,last_idx + suma(ithread+2) = suma(ithread+2) + a%irp(i) + a%irp(i) = a%irp(i)+a%irp(i-1) + end do end if - !$OMP BARRIER - !$OMP SINGLE do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) + suma(i) = suma(i) + suma(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 END SINGLE + !$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 + + !$OMP DO SCHEDULE(STATIC) + do i=1,nr+1 + a%irp(i) = suma(ithread+1) + a%irp(i) +1 end do - + !$OMP END DO + !$OMP SINGLE + a%irp(1) = 1 + !$OMP END SINGLE + !$OMP END PARALLEL #else - + a%irp(:) = 0 do k=1,nza i = itemp(k) a%irp(i) = a%irp(i) + 1 @@ -3010,6 +3003,7 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) end do a%irp(nr+1) = ip #endif + call a%set_host() end subroutine psb_s_cp_csr_from_coo @@ -3129,7 +3123,7 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) character(len=20) :: name='mv_from_coo' #if defined(OPENMP) - integer(psb_ipk_), allocatable :: sum(:) + integer(psb_ipk_), allocatable :: suma(:) integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s integer(psb_ipk_) :: nxt_val,old_val,saved_elem #endif @@ -3156,90 +3150,88 @@ 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(none) & + !$OMP shared(suma,nthreads,nr,a,itemp,nza) & + !$OMP private(ithread,work,i,first_idx,last_idx,s) + + !$OMP WORKSHARE a%irp(:) = 0 + !$OMP END WORKSHARE -#if defined(OPENMP) - !$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) + !$OMP private(k) do k=1,nza i = itemp(k) - a%irp(i) = a%irp(i) + 1 + !$OMP ATOMIC UPDATE + a%irp(i+1) = a%irp(i+1) + 1 + !$OMP END ATOMIC end do !$OMP END DO - + !$OMP SINGLE nthreads = omp_get_num_threads() - allocate(sum(nthreads+1)) - sum(:) = 0 - sum(1) = 1 + allocate(suma(nthreads+1)) + suma(:) = 0 + !suma(1) = 1 !$OMP END SINGLE - ithread = omp_get_thread_num() - work = nr/nthreads - if (ithread < MOD(nr,nthreads)) then + + work = (nr+1)/nthreads + if (ithread < MOD((nr+1),nthreads)) then work = work + 1 first_idx = ithread*work + 1 else - first_idx = ithread*work + MOD(nr,nthreads) + 1 + first_idx = ithread*work + MOD((nr+1),nthreads) + 1 end if - last_idx = first_idx + work - 1 - + last_idx = min(first_idx + work - 1,nr+1) s = 0 - do i=first_idx,last_idx - s = s + a%irp(i) - end do - if (work > 0) then - sum(ithread+2) = s + if (first_idx<=last_idx) then + suma(ithread+2) = suma(ithread+2) + a%irp(first_idx) + do i=first_idx+1,last_idx + suma(ithread+2) = suma(ithread+2) + a%irp(i) + a%irp(i) = a%irp(i)+a%irp(i-1) + end do end if - !$OMP BARRIER - !$OMP SINGLE do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) + suma(i) = suma(i) + suma(i-1) end do - !$OMP END SINGLE + !$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 + !$OMP BARRIER - 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 + !$OMP DO SCHEDULE(STATIC) + do i=1,nr+1 + a%irp(i) = suma(ithread+1) + a%irp(i) +1 end do + !$OMP END DO + !$OMP SINGLE + a%irp(1) = 1 + !$OMP END SINGLE !$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 + a%irp(:) = 0 + 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 #endif - + + !write(0,*) name,' Check:',a%irp(nr+1),all(a%irp(1:nr) < a%irp(nr+1)) + !write(0,*) name,a%irp(:) call a%set_host() end subroutine psb_s_mv_csr_from_coo diff --git a/base/serial/impl/psb_z_csr_impl.F90 b/base/serial/impl/psb_z_csr_impl.F90 index 3e1dacb95..b07e37b74 100644 --- a/base/serial/impl/psb_z_csr_impl.F90 +++ b/base/serial/impl/psb_z_csr_impl.F90 @@ -2877,7 +2877,7 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) logical :: use_openmp = .false. #if defined(OPENMP) - integer(psb_ipk_), allocatable :: sum(:) + integer(psb_ipk_), allocatable :: suma(:) integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s,j integer(psb_ipk_) :: nxt_val,old_val,saved_elem,maxthreads #endif @@ -2923,81 +2923,74 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) endif - a%irp(:) = 0 #if defined(OPENMP) - 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 shared(suma,nthreads,nr,a,itemp,nza) & + !$OMP private(ithread,work,i,first_idx,last_idx,s) + + !$OMP WORKSHARE + a%irp(:) = 0 + !$OMP END WORKSHARE + !$OMP DO schedule(STATIC) & - !$OMP private(k,i) + !$OMP private(k) do k=1,nza i = itemp(k) - a%irp(i) = a%irp(i) + 1 + !$OMP ATOMIC UPDATE + a%irp(i+1) = a%irp(i+1) + 1 + !$OMP END ATOMIC end do !$OMP END DO - + !$OMP SINGLE nthreads = omp_get_num_threads() + allocate(suma(nthreads+1)) + suma(:) = 0 + !suma(1) = 1 !$OMP END SINGLE - ithread = omp_get_thread_num() - - work = nr/nthreads - if (ithread < MOD(nr,nthreads)) then + + + work = (nr+1)/nthreads + if (ithread < MOD((nr+1),nthreads)) then work = work + 1 first_idx = ithread*work + 1 else - first_idx = ithread*work + MOD(nr,nthreads) + 1 + first_idx = ithread*work + MOD((nr+1),nthreads) + 1 end if - - last_idx = first_idx + work - 1 - + + last_idx = min(first_idx + work - 1,nr+1) s = 0 - do i=first_idx,last_idx - s = s + a%irp(i) - end do - if (work > 0) then - sum(ithread+2) = s + if (first_idx<=last_idx) then + suma(ithread+2) = suma(ithread+2) + a%irp(first_idx) + do i=first_idx+1,last_idx + suma(ithread+2) = suma(ithread+2) + a%irp(i) + a%irp(i) = a%irp(i)+a%irp(i-1) + end do end if - !$OMP BARRIER - !$OMP SINGLE do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) + suma(i) = suma(i) + suma(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 END SINGLE + !$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 + + !$OMP DO SCHEDULE(STATIC) + do i=1,nr+1 + a%irp(i) = suma(ithread+1) + a%irp(i) +1 end do - + !$OMP END DO + !$OMP SINGLE + a%irp(1) = 1 + !$OMP END SINGLE + !$OMP END PARALLEL #else - + a%irp(:) = 0 do k=1,nza i = itemp(k) a%irp(i) = a%irp(i) + 1 @@ -3010,6 +3003,7 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) end do a%irp(nr+1) = ip #endif + call a%set_host() end subroutine psb_z_cp_csr_from_coo @@ -3129,7 +3123,7 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) character(len=20) :: name='mv_from_coo' #if defined(OPENMP) - integer(psb_ipk_), allocatable :: sum(:) + integer(psb_ipk_), allocatable :: suma(:) integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s integer(psb_ipk_) :: nxt_val,old_val,saved_elem #endif @@ -3156,90 +3150,88 @@ 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(none) & + !$OMP shared(suma,nthreads,nr,a,itemp,nza) & + !$OMP private(ithread,work,i,first_idx,last_idx,s) + + !$OMP WORKSHARE a%irp(:) = 0 + !$OMP END WORKSHARE -#if defined(OPENMP) - !$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) + !$OMP private(k) do k=1,nza i = itemp(k) - a%irp(i) = a%irp(i) + 1 + !$OMP ATOMIC UPDATE + a%irp(i+1) = a%irp(i+1) + 1 + !$OMP END ATOMIC end do !$OMP END DO - + !$OMP SINGLE nthreads = omp_get_num_threads() - allocate(sum(nthreads+1)) - sum(:) = 0 - sum(1) = 1 + allocate(suma(nthreads+1)) + suma(:) = 0 + !suma(1) = 1 !$OMP END SINGLE - ithread = omp_get_thread_num() - work = nr/nthreads - if (ithread < MOD(nr,nthreads)) then + + work = (nr+1)/nthreads + if (ithread < MOD((nr+1),nthreads)) then work = work + 1 first_idx = ithread*work + 1 else - first_idx = ithread*work + MOD(nr,nthreads) + 1 + first_idx = ithread*work + MOD((nr+1),nthreads) + 1 end if - last_idx = first_idx + work - 1 - + last_idx = min(first_idx + work - 1,nr+1) s = 0 - do i=first_idx,last_idx - s = s + a%irp(i) - end do - if (work > 0) then - sum(ithread+2) = s + if (first_idx<=last_idx) then + suma(ithread+2) = suma(ithread+2) + a%irp(first_idx) + do i=first_idx+1,last_idx + suma(ithread+2) = suma(ithread+2) + a%irp(i) + a%irp(i) = a%irp(i)+a%irp(i-1) + end do end if - !$OMP BARRIER - !$OMP SINGLE do i=2,nthreads+1 - sum(i) = sum(i) + sum(i-1) + suma(i) = suma(i) + suma(i-1) end do - !$OMP END SINGLE + !$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 + !$OMP BARRIER - 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 + !$OMP DO SCHEDULE(STATIC) + do i=1,nr+1 + a%irp(i) = suma(ithread+1) + a%irp(i) +1 end do + !$OMP END DO + !$OMP SINGLE + a%irp(1) = 1 + !$OMP END SINGLE !$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 + a%irp(:) = 0 + 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 #endif - + + !write(0,*) name,' Check:',a%irp(nr+1),all(a%irp(1:nr) < a%irp(nr+1)) + !write(0,*) name,a%irp(:) call a%set_host() end subroutine psb_z_mv_csr_from_coo diff --git a/test/omp/psb_tomp.F90 b/test/omp/psb_tomp.F90 index 468eeb5ad..f3d19a250 100644 --- a/test/omp/psb_tomp.F90 +++ b/test/omp/psb_tomp.F90 @@ -639,7 +639,16 @@ contains write(psb_out_unit,'("-total time : ",es12.5)') ttot end if - call a%print('a.mtx',head='Test') +!!$ !$omp parallel +!!$ !$omp master +!!$ block +!!$ character(len=1024) :: fname +!!$ write(fname,'(a,i4.4,a,i4.4,a)') 'a-',iam,'-',np,'.mtx' +!!$ write(0,*) iam,' Size of A ',a%get_nrows(),a%get_ncols(),a%get_nzeros() +!!$ call a%print(fname,head='Test') +!!$ end block +!!$ !$omp end master +!!$ !$omp end parallel call psb_erractionrestore(err_act) return From 02dd204351332fb7f9c4bb9b4e550602dde7935e Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 18 Apr 2023 17:00:22 +0200 Subject: [PATCH 19/63] Implement psi_exscan and use in _from_coo --- base/modules/auxil/psi_c_serial_mod.f90 | 12 + base/modules/auxil/psi_d_serial_mod.f90 | 12 + base/modules/auxil/psi_e_serial_mod.f90 | 12 + base/modules/auxil/psi_i2_serial_mod.f90 | 12 + base/modules/auxil/psi_m_serial_mod.f90 | 12 + base/modules/auxil/psi_s_serial_mod.f90 | 12 + base/modules/auxil/psi_z_serial_mod.f90 | 12 + ...{psb_c_csc_impl.f90 => psb_c_csc_impl.F90} | 34 +- base/serial/impl/psb_c_csr_impl.F90 | 126 +------ ...{psb_d_csc_impl.f90 => psb_d_csc_impl.F90} | 34 +- base/serial/impl/psb_d_csr_impl.F90 | 126 +------ ...{psb_s_csc_impl.f90 => psb_s_csc_impl.F90} | 34 +- base/serial/impl/psb_s_csr_impl.F90 | 126 +------ ...{psb_z_csc_impl.f90 => psb_z_csc_impl.F90} | 34 +- base/serial/impl/psb_z_csr_impl.F90 | 126 +------ base/serial/psi_c_serial_impl.F90 | 91 +++++ base/serial/psi_d_serial_impl.F90 | 91 +++++ base/serial/psi_e_serial_impl.F90 | 330 ++++++++++++++++- base/serial/psi_i2_serial_impl.F90 | 330 ++++++++++++++++- base/serial/psi_m_serial_impl.F90 | 332 +++++++++++++++++- base/serial/psi_s_serial_impl.F90 | 91 +++++ base/serial/psi_z_serial_impl.F90 | 91 +++++ 22 files changed, 1554 insertions(+), 526 deletions(-) rename base/serial/impl/{psb_c_csc_impl.f90 => psb_c_csc_impl.F90} (99%) rename base/serial/impl/{psb_d_csc_impl.f90 => psb_d_csc_impl.F90} (99%) rename base/serial/impl/{psb_s_csc_impl.f90 => psb_s_csc_impl.F90} (99%) rename base/serial/impl/{psb_z_csc_impl.f90 => psb_z_csc_impl.F90} (99%) diff --git a/base/modules/auxil/psi_c_serial_mod.f90 b/base/modules/auxil/psi_c_serial_mod.f90 index 191e7ef36..d62ba3bc4 100644 --- a/base/modules/auxil/psi_c_serial_mod.f90 +++ b/base/modules/auxil/psi_c_serial_mod.f90 @@ -156,4 +156,16 @@ module psi_c_serial_mod end subroutine psi_csctv end interface psi_sct + interface psi_exscan + subroutine psi_c_exscanv(n,x,info,shift,ibase) + 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 + integer(psb_ipk_), intent(in), optional :: ibase + 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..ae88be746 100644 --- a/base/modules/auxil/psi_d_serial_mod.f90 +++ b/base/modules/auxil/psi_d_serial_mod.f90 @@ -156,4 +156,16 @@ module psi_d_serial_mod end subroutine psi_dsctv end interface psi_sct + interface psi_exscan + subroutine psi_d_exscanv(n,x,info,shift,ibase) + 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 + integer(psb_ipk_), intent(in), optional :: ibase + 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..a5544075b 100644 --- a/base/modules/auxil/psi_e_serial_mod.f90 +++ b/base/modules/auxil/psi_e_serial_mod.f90 @@ -156,4 +156,16 @@ module psi_e_serial_mod end subroutine psi_esctv end interface psi_sct + interface psi_exscan + subroutine psi_e_exscanv(n,x,info,shift,ibase) + 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 + integer(psb_ipk_), intent(in), optional :: ibase + 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..c0b5a3276 100644 --- a/base/modules/auxil/psi_i2_serial_mod.f90 +++ b/base/modules/auxil/psi_i2_serial_mod.f90 @@ -156,4 +156,16 @@ module psi_i2_serial_mod end subroutine psi_i2sctv end interface psi_sct + interface psi_exscan + subroutine psi_i2_exscanv(n,x,info,shift,ibase) + 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 + integer(psb_ipk_), intent(in), optional :: ibase + end subroutine psi_i2_exscanv + end interface psi_exscan + end module psi_i2_serial_mod diff --git a/base/modules/auxil/psi_m_serial_mod.f90 b/base/modules/auxil/psi_m_serial_mod.f90 index a80d0ffe6..ab875f7b9 100644 --- a/base/modules/auxil/psi_m_serial_mod.f90 +++ b/base/modules/auxil/psi_m_serial_mod.f90 @@ -156,4 +156,16 @@ module psi_m_serial_mod end subroutine psi_msctv end interface psi_sct + interface psi_exscan + subroutine psi_m_exscanv(n,x,info,shift,ibase) + 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 + integer(psb_ipk_), intent(in), optional :: ibase + 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..fee1afc65 100644 --- a/base/modules/auxil/psi_s_serial_mod.f90 +++ b/base/modules/auxil/psi_s_serial_mod.f90 @@ -156,4 +156,16 @@ module psi_s_serial_mod end subroutine psi_ssctv end interface psi_sct + interface psi_exscan + subroutine psi_s_exscanv(n,x,info,shift,ibase) + 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 + integer(psb_ipk_), intent(in), optional :: ibase + 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..3ab430ccb 100644 --- a/base/modules/auxil/psi_z_serial_mod.f90 +++ b/base/modules/auxil/psi_z_serial_mod.f90 @@ -156,4 +156,16 @@ module psi_z_serial_mod end subroutine psi_zsctv end interface psi_sct + interface psi_exscan + subroutine psi_z_exscanv(n,x,info,shift,ibase) + 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 + integer(psb_ipk_), intent(in), optional :: ibase + end subroutine psi_z_exscanv + end interface psi_exscan + end module psi_z_serial_mod diff --git a/base/serial/impl/psb_c_csc_impl.f90 b/base/serial/impl/psb_c_csc_impl.F90 similarity index 99% rename from base/serial/impl/psb_c_csc_impl.f90 rename to base/serial/impl/psb_c_csc_impl.F90 index 87d7e3dda..c573a40d8 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,35 @@ 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(none) & + !$OMP shared(nr,a,itemp,nza) & + !$OMP private(i,info) + + !$OMP WORKSHARE a%icp(:) = 0 + !$OMP END WORKSHARE + + !$OMP DO schedule(STATIC) & + !$OMP private(k) 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 + !$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 +#endif + call psi_exscan(nc+1,a%icp,info,shift=ione,ibase=ione) call a%set_host() diff --git a/base/serial/impl/psb_c_csr_impl.F90 b/base/serial/impl/psb_c_csr_impl.F90 index e091e020f..388e9e2b0 100644 --- a/base/serial/impl/psb_c_csr_impl.F90 +++ b/base/serial/impl/psb_c_csr_impl.F90 @@ -2876,12 +2876,6 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) character(len=20) :: name='c_cp_csr_from_coo' logical :: use_openmp = .false. -#if defined(OPENMP) - integer(psb_ipk_), allocatable :: suma(:) - integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s,j - integer(psb_ipk_) :: nxt_val,old_val,saved_elem,maxthreads -#endif - info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2927,8 +2921,8 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) #if defined(OPENMP) !$OMP PARALLEL default(none) & - !$OMP shared(suma,nthreads,nr,a,itemp,nza) & - !$OMP private(ithread,work,i,first_idx,last_idx,s) + !$OMP shared(nr,a,itemp,nza) & + !$OMP private(i,info) !$OMP WORKSHARE a%irp(:) = 0 @@ -2943,51 +2937,6 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO - - !$OMP SINGLE - nthreads = omp_get_num_threads() - allocate(suma(nthreads+1)) - suma(:) = 0 - !suma(1) = 1 - !$OMP END SINGLE - ithread = omp_get_thread_num() - - - work = (nr+1)/nthreads - if (ithread < MOD((nr+1),nthreads)) then - work = work + 1 - first_idx = ithread*work + 1 - else - first_idx = ithread*work + MOD((nr+1),nthreads) + 1 - end if - - last_idx = min(first_idx + work - 1,nr+1) - s = 0 - if (first_idx<=last_idx) then - suma(ithread+2) = suma(ithread+2) + a%irp(first_idx) - do i=first_idx+1,last_idx - suma(ithread+2) = suma(ithread+2) + a%irp(i) - a%irp(i) = a%irp(i)+a%irp(i-1) - end do - end if - !$OMP BARRIER - !$OMP SINGLE - do i=2,nthreads+1 - suma(i) = suma(i) + suma(i-1) - end do - !$OMP END SINGLE - - !$OMP BARRIER - - !$OMP DO SCHEDULE(STATIC) - do i=1,nr+1 - a%irp(i) = suma(ithread+1) + a%irp(i) +1 - end do - !$OMP END DO - !$OMP SINGLE - a%irp(1) = 1 - !$OMP END SINGLE - !$OMP END PARALLEL #else a%irp(:) = 0 @@ -2995,14 +2944,8 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) 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 #endif + call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) call a%set_host() @@ -3122,12 +3065,6 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='mv_from_coo' -#if defined(OPENMP) - integer(psb_ipk_), allocatable :: suma(:) - integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s - integer(psb_ipk_) :: nxt_val,old_val,saved_elem -#endif - info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -3153,8 +3090,8 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) #if defined(OPENMP) !$OMP PARALLEL default(none) & - !$OMP shared(suma,nthreads,nr,a,itemp,nza) & - !$OMP private(ithread,work,i,first_idx,last_idx,s) + !$OMP shared(nr,a,itemp,nza) & + !$OMP private(i,info) !$OMP WORKSHARE a%irp(:) = 0 @@ -3169,51 +3106,6 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO - - !$OMP SINGLE - nthreads = omp_get_num_threads() - allocate(suma(nthreads+1)) - suma(:) = 0 - !suma(1) = 1 - !$OMP END SINGLE - ithread = omp_get_thread_num() - - - work = (nr+1)/nthreads - if (ithread < MOD((nr+1),nthreads)) then - work = work + 1 - first_idx = ithread*work + 1 - else - first_idx = ithread*work + MOD((nr+1),nthreads) + 1 - end if - - last_idx = min(first_idx + work - 1,nr+1) - s = 0 - if (first_idx<=last_idx) then - suma(ithread+2) = suma(ithread+2) + a%irp(first_idx) - do i=first_idx+1,last_idx - suma(ithread+2) = suma(ithread+2) + a%irp(i) - a%irp(i) = a%irp(i)+a%irp(i-1) - end do - end if - !$OMP BARRIER - !$OMP SINGLE - do i=2,nthreads+1 - suma(i) = suma(i) + suma(i-1) - end do - !$OMP END SINGLE - - !$OMP BARRIER - - !$OMP DO SCHEDULE(STATIC) - do i=1,nr+1 - a%irp(i) = suma(ithread+1) + a%irp(i) +1 - end do - !$OMP END DO - !$OMP SINGLE - a%irp(1) = 1 - !$OMP END SINGLE - !$OMP END PARALLEL #else a%irp(:) = 0 @@ -3221,14 +3113,8 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) 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 #endif + call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) !write(0,*) name,' Check:',a%irp(nr+1),all(a%irp(1:nr) < a%irp(nr+1)) !write(0,*) name,a%irp(:) diff --git a/base/serial/impl/psb_d_csc_impl.f90 b/base/serial/impl/psb_d_csc_impl.F90 similarity index 99% rename from base/serial/impl/psb_d_csc_impl.f90 rename to base/serial/impl/psb_d_csc_impl.F90 index 4f10439b5..891df5a32 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,35 @@ 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(none) & + !$OMP shared(nr,a,itemp,nza) & + !$OMP private(i,info) + + !$OMP WORKSHARE a%icp(:) = 0 + !$OMP END WORKSHARE + + !$OMP DO schedule(STATIC) & + !$OMP private(k) 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 + !$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 +#endif + call psi_exscan(nc+1,a%icp,info,shift=ione,ibase=ione) call a%set_host() diff --git a/base/serial/impl/psb_d_csr_impl.F90 b/base/serial/impl/psb_d_csr_impl.F90 index e6b9f9582..1762604de 100644 --- a/base/serial/impl/psb_d_csr_impl.F90 +++ b/base/serial/impl/psb_d_csr_impl.F90 @@ -2876,12 +2876,6 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) character(len=20) :: name='d_cp_csr_from_coo' logical :: use_openmp = .false. -#if defined(OPENMP) - integer(psb_ipk_), allocatable :: suma(:) - integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s,j - integer(psb_ipk_) :: nxt_val,old_val,saved_elem,maxthreads -#endif - info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2927,8 +2921,8 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) #if defined(OPENMP) !$OMP PARALLEL default(none) & - !$OMP shared(suma,nthreads,nr,a,itemp,nza) & - !$OMP private(ithread,work,i,first_idx,last_idx,s) + !$OMP shared(nr,a,itemp,nza) & + !$OMP private(i,info) !$OMP WORKSHARE a%irp(:) = 0 @@ -2943,51 +2937,6 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO - - !$OMP SINGLE - nthreads = omp_get_num_threads() - allocate(suma(nthreads+1)) - suma(:) = 0 - !suma(1) = 1 - !$OMP END SINGLE - ithread = omp_get_thread_num() - - - work = (nr+1)/nthreads - if (ithread < MOD((nr+1),nthreads)) then - work = work + 1 - first_idx = ithread*work + 1 - else - first_idx = ithread*work + MOD((nr+1),nthreads) + 1 - end if - - last_idx = min(first_idx + work - 1,nr+1) - s = 0 - if (first_idx<=last_idx) then - suma(ithread+2) = suma(ithread+2) + a%irp(first_idx) - do i=first_idx+1,last_idx - suma(ithread+2) = suma(ithread+2) + a%irp(i) - a%irp(i) = a%irp(i)+a%irp(i-1) - end do - end if - !$OMP BARRIER - !$OMP SINGLE - do i=2,nthreads+1 - suma(i) = suma(i) + suma(i-1) - end do - !$OMP END SINGLE - - !$OMP BARRIER - - !$OMP DO SCHEDULE(STATIC) - do i=1,nr+1 - a%irp(i) = suma(ithread+1) + a%irp(i) +1 - end do - !$OMP END DO - !$OMP SINGLE - a%irp(1) = 1 - !$OMP END SINGLE - !$OMP END PARALLEL #else a%irp(:) = 0 @@ -2995,14 +2944,8 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) 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 #endif + call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) call a%set_host() @@ -3122,12 +3065,6 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='mv_from_coo' -#if defined(OPENMP) - integer(psb_ipk_), allocatable :: suma(:) - integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s - integer(psb_ipk_) :: nxt_val,old_val,saved_elem -#endif - info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -3153,8 +3090,8 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) #if defined(OPENMP) !$OMP PARALLEL default(none) & - !$OMP shared(suma,nthreads,nr,a,itemp,nza) & - !$OMP private(ithread,work,i,first_idx,last_idx,s) + !$OMP shared(nr,a,itemp,nza) & + !$OMP private(i,info) !$OMP WORKSHARE a%irp(:) = 0 @@ -3169,51 +3106,6 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO - - !$OMP SINGLE - nthreads = omp_get_num_threads() - allocate(suma(nthreads+1)) - suma(:) = 0 - !suma(1) = 1 - !$OMP END SINGLE - ithread = omp_get_thread_num() - - - work = (nr+1)/nthreads - if (ithread < MOD((nr+1),nthreads)) then - work = work + 1 - first_idx = ithread*work + 1 - else - first_idx = ithread*work + MOD((nr+1),nthreads) + 1 - end if - - last_idx = min(first_idx + work - 1,nr+1) - s = 0 - if (first_idx<=last_idx) then - suma(ithread+2) = suma(ithread+2) + a%irp(first_idx) - do i=first_idx+1,last_idx - suma(ithread+2) = suma(ithread+2) + a%irp(i) - a%irp(i) = a%irp(i)+a%irp(i-1) - end do - end if - !$OMP BARRIER - !$OMP SINGLE - do i=2,nthreads+1 - suma(i) = suma(i) + suma(i-1) - end do - !$OMP END SINGLE - - !$OMP BARRIER - - !$OMP DO SCHEDULE(STATIC) - do i=1,nr+1 - a%irp(i) = suma(ithread+1) + a%irp(i) +1 - end do - !$OMP END DO - !$OMP SINGLE - a%irp(1) = 1 - !$OMP END SINGLE - !$OMP END PARALLEL #else a%irp(:) = 0 @@ -3221,14 +3113,8 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) 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 #endif + call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) !write(0,*) name,' Check:',a%irp(nr+1),all(a%irp(1:nr) < a%irp(nr+1)) !write(0,*) name,a%irp(:) diff --git a/base/serial/impl/psb_s_csc_impl.f90 b/base/serial/impl/psb_s_csc_impl.F90 similarity index 99% rename from base/serial/impl/psb_s_csc_impl.f90 rename to base/serial/impl/psb_s_csc_impl.F90 index e52086d1f..2bf77184d 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,35 @@ 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(none) & + !$OMP shared(nr,a,itemp,nza) & + !$OMP private(i,info) + + !$OMP WORKSHARE a%icp(:) = 0 + !$OMP END WORKSHARE + + !$OMP DO schedule(STATIC) & + !$OMP private(k) 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 + !$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 +#endif + call psi_exscan(nc+1,a%icp,info,shift=ione,ibase=ione) call a%set_host() diff --git a/base/serial/impl/psb_s_csr_impl.F90 b/base/serial/impl/psb_s_csr_impl.F90 index 73f5484ab..71da21a42 100644 --- a/base/serial/impl/psb_s_csr_impl.F90 +++ b/base/serial/impl/psb_s_csr_impl.F90 @@ -2876,12 +2876,6 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) character(len=20) :: name='s_cp_csr_from_coo' logical :: use_openmp = .false. -#if defined(OPENMP) - integer(psb_ipk_), allocatable :: suma(:) - integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s,j - integer(psb_ipk_) :: nxt_val,old_val,saved_elem,maxthreads -#endif - info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2927,8 +2921,8 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) #if defined(OPENMP) !$OMP PARALLEL default(none) & - !$OMP shared(suma,nthreads,nr,a,itemp,nza) & - !$OMP private(ithread,work,i,first_idx,last_idx,s) + !$OMP shared(nr,a,itemp,nza) & + !$OMP private(i,info) !$OMP WORKSHARE a%irp(:) = 0 @@ -2943,51 +2937,6 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO - - !$OMP SINGLE - nthreads = omp_get_num_threads() - allocate(suma(nthreads+1)) - suma(:) = 0 - !suma(1) = 1 - !$OMP END SINGLE - ithread = omp_get_thread_num() - - - work = (nr+1)/nthreads - if (ithread < MOD((nr+1),nthreads)) then - work = work + 1 - first_idx = ithread*work + 1 - else - first_idx = ithread*work + MOD((nr+1),nthreads) + 1 - end if - - last_idx = min(first_idx + work - 1,nr+1) - s = 0 - if (first_idx<=last_idx) then - suma(ithread+2) = suma(ithread+2) + a%irp(first_idx) - do i=first_idx+1,last_idx - suma(ithread+2) = suma(ithread+2) + a%irp(i) - a%irp(i) = a%irp(i)+a%irp(i-1) - end do - end if - !$OMP BARRIER - !$OMP SINGLE - do i=2,nthreads+1 - suma(i) = suma(i) + suma(i-1) - end do - !$OMP END SINGLE - - !$OMP BARRIER - - !$OMP DO SCHEDULE(STATIC) - do i=1,nr+1 - a%irp(i) = suma(ithread+1) + a%irp(i) +1 - end do - !$OMP END DO - !$OMP SINGLE - a%irp(1) = 1 - !$OMP END SINGLE - !$OMP END PARALLEL #else a%irp(:) = 0 @@ -2995,14 +2944,8 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) 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 #endif + call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) call a%set_host() @@ -3122,12 +3065,6 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='mv_from_coo' -#if defined(OPENMP) - integer(psb_ipk_), allocatable :: suma(:) - integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s - integer(psb_ipk_) :: nxt_val,old_val,saved_elem -#endif - info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -3153,8 +3090,8 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) #if defined(OPENMP) !$OMP PARALLEL default(none) & - !$OMP shared(suma,nthreads,nr,a,itemp,nza) & - !$OMP private(ithread,work,i,first_idx,last_idx,s) + !$OMP shared(nr,a,itemp,nza) & + !$OMP private(i,info) !$OMP WORKSHARE a%irp(:) = 0 @@ -3169,51 +3106,6 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO - - !$OMP SINGLE - nthreads = omp_get_num_threads() - allocate(suma(nthreads+1)) - suma(:) = 0 - !suma(1) = 1 - !$OMP END SINGLE - ithread = omp_get_thread_num() - - - work = (nr+1)/nthreads - if (ithread < MOD((nr+1),nthreads)) then - work = work + 1 - first_idx = ithread*work + 1 - else - first_idx = ithread*work + MOD((nr+1),nthreads) + 1 - end if - - last_idx = min(first_idx + work - 1,nr+1) - s = 0 - if (first_idx<=last_idx) then - suma(ithread+2) = suma(ithread+2) + a%irp(first_idx) - do i=first_idx+1,last_idx - suma(ithread+2) = suma(ithread+2) + a%irp(i) - a%irp(i) = a%irp(i)+a%irp(i-1) - end do - end if - !$OMP BARRIER - !$OMP SINGLE - do i=2,nthreads+1 - suma(i) = suma(i) + suma(i-1) - end do - !$OMP END SINGLE - - !$OMP BARRIER - - !$OMP DO SCHEDULE(STATIC) - do i=1,nr+1 - a%irp(i) = suma(ithread+1) + a%irp(i) +1 - end do - !$OMP END DO - !$OMP SINGLE - a%irp(1) = 1 - !$OMP END SINGLE - !$OMP END PARALLEL #else a%irp(:) = 0 @@ -3221,14 +3113,8 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) 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 #endif + call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) !write(0,*) name,' Check:',a%irp(nr+1),all(a%irp(1:nr) < a%irp(nr+1)) !write(0,*) name,a%irp(:) diff --git a/base/serial/impl/psb_z_csc_impl.f90 b/base/serial/impl/psb_z_csc_impl.F90 similarity index 99% rename from base/serial/impl/psb_z_csc_impl.f90 rename to base/serial/impl/psb_z_csc_impl.F90 index 8b0ccc65b..22ea36774 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,35 @@ 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(none) & + !$OMP shared(nr,a,itemp,nza) & + !$OMP private(i,info) + + !$OMP WORKSHARE a%icp(:) = 0 + !$OMP END WORKSHARE + + !$OMP DO schedule(STATIC) & + !$OMP private(k) 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 + !$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 +#endif + call psi_exscan(nc+1,a%icp,info,shift=ione,ibase=ione) call a%set_host() diff --git a/base/serial/impl/psb_z_csr_impl.F90 b/base/serial/impl/psb_z_csr_impl.F90 index b07e37b74..34332f467 100644 --- a/base/serial/impl/psb_z_csr_impl.F90 +++ b/base/serial/impl/psb_z_csr_impl.F90 @@ -2876,12 +2876,6 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) character(len=20) :: name='z_cp_csr_from_coo' logical :: use_openmp = .false. -#if defined(OPENMP) - integer(psb_ipk_), allocatable :: suma(:) - integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s,j - integer(psb_ipk_) :: nxt_val,old_val,saved_elem,maxthreads -#endif - info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2927,8 +2921,8 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) #if defined(OPENMP) !$OMP PARALLEL default(none) & - !$OMP shared(suma,nthreads,nr,a,itemp,nza) & - !$OMP private(ithread,work,i,first_idx,last_idx,s) + !$OMP shared(nr,a,itemp,nza) & + !$OMP private(i,info) !$OMP WORKSHARE a%irp(:) = 0 @@ -2943,51 +2937,6 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO - - !$OMP SINGLE - nthreads = omp_get_num_threads() - allocate(suma(nthreads+1)) - suma(:) = 0 - !suma(1) = 1 - !$OMP END SINGLE - ithread = omp_get_thread_num() - - - work = (nr+1)/nthreads - if (ithread < MOD((nr+1),nthreads)) then - work = work + 1 - first_idx = ithread*work + 1 - else - first_idx = ithread*work + MOD((nr+1),nthreads) + 1 - end if - - last_idx = min(first_idx + work - 1,nr+1) - s = 0 - if (first_idx<=last_idx) then - suma(ithread+2) = suma(ithread+2) + a%irp(first_idx) - do i=first_idx+1,last_idx - suma(ithread+2) = suma(ithread+2) + a%irp(i) - a%irp(i) = a%irp(i)+a%irp(i-1) - end do - end if - !$OMP BARRIER - !$OMP SINGLE - do i=2,nthreads+1 - suma(i) = suma(i) + suma(i-1) - end do - !$OMP END SINGLE - - !$OMP BARRIER - - !$OMP DO SCHEDULE(STATIC) - do i=1,nr+1 - a%irp(i) = suma(ithread+1) + a%irp(i) +1 - end do - !$OMP END DO - !$OMP SINGLE - a%irp(1) = 1 - !$OMP END SINGLE - !$OMP END PARALLEL #else a%irp(:) = 0 @@ -2995,14 +2944,8 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) 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 #endif + call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) call a%set_host() @@ -3122,12 +3065,6 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='mv_from_coo' -#if defined(OPENMP) - integer(psb_ipk_), allocatable :: suma(:) - integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s - integer(psb_ipk_) :: nxt_val,old_val,saved_elem -#endif - info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -3153,8 +3090,8 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) #if defined(OPENMP) !$OMP PARALLEL default(none) & - !$OMP shared(suma,nthreads,nr,a,itemp,nza) & - !$OMP private(ithread,work,i,first_idx,last_idx,s) + !$OMP shared(nr,a,itemp,nza) & + !$OMP private(i,info) !$OMP WORKSHARE a%irp(:) = 0 @@ -3169,51 +3106,6 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO - - !$OMP SINGLE - nthreads = omp_get_num_threads() - allocate(suma(nthreads+1)) - suma(:) = 0 - !suma(1) = 1 - !$OMP END SINGLE - ithread = omp_get_thread_num() - - - work = (nr+1)/nthreads - if (ithread < MOD((nr+1),nthreads)) then - work = work + 1 - first_idx = ithread*work + 1 - else - first_idx = ithread*work + MOD((nr+1),nthreads) + 1 - end if - - last_idx = min(first_idx + work - 1,nr+1) - s = 0 - if (first_idx<=last_idx) then - suma(ithread+2) = suma(ithread+2) + a%irp(first_idx) - do i=first_idx+1,last_idx - suma(ithread+2) = suma(ithread+2) + a%irp(i) - a%irp(i) = a%irp(i)+a%irp(i-1) - end do - end if - !$OMP BARRIER - !$OMP SINGLE - do i=2,nthreads+1 - suma(i) = suma(i) + suma(i-1) - end do - !$OMP END SINGLE - - !$OMP BARRIER - - !$OMP DO SCHEDULE(STATIC) - do i=1,nr+1 - a%irp(i) = suma(ithread+1) + a%irp(i) +1 - end do - !$OMP END DO - !$OMP SINGLE - a%irp(1) = 1 - !$OMP END SINGLE - !$OMP END PARALLEL #else a%irp(:) = 0 @@ -3221,14 +3113,8 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) 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 #endif + call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) !write(0,*) name,' Check:',a%irp(nr+1),all(a%irp(1:nr) < a%irp(nr+1)) !write(0,*) name,a%irp(:) diff --git a/base/serial/psi_c_serial_impl.F90 b/base/serial/psi_c_serial_impl.F90 index 1da2ce6ee..91f463f41 100644 --- a/base/serial/psi_c_serial_impl.F90 +++ b/base/serial/psi_c_serial_impl.F90 @@ -29,6 +29,97 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +subroutine psi_c_exscanv(n,x,info,shift,ibase) + 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 + integer(psb_ipk_), intent(in), optional :: ibase + + complex(psb_spk_) :: shift_, tp, ts + complex(psb_spk_), allocatable :: suma(:) + integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk, ibase_ + + if (present(shift)) then + shift_ = shift + else + shift_ = czero + end if + if (present(ibase)) then + ibase_ = ibase + else + ibase_ = ione + end if + +#if defined(OPENMP) + + !$OMP PARALLEL default(none) & + !$OMP shared(suma,nthreads,n,x,shift_,ibase_) & + !$OMP private(ithread,wrk,i,first_idx,last_idx) + + !$OMP SINGLE + nthreads = omp_get_num_threads() + allocate(suma(nthreads+1)) + suma(:) = 0 + !suma(1) = 1 + !$OMP END SINGLE + ithread = omp_get_thread_num() + + + wrk = (n)/nthreads + if (ithread < MOD((n),nthreads)) then + wrk = wrk + 1 + first_idx = ithread*wrk + ibase_ + else + first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + end if + + last_idx = min(first_idx + wrk - 1,n - (ibase_-ione)) + if (first_idx<=last_idx) then + suma(ithread+2) = suma(ithread+2) + x(first_idx) + do i=first_idx+1,last_idx + suma(ithread+2) = suma(ithread+2) + x(i) + x(i) = x(i)+x(i-1) + end do + end if + !$OMP BARRIER + !$OMP SINGLE + do i=2,nthreads+1 + suma(i) = suma(i) + suma(i-1) + end do + !$OMP END SINGLE + + !$OMP BARRIER + + !$OMP DO SCHEDULE(STATIC) + do i=1,n + x(i) = suma(ithread+1) + x(i) + shift_ + end do + !$OMP END DO + !$OMP SINGLE + x(1) = shift_ + !$OMP END SINGLE + + !$OMP END PARALLEL +#else + tp = shift_ + do i=1,n + ts = x(i) + x(i) = tp + tp = tp + ts + end do + +#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..d8fb92d7b 100644 --- a/base/serial/psi_d_serial_impl.F90 +++ b/base/serial/psi_d_serial_impl.F90 @@ -29,6 +29,97 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +subroutine psi_d_exscanv(n,x,info,shift,ibase) + 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 + integer(psb_ipk_), intent(in), optional :: ibase + + real(psb_dpk_) :: shift_, tp, ts + real(psb_dpk_), allocatable :: suma(:) + integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk, ibase_ + + if (present(shift)) then + shift_ = shift + else + shift_ = dzero + end if + if (present(ibase)) then + ibase_ = ibase + else + ibase_ = ione + end if + +#if defined(OPENMP) + + !$OMP PARALLEL default(none) & + !$OMP shared(suma,nthreads,n,x,shift_,ibase_) & + !$OMP private(ithread,wrk,i,first_idx,last_idx) + + !$OMP SINGLE + nthreads = omp_get_num_threads() + allocate(suma(nthreads+1)) + suma(:) = 0 + !suma(1) = 1 + !$OMP END SINGLE + ithread = omp_get_thread_num() + + + wrk = (n)/nthreads + if (ithread < MOD((n),nthreads)) then + wrk = wrk + 1 + first_idx = ithread*wrk + ibase_ + else + first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + end if + + last_idx = min(first_idx + wrk - 1,n - (ibase_-ione)) + if (first_idx<=last_idx) then + suma(ithread+2) = suma(ithread+2) + x(first_idx) + do i=first_idx+1,last_idx + suma(ithread+2) = suma(ithread+2) + x(i) + x(i) = x(i)+x(i-1) + end do + end if + !$OMP BARRIER + !$OMP SINGLE + do i=2,nthreads+1 + suma(i) = suma(i) + suma(i-1) + end do + !$OMP END SINGLE + + !$OMP BARRIER + + !$OMP DO SCHEDULE(STATIC) + do i=1,n + x(i) = suma(ithread+1) + x(i) + shift_ + end do + !$OMP END DO + !$OMP SINGLE + x(1) = shift_ + !$OMP END SINGLE + + !$OMP END PARALLEL +#else + tp = shift_ + do i=1,n + ts = x(i) + x(i) = tp + tp = tp + ts + end do + +#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..24ce41f10 100644 --- a/base/serial/psi_e_serial_impl.F90 +++ b/base/serial/psi_e_serial_impl.F90 @@ -29,6 +29,97 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +subroutine psi_e_exscanv(n,x,info,shift,ibase) + 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_ipk_), intent(in), optional :: ibase + + integer(psb_epk_) :: shift_, tp, ts + integer(psb_epk_), allocatable :: suma(:) + integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk, ibase_ + + if (present(shift)) then + shift_ = shift + else + shift_ = ezero + end if + if (present(ibase)) then + ibase_ = ibase + else + ibase_ = ione + end if + +#if defined(OPENMP) + + !$OMP PARALLEL default(none) & + !$OMP shared(suma,nthreads,n,x,shift_,ibase_) & + !$OMP private(ithread,wrk,i,first_idx,last_idx) + + !$OMP SINGLE + nthreads = omp_get_num_threads() + allocate(suma(nthreads+1)) + suma(:) = 0 + !suma(1) = 1 + !$OMP END SINGLE + ithread = omp_get_thread_num() + + + wrk = (n)/nthreads + if (ithread < MOD((n),nthreads)) then + wrk = wrk + 1 + first_idx = ithread*wrk + ibase_ + else + first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + end if + + last_idx = min(first_idx + wrk - 1,n - (ibase_-ione)) + if (first_idx<=last_idx) then + suma(ithread+2) = suma(ithread+2) + x(first_idx) + do i=first_idx+1,last_idx + suma(ithread+2) = suma(ithread+2) + x(i) + x(i) = x(i)+x(i-1) + end do + end if + !$OMP BARRIER + !$OMP SINGLE + do i=2,nthreads+1 + suma(i) = suma(i) + suma(i-1) + end do + !$OMP END SINGLE + + !$OMP BARRIER + + !$OMP DO SCHEDULE(STATIC) + do i=1,n + x(i) = suma(ithread+1) + x(i) + shift_ + end do + !$OMP END DO + !$OMP SINGLE + x(1) = shift_ + !$OMP END SINGLE + + !$OMP END PARALLEL +#else + tp = shift_ + do i=1,n + ts = x(i) + x(i) = tp + tp = tp + ts + end do + +#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 +532,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 +593,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 +624,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 +746,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 +785,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 +1231,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 +1243,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 +1261,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 +1276,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 +1294,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 +1309,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 +1327,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 +1342,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 +1435,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 +1453,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 +1468,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 +1486,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 +1501,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 +1519,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 +1534,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..c58890137 100644 --- a/base/serial/psi_i2_serial_impl.F90 +++ b/base/serial/psi_i2_serial_impl.F90 @@ -29,6 +29,97 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +subroutine psi_i2_exscanv(n,x,info,shift,ibase) + 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_ipk_), intent(in), optional :: ibase + + integer(psb_i2pk_) :: shift_, tp, ts + integer(psb_i2pk_), allocatable :: suma(:) + integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk, ibase_ + + if (present(shift)) then + shift_ = shift + else + shift_ = i2zero + end if + if (present(ibase)) then + ibase_ = ibase + else + ibase_ = ione + end if + +#if defined(OPENMP) + + !$OMP PARALLEL default(none) & + !$OMP shared(suma,nthreads,n,x,shift_,ibase_) & + !$OMP private(ithread,wrk,i,first_idx,last_idx) + + !$OMP SINGLE + nthreads = omp_get_num_threads() + allocate(suma(nthreads+1)) + suma(:) = 0 + !suma(1) = 1 + !$OMP END SINGLE + ithread = omp_get_thread_num() + + + wrk = (n)/nthreads + if (ithread < MOD((n),nthreads)) then + wrk = wrk + 1 + first_idx = ithread*wrk + ibase_ + else + first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + end if + + last_idx = min(first_idx + wrk - 1,n - (ibase_-ione)) + if (first_idx<=last_idx) then + suma(ithread+2) = suma(ithread+2) + x(first_idx) + do i=first_idx+1,last_idx + suma(ithread+2) = suma(ithread+2) + x(i) + x(i) = x(i)+x(i-1) + end do + end if + !$OMP BARRIER + !$OMP SINGLE + do i=2,nthreads+1 + suma(i) = suma(i) + suma(i-1) + end do + !$OMP END SINGLE + + !$OMP BARRIER + + !$OMP DO SCHEDULE(STATIC) + do i=1,n + x(i) = suma(ithread+1) + x(i) + shift_ + end do + !$OMP END DO + !$OMP SINGLE + x(1) = shift_ + !$OMP END SINGLE + + !$OMP END PARALLEL +#else + tp = shift_ + do i=1,n + ts = x(i) + x(i) = tp + tp = tp + ts + end do + +#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 +532,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 +593,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 +624,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 +746,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 +785,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 +1231,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 +1243,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 +1261,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 +1276,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 +1294,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 +1309,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 +1327,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 +1342,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 +1435,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 +1453,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 +1468,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 +1486,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 +1501,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 +1519,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 +1534,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..d7849cd74 100644 --- a/base/serial/psi_m_serial_impl.F90 +++ b/base/serial/psi_m_serial_impl.F90 @@ -29,6 +29,99 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +subroutine psi_m_exscanv(n,x,info,shift,ibase) + 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_ipk_), intent(in), optional :: ibase + + integer(psb_mpk_) :: shift_, tp, ts + integer(psb_mpk_), allocatable :: suma(:) + integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk, ibase_ + logical is_nested + + if (present(shift)) then + shift_ = shift + else + shift_ = mzero + end if + if (present(ibase)) then + ibase_ = ibase + else + ibase_ = ione + end if + +#if defined(OPENMP) + is_nested = omp_get_nested() + call omp_set_nested(.true.) + !$OMP PARALLEL default(none) & + !$OMP shared(suma,nthreads,n,x,shift_,ibase_) & + !$OMP private(ithread,wrk,i,first_idx,last_idx) + + !$OMP SINGLE + nthreads = omp_get_num_threads() + allocate(suma(nthreads+1)) + suma(:) = 0 + !suma(1) = 1 + !$OMP END SINGLE + ithread = omp_get_thread_num() + + + wrk = (n)/nthreads + if (ithread < MOD((n),nthreads)) then + wrk = wrk + 1 + first_idx = ithread*wrk + ibase_ + else + first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + end if + + last_idx = min(first_idx + wrk - 1,n - (ibase_-ione)) + if (first_idx<=last_idx) then + suma(ithread+2) = suma(ithread+2) + x(first_idx) + do i=first_idx+1,last_idx + suma(ithread+2) = suma(ithread+2) + x(i) + x(i) = x(i)+x(i-1) + end do + end if + !$OMP BARRIER + !$OMP SINGLE + do i=2,nthreads+1 + suma(i) = suma(i) + suma(i-1) + end do + !$OMP END SINGLE + + !$OMP BARRIER + + !$OMP DO SCHEDULE(STATIC) + do i=1,n + x(i) = suma(ithread+1) + x(i) + shift_ + end do + !$OMP END DO + !$OMP SINGLE + x(1) = shift_ + !$OMP END SINGLE + !$OMP END PARALLEL + call omp_set_nested(is_nested) +#else + tp = shift_ + do i=1,n + ts = x(i) + x(i) = tp + tp = tp + ts + end do + +#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 +534,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 +595,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 +626,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 +748,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 +787,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 +1233,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 +1245,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 +1263,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 +1278,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 +1296,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 +1311,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 +1329,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 +1344,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 +1437,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 +1455,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 +1470,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 +1488,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 +1503,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 +1521,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 +1536,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..ec22ade74 100644 --- a/base/serial/psi_s_serial_impl.F90 +++ b/base/serial/psi_s_serial_impl.F90 @@ -29,6 +29,97 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +subroutine psi_s_exscanv(n,x,info,shift,ibase) + 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 + integer(psb_ipk_), intent(in), optional :: ibase + + real(psb_spk_) :: shift_, tp, ts + real(psb_spk_), allocatable :: suma(:) + integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk, ibase_ + + if (present(shift)) then + shift_ = shift + else + shift_ = szero + end if + if (present(ibase)) then + ibase_ = ibase + else + ibase_ = ione + end if + +#if defined(OPENMP) + + !$OMP PARALLEL default(none) & + !$OMP shared(suma,nthreads,n,x,shift_,ibase_) & + !$OMP private(ithread,wrk,i,first_idx,last_idx) + + !$OMP SINGLE + nthreads = omp_get_num_threads() + allocate(suma(nthreads+1)) + suma(:) = 0 + !suma(1) = 1 + !$OMP END SINGLE + ithread = omp_get_thread_num() + + + wrk = (n)/nthreads + if (ithread < MOD((n),nthreads)) then + wrk = wrk + 1 + first_idx = ithread*wrk + ibase_ + else + first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + end if + + last_idx = min(first_idx + wrk - 1,n - (ibase_-ione)) + if (first_idx<=last_idx) then + suma(ithread+2) = suma(ithread+2) + x(first_idx) + do i=first_idx+1,last_idx + suma(ithread+2) = suma(ithread+2) + x(i) + x(i) = x(i)+x(i-1) + end do + end if + !$OMP BARRIER + !$OMP SINGLE + do i=2,nthreads+1 + suma(i) = suma(i) + suma(i-1) + end do + !$OMP END SINGLE + + !$OMP BARRIER + + !$OMP DO SCHEDULE(STATIC) + do i=1,n + x(i) = suma(ithread+1) + x(i) + shift_ + end do + !$OMP END DO + !$OMP SINGLE + x(1) = shift_ + !$OMP END SINGLE + + !$OMP END PARALLEL +#else + tp = shift_ + do i=1,n + ts = x(i) + x(i) = tp + tp = tp + ts + end do + +#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..9bcdfd7e2 100644 --- a/base/serial/psi_z_serial_impl.F90 +++ b/base/serial/psi_z_serial_impl.F90 @@ -29,6 +29,97 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +subroutine psi_z_exscanv(n,x,info,shift,ibase) + 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 + integer(psb_ipk_), intent(in), optional :: ibase + + complex(psb_dpk_) :: shift_, tp, ts + complex(psb_dpk_), allocatable :: suma(:) + integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk, ibase_ + + if (present(shift)) then + shift_ = shift + else + shift_ = zzero + end if + if (present(ibase)) then + ibase_ = ibase + else + ibase_ = ione + end if + +#if defined(OPENMP) + + !$OMP PARALLEL default(none) & + !$OMP shared(suma,nthreads,n,x,shift_,ibase_) & + !$OMP private(ithread,wrk,i,first_idx,last_idx) + + !$OMP SINGLE + nthreads = omp_get_num_threads() + allocate(suma(nthreads+1)) + suma(:) = 0 + !suma(1) = 1 + !$OMP END SINGLE + ithread = omp_get_thread_num() + + + wrk = (n)/nthreads + if (ithread < MOD((n),nthreads)) then + wrk = wrk + 1 + first_idx = ithread*wrk + ibase_ + else + first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + end if + + last_idx = min(first_idx + wrk - 1,n - (ibase_-ione)) + if (first_idx<=last_idx) then + suma(ithread+2) = suma(ithread+2) + x(first_idx) + do i=first_idx+1,last_idx + suma(ithread+2) = suma(ithread+2) + x(i) + x(i) = x(i)+x(i-1) + end do + end if + !$OMP BARRIER + !$OMP SINGLE + do i=2,nthreads+1 + suma(i) = suma(i) + suma(i-1) + end do + !$OMP END SINGLE + + !$OMP BARRIER + + !$OMP DO SCHEDULE(STATIC) + do i=1,n + x(i) = suma(ithread+1) + x(i) + shift_ + end do + !$OMP END DO + !$OMP SINGLE + x(1) = shift_ + !$OMP END SINGLE + + !$OMP END PARALLEL +#else + tp = shift_ + do i=1,n + ts = x(i) + x(i) = tp + tp = tp + ts + end do + +#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 From 9c248a31e2a74248cbab7028f00b16ffcdf34b75 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Wed, 19 Apr 2023 12:12:58 +0200 Subject: [PATCH 20/63] Refactored EXSCAN and its OpenMP usage. --- base/serial/impl/psb_c_csr_impl.F90 | 20 ++--- base/serial/impl/psb_d_csr_impl.F90 | 20 ++--- base/serial/impl/psb_s_csr_impl.F90 | 20 ++--- base/serial/impl/psb_z_csr_impl.F90 | 20 ++--- base/serial/psi_c_serial_impl.F90 | 113 +++++++++++++++------------ base/serial/psi_d_serial_impl.F90 | 113 +++++++++++++++------------ base/serial/psi_e_serial_impl.F90 | 113 +++++++++++++++------------ base/serial/psi_i2_serial_impl.F90 | 113 +++++++++++++++------------ base/serial/psi_m_serial_impl.F90 | 115 +++++++++++++++------------- base/serial/psi_s_serial_impl.F90 | 113 +++++++++++++++------------ base/serial/psi_z_serial_impl.F90 | 113 +++++++++++++++------------ 11 files changed, 473 insertions(+), 400 deletions(-) diff --git a/base/serial/impl/psb_c_csr_impl.F90 b/base/serial/impl/psb_c_csr_impl.F90 index 388e9e2b0..b742204d1 100644 --- a/base/serial/impl/psb_c_csr_impl.F90 +++ b/base/serial/impl/psb_c_csr_impl.F90 @@ -2920,16 +2920,14 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) #if defined(OPENMP) - !$OMP PARALLEL default(none) & - !$OMP shared(nr,a,itemp,nza) & - !$OMP private(i,info) + !$OMP PARALLEL default(shared) reduction(max:info) !$OMP WORKSHARE a%irp(:) = 0 !$OMP END WORKSHARE !$OMP DO schedule(STATIC) & - !$OMP private(k) + !$OMP private(k,i) do k=1,nza i = itemp(k) !$OMP ATOMIC UPDATE @@ -2937,6 +2935,7 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO + call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) !$OMP END PARALLEL #else a%irp(:) = 0 @@ -2944,8 +2943,8 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) i = itemp(k) a%irp(i) = a%irp(i) + 1 end do + call psi_exscan(nr+1,a%irp,info,shift=cone,ibase=ione) #endif - call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) call a%set_host() @@ -3089,16 +3088,14 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) #if defined(OPENMP) - !$OMP PARALLEL default(none) & - !$OMP shared(nr,a,itemp,nza) & - !$OMP private(i,info) + !$OMP PARALLEL default(shared) reduction(max:info) !$OMP WORKSHARE a%irp(:) = 0 !$OMP END WORKSHARE !$OMP DO schedule(STATIC) & - !$OMP private(k) + !$OMP private(k,i) do k=1,nza i = itemp(k) !$OMP ATOMIC UPDATE @@ -3106,6 +3103,7 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO + call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) !$OMP END PARALLEL #else a%irp(:) = 0 @@ -3113,11 +3111,9 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) i = itemp(k) a%irp(i) = a%irp(i) + 1 end do -#endif call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) +#endif - !write(0,*) name,' Check:',a%irp(nr+1),all(a%irp(1:nr) < a%irp(nr+1)) - !write(0,*) name,a%irp(:) call a%set_host() end subroutine psb_c_mv_csr_from_coo diff --git a/base/serial/impl/psb_d_csr_impl.F90 b/base/serial/impl/psb_d_csr_impl.F90 index 1762604de..86287e324 100644 --- a/base/serial/impl/psb_d_csr_impl.F90 +++ b/base/serial/impl/psb_d_csr_impl.F90 @@ -2920,16 +2920,14 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) #if defined(OPENMP) - !$OMP PARALLEL default(none) & - !$OMP shared(nr,a,itemp,nza) & - !$OMP private(i,info) + !$OMP PARALLEL default(shared) reduction(max:info) !$OMP WORKSHARE a%irp(:) = 0 !$OMP END WORKSHARE !$OMP DO schedule(STATIC) & - !$OMP private(k) + !$OMP private(k,i) do k=1,nza i = itemp(k) !$OMP ATOMIC UPDATE @@ -2937,6 +2935,7 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO + call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) !$OMP END PARALLEL #else a%irp(:) = 0 @@ -2944,8 +2943,8 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) i = itemp(k) a%irp(i) = a%irp(i) + 1 end do + call psi_exscan(nr+1,a%irp,info,shift=done,ibase=ione) #endif - call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) call a%set_host() @@ -3089,16 +3088,14 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) #if defined(OPENMP) - !$OMP PARALLEL default(none) & - !$OMP shared(nr,a,itemp,nza) & - !$OMP private(i,info) + !$OMP PARALLEL default(shared) reduction(max:info) !$OMP WORKSHARE a%irp(:) = 0 !$OMP END WORKSHARE !$OMP DO schedule(STATIC) & - !$OMP private(k) + !$OMP private(k,i) do k=1,nza i = itemp(k) !$OMP ATOMIC UPDATE @@ -3106,6 +3103,7 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO + call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) !$OMP END PARALLEL #else a%irp(:) = 0 @@ -3113,11 +3111,9 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) i = itemp(k) a%irp(i) = a%irp(i) + 1 end do -#endif call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) +#endif - !write(0,*) name,' Check:',a%irp(nr+1),all(a%irp(1:nr) < a%irp(nr+1)) - !write(0,*) name,a%irp(:) call a%set_host() end subroutine psb_d_mv_csr_from_coo diff --git a/base/serial/impl/psb_s_csr_impl.F90 b/base/serial/impl/psb_s_csr_impl.F90 index 71da21a42..46ead8fc3 100644 --- a/base/serial/impl/psb_s_csr_impl.F90 +++ b/base/serial/impl/psb_s_csr_impl.F90 @@ -2920,16 +2920,14 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) #if defined(OPENMP) - !$OMP PARALLEL default(none) & - !$OMP shared(nr,a,itemp,nza) & - !$OMP private(i,info) + !$OMP PARALLEL default(shared) reduction(max:info) !$OMP WORKSHARE a%irp(:) = 0 !$OMP END WORKSHARE !$OMP DO schedule(STATIC) & - !$OMP private(k) + !$OMP private(k,i) do k=1,nza i = itemp(k) !$OMP ATOMIC UPDATE @@ -2937,6 +2935,7 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO + call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) !$OMP END PARALLEL #else a%irp(:) = 0 @@ -2944,8 +2943,8 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) i = itemp(k) a%irp(i) = a%irp(i) + 1 end do + call psi_exscan(nr+1,a%irp,info,shift=sone,ibase=ione) #endif - call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) call a%set_host() @@ -3089,16 +3088,14 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) #if defined(OPENMP) - !$OMP PARALLEL default(none) & - !$OMP shared(nr,a,itemp,nza) & - !$OMP private(i,info) + !$OMP PARALLEL default(shared) reduction(max:info) !$OMP WORKSHARE a%irp(:) = 0 !$OMP END WORKSHARE !$OMP DO schedule(STATIC) & - !$OMP private(k) + !$OMP private(k,i) do k=1,nza i = itemp(k) !$OMP ATOMIC UPDATE @@ -3106,6 +3103,7 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO + call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) !$OMP END PARALLEL #else a%irp(:) = 0 @@ -3113,11 +3111,9 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) i = itemp(k) a%irp(i) = a%irp(i) + 1 end do -#endif call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) +#endif - !write(0,*) name,' Check:',a%irp(nr+1),all(a%irp(1:nr) < a%irp(nr+1)) - !write(0,*) name,a%irp(:) call a%set_host() end subroutine psb_s_mv_csr_from_coo diff --git a/base/serial/impl/psb_z_csr_impl.F90 b/base/serial/impl/psb_z_csr_impl.F90 index 34332f467..b6ec8fe71 100644 --- a/base/serial/impl/psb_z_csr_impl.F90 +++ b/base/serial/impl/psb_z_csr_impl.F90 @@ -2920,16 +2920,14 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) #if defined(OPENMP) - !$OMP PARALLEL default(none) & - !$OMP shared(nr,a,itemp,nza) & - !$OMP private(i,info) + !$OMP PARALLEL default(shared) reduction(max:info) !$OMP WORKSHARE a%irp(:) = 0 !$OMP END WORKSHARE !$OMP DO schedule(STATIC) & - !$OMP private(k) + !$OMP private(k,i) do k=1,nza i = itemp(k) !$OMP ATOMIC UPDATE @@ -2937,6 +2935,7 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO + call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) !$OMP END PARALLEL #else a%irp(:) = 0 @@ -2944,8 +2943,8 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) i = itemp(k) a%irp(i) = a%irp(i) + 1 end do + call psi_exscan(nr+1,a%irp,info,shift=zone,ibase=ione) #endif - call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) call a%set_host() @@ -3089,16 +3088,14 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) #if defined(OPENMP) - !$OMP PARALLEL default(none) & - !$OMP shared(nr,a,itemp,nza) & - !$OMP private(i,info) + !$OMP PARALLEL default(shared) reduction(max:info) !$OMP WORKSHARE a%irp(:) = 0 !$OMP END WORKSHARE !$OMP DO schedule(STATIC) & - !$OMP private(k) + !$OMP private(k,i) do k=1,nza i = itemp(k) !$OMP ATOMIC UPDATE @@ -3106,6 +3103,7 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO + call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) !$OMP END PARALLEL #else a%irp(:) = 0 @@ -3113,11 +3111,9 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) i = itemp(k) a%irp(i) = a%irp(i) + 1 end do -#endif call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) +#endif - !write(0,*) name,' Check:',a%irp(nr+1),all(a%irp(1:nr) < a%irp(nr+1)) - !write(0,*) name,a%irp(:) call a%set_host() end subroutine psb_z_mv_csr_from_coo diff --git a/base/serial/psi_c_serial_impl.F90 b/base/serial/psi_c_serial_impl.F90 index 91f463f41..2391becbe 100644 --- a/base/serial/psi_c_serial_impl.F90 +++ b/base/serial/psi_c_serial_impl.F90 @@ -44,8 +44,8 @@ subroutine psi_c_exscanv(n,x,info,shift,ibase) integer(psb_ipk_), intent(in), optional :: ibase complex(psb_spk_) :: shift_, tp, ts - complex(psb_spk_), allocatable :: suma(:) - integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk, ibase_ + integer(psb_ipk_) :: ibase_ + logical is_nested, is_parallel if (present(shift)) then shift_ = shift @@ -59,55 +59,14 @@ subroutine psi_c_exscanv(n,x,info,shift,ibase) end if #if defined(OPENMP) - - !$OMP PARALLEL default(none) & - !$OMP shared(suma,nthreads,n,x,shift_,ibase_) & - !$OMP private(ithread,wrk,i,first_idx,last_idx) - - !$OMP SINGLE - nthreads = omp_get_num_threads() - allocate(suma(nthreads+1)) - suma(:) = 0 - !suma(1) = 1 - !$OMP END SINGLE - ithread = omp_get_thread_num() - - - wrk = (n)/nthreads - if (ithread < MOD((n),nthreads)) then - wrk = wrk + 1 - first_idx = ithread*wrk + ibase_ + is_parallel = omp_in_parallel() + if (is_parallel) then + call inner_c_exscan() else - first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ - end if - - last_idx = min(first_idx + wrk - 1,n - (ibase_-ione)) - if (first_idx<=last_idx) then - suma(ithread+2) = suma(ithread+2) + x(first_idx) - do i=first_idx+1,last_idx - suma(ithread+2) = suma(ithread+2) + x(i) - x(i) = x(i)+x(i-1) - end do + !$OMP PARALLEL default(shared) + call inner_c_exscan() + !$OMP END PARALLEL end if - !$OMP BARRIER - !$OMP SINGLE - do i=2,nthreads+1 - suma(i) = suma(i) + suma(i-1) - end do - !$OMP END SINGLE - - !$OMP BARRIER - - !$OMP DO SCHEDULE(STATIC) - do i=1,n - x(i) = suma(ithread+1) + x(i) + shift_ - end do - !$OMP END DO - !$OMP SINGLE - x(1) = shift_ - !$OMP END SINGLE - - !$OMP END PARALLEL #else tp = shift_ do i=1,n @@ -117,7 +76,61 @@ subroutine psi_c_exscanv(n,x,info,shift,ibase) 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. + integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk + complex(psb_spk_), pointer :: sumb(:) + + 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 + first_idx = ithread*wrk + ibase_ + else + first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + end if + + last_idx = min(first_idx + wrk - 1,n - (ione-ibase_)) + if (first_idx<=last_idx) then + sumb(ithread+2) = sumb(ithread+2) + x(first_idx) + do i=first_idx+1,last_idx + sumb(ithread+2) = sumb(ithread+2) + x(i) + x(i) = x(i)+x(i-1) + end do + end if + !$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) = sumb(ithread+1) + x(i) + shift_ + end do + !$OMP END DO + !$OMP SINGLE + x(1) = shift_ + deallocate(sumb) + !$OMP END SINGLE + end subroutine inner_c_exscan +#endif end subroutine psi_c_exscanv subroutine psb_m_cgelp(trans,iperm,x,info) diff --git a/base/serial/psi_d_serial_impl.F90 b/base/serial/psi_d_serial_impl.F90 index d8fb92d7b..099dd1d46 100644 --- a/base/serial/psi_d_serial_impl.F90 +++ b/base/serial/psi_d_serial_impl.F90 @@ -44,8 +44,8 @@ subroutine psi_d_exscanv(n,x,info,shift,ibase) integer(psb_ipk_), intent(in), optional :: ibase real(psb_dpk_) :: shift_, tp, ts - real(psb_dpk_), allocatable :: suma(:) - integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk, ibase_ + integer(psb_ipk_) :: ibase_ + logical is_nested, is_parallel if (present(shift)) then shift_ = shift @@ -59,55 +59,14 @@ subroutine psi_d_exscanv(n,x,info,shift,ibase) end if #if defined(OPENMP) - - !$OMP PARALLEL default(none) & - !$OMP shared(suma,nthreads,n,x,shift_,ibase_) & - !$OMP private(ithread,wrk,i,first_idx,last_idx) - - !$OMP SINGLE - nthreads = omp_get_num_threads() - allocate(suma(nthreads+1)) - suma(:) = 0 - !suma(1) = 1 - !$OMP END SINGLE - ithread = omp_get_thread_num() - - - wrk = (n)/nthreads - if (ithread < MOD((n),nthreads)) then - wrk = wrk + 1 - first_idx = ithread*wrk + ibase_ + is_parallel = omp_in_parallel() + if (is_parallel) then + call inner_d_exscan() else - first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ - end if - - last_idx = min(first_idx + wrk - 1,n - (ibase_-ione)) - if (first_idx<=last_idx) then - suma(ithread+2) = suma(ithread+2) + x(first_idx) - do i=first_idx+1,last_idx - suma(ithread+2) = suma(ithread+2) + x(i) - x(i) = x(i)+x(i-1) - end do + !$OMP PARALLEL default(shared) + call inner_d_exscan() + !$OMP END PARALLEL end if - !$OMP BARRIER - !$OMP SINGLE - do i=2,nthreads+1 - suma(i) = suma(i) + suma(i-1) - end do - !$OMP END SINGLE - - !$OMP BARRIER - - !$OMP DO SCHEDULE(STATIC) - do i=1,n - x(i) = suma(ithread+1) + x(i) + shift_ - end do - !$OMP END DO - !$OMP SINGLE - x(1) = shift_ - !$OMP END SINGLE - - !$OMP END PARALLEL #else tp = shift_ do i=1,n @@ -117,7 +76,61 @@ subroutine psi_d_exscanv(n,x,info,shift,ibase) 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. + integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk + real(psb_dpk_), pointer :: sumb(:) + + 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 + first_idx = ithread*wrk + ibase_ + else + first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + end if + + last_idx = min(first_idx + wrk - 1,n - (ione-ibase_)) + if (first_idx<=last_idx) then + sumb(ithread+2) = sumb(ithread+2) + x(first_idx) + do i=first_idx+1,last_idx + sumb(ithread+2) = sumb(ithread+2) + x(i) + x(i) = x(i)+x(i-1) + end do + end if + !$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) = sumb(ithread+1) + x(i) + shift_ + end do + !$OMP END DO + !$OMP SINGLE + x(1) = shift_ + deallocate(sumb) + !$OMP END SINGLE + end subroutine inner_d_exscan +#endif end subroutine psi_d_exscanv subroutine psb_m_dgelp(trans,iperm,x,info) diff --git a/base/serial/psi_e_serial_impl.F90 b/base/serial/psi_e_serial_impl.F90 index 24ce41f10..10ca93b42 100644 --- a/base/serial/psi_e_serial_impl.F90 +++ b/base/serial/psi_e_serial_impl.F90 @@ -44,8 +44,8 @@ subroutine psi_e_exscanv(n,x,info,shift,ibase) integer(psb_ipk_), intent(in), optional :: ibase integer(psb_epk_) :: shift_, tp, ts - integer(psb_epk_), allocatable :: suma(:) - integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk, ibase_ + integer(psb_ipk_) :: ibase_ + logical is_nested, is_parallel if (present(shift)) then shift_ = shift @@ -59,55 +59,14 @@ subroutine psi_e_exscanv(n,x,info,shift,ibase) end if #if defined(OPENMP) - - !$OMP PARALLEL default(none) & - !$OMP shared(suma,nthreads,n,x,shift_,ibase_) & - !$OMP private(ithread,wrk,i,first_idx,last_idx) - - !$OMP SINGLE - nthreads = omp_get_num_threads() - allocate(suma(nthreads+1)) - suma(:) = 0 - !suma(1) = 1 - !$OMP END SINGLE - ithread = omp_get_thread_num() - - - wrk = (n)/nthreads - if (ithread < MOD((n),nthreads)) then - wrk = wrk + 1 - first_idx = ithread*wrk + ibase_ + is_parallel = omp_in_parallel() + if (is_parallel) then + call inner_e_exscan() else - first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ - end if - - last_idx = min(first_idx + wrk - 1,n - (ibase_-ione)) - if (first_idx<=last_idx) then - suma(ithread+2) = suma(ithread+2) + x(first_idx) - do i=first_idx+1,last_idx - suma(ithread+2) = suma(ithread+2) + x(i) - x(i) = x(i)+x(i-1) - end do + !$OMP PARALLEL default(shared) + call inner_e_exscan() + !$OMP END PARALLEL end if - !$OMP BARRIER - !$OMP SINGLE - do i=2,nthreads+1 - suma(i) = suma(i) + suma(i-1) - end do - !$OMP END SINGLE - - !$OMP BARRIER - - !$OMP DO SCHEDULE(STATIC) - do i=1,n - x(i) = suma(ithread+1) + x(i) + shift_ - end do - !$OMP END DO - !$OMP SINGLE - x(1) = shift_ - !$OMP END SINGLE - - !$OMP END PARALLEL #else tp = shift_ do i=1,n @@ -117,7 +76,61 @@ subroutine psi_e_exscanv(n,x,info,shift,ibase) 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. + integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk + integer(psb_epk_), pointer :: sumb(:) + + 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 + first_idx = ithread*wrk + ibase_ + else + first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + end if + + last_idx = min(first_idx + wrk - 1,n - (ione-ibase_)) + if (first_idx<=last_idx) then + sumb(ithread+2) = sumb(ithread+2) + x(first_idx) + do i=first_idx+1,last_idx + sumb(ithread+2) = sumb(ithread+2) + x(i) + x(i) = x(i)+x(i-1) + end do + end if + !$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) = sumb(ithread+1) + x(i) + shift_ + end do + !$OMP END DO + !$OMP SINGLE + x(1) = shift_ + deallocate(sumb) + !$OMP END SINGLE + end subroutine inner_e_exscan +#endif end subroutine psi_e_exscanv subroutine psb_m_egelp(trans,iperm,x,info) diff --git a/base/serial/psi_i2_serial_impl.F90 b/base/serial/psi_i2_serial_impl.F90 index c58890137..3ccd35bc7 100644 --- a/base/serial/psi_i2_serial_impl.F90 +++ b/base/serial/psi_i2_serial_impl.F90 @@ -44,8 +44,8 @@ subroutine psi_i2_exscanv(n,x,info,shift,ibase) integer(psb_ipk_), intent(in), optional :: ibase integer(psb_i2pk_) :: shift_, tp, ts - integer(psb_i2pk_), allocatable :: suma(:) - integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk, ibase_ + integer(psb_ipk_) :: ibase_ + logical is_nested, is_parallel if (present(shift)) then shift_ = shift @@ -59,55 +59,14 @@ subroutine psi_i2_exscanv(n,x,info,shift,ibase) end if #if defined(OPENMP) - - !$OMP PARALLEL default(none) & - !$OMP shared(suma,nthreads,n,x,shift_,ibase_) & - !$OMP private(ithread,wrk,i,first_idx,last_idx) - - !$OMP SINGLE - nthreads = omp_get_num_threads() - allocate(suma(nthreads+1)) - suma(:) = 0 - !suma(1) = 1 - !$OMP END SINGLE - ithread = omp_get_thread_num() - - - wrk = (n)/nthreads - if (ithread < MOD((n),nthreads)) then - wrk = wrk + 1 - first_idx = ithread*wrk + ibase_ + is_parallel = omp_in_parallel() + if (is_parallel) then + call inner_i2_exscan() else - first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ - end if - - last_idx = min(first_idx + wrk - 1,n - (ibase_-ione)) - if (first_idx<=last_idx) then - suma(ithread+2) = suma(ithread+2) + x(first_idx) - do i=first_idx+1,last_idx - suma(ithread+2) = suma(ithread+2) + x(i) - x(i) = x(i)+x(i-1) - end do + !$OMP PARALLEL default(shared) + call inner_i2_exscan() + !$OMP END PARALLEL end if - !$OMP BARRIER - !$OMP SINGLE - do i=2,nthreads+1 - suma(i) = suma(i) + suma(i-1) - end do - !$OMP END SINGLE - - !$OMP BARRIER - - !$OMP DO SCHEDULE(STATIC) - do i=1,n - x(i) = suma(ithread+1) + x(i) + shift_ - end do - !$OMP END DO - !$OMP SINGLE - x(1) = shift_ - !$OMP END SINGLE - - !$OMP END PARALLEL #else tp = shift_ do i=1,n @@ -117,7 +76,61 @@ subroutine psi_i2_exscanv(n,x,info,shift,ibase) 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. + integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk + integer(psb_i2pk_), pointer :: sumb(:) + + 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 + first_idx = ithread*wrk + ibase_ + else + first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + end if + + last_idx = min(first_idx + wrk - 1,n - (ione-ibase_)) + if (first_idx<=last_idx) then + sumb(ithread+2) = sumb(ithread+2) + x(first_idx) + do i=first_idx+1,last_idx + sumb(ithread+2) = sumb(ithread+2) + x(i) + x(i) = x(i)+x(i-1) + end do + end if + !$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) = sumb(ithread+1) + x(i) + shift_ + end do + !$OMP END DO + !$OMP SINGLE + x(1) = shift_ + deallocate(sumb) + !$OMP END SINGLE + end subroutine inner_i2_exscan +#endif end subroutine psi_i2_exscanv subroutine psb_m_i2gelp(trans,iperm,x,info) diff --git a/base/serial/psi_m_serial_impl.F90 b/base/serial/psi_m_serial_impl.F90 index d7849cd74..c3d73e5af 100644 --- a/base/serial/psi_m_serial_impl.F90 +++ b/base/serial/psi_m_serial_impl.F90 @@ -44,9 +44,8 @@ subroutine psi_m_exscanv(n,x,info,shift,ibase) integer(psb_ipk_), intent(in), optional :: ibase integer(psb_mpk_) :: shift_, tp, ts - integer(psb_mpk_), allocatable :: suma(:) - integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk, ibase_ - logical is_nested + integer(psb_ipk_) :: ibase_ + logical is_nested, is_parallel if (present(shift)) then shift_ = shift @@ -60,56 +59,14 @@ subroutine psi_m_exscanv(n,x,info,shift,ibase) end if #if defined(OPENMP) - is_nested = omp_get_nested() - call omp_set_nested(.true.) - !$OMP PARALLEL default(none) & - !$OMP shared(suma,nthreads,n,x,shift_,ibase_) & - !$OMP private(ithread,wrk,i,first_idx,last_idx) - - !$OMP SINGLE - nthreads = omp_get_num_threads() - allocate(suma(nthreads+1)) - suma(:) = 0 - !suma(1) = 1 - !$OMP END SINGLE - ithread = omp_get_thread_num() - - - wrk = (n)/nthreads - if (ithread < MOD((n),nthreads)) then - wrk = wrk + 1 - first_idx = ithread*wrk + ibase_ + is_parallel = omp_in_parallel() + if (is_parallel) then + call inner_m_exscan() else - first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + !$OMP PARALLEL default(shared) + call inner_m_exscan() + !$OMP END PARALLEL end if - - last_idx = min(first_idx + wrk - 1,n - (ibase_-ione)) - if (first_idx<=last_idx) then - suma(ithread+2) = suma(ithread+2) + x(first_idx) - do i=first_idx+1,last_idx - suma(ithread+2) = suma(ithread+2) + x(i) - x(i) = x(i)+x(i-1) - end do - end if - !$OMP BARRIER - !$OMP SINGLE - do i=2,nthreads+1 - suma(i) = suma(i) + suma(i-1) - end do - !$OMP END SINGLE - - !$OMP BARRIER - - !$OMP DO SCHEDULE(STATIC) - do i=1,n - x(i) = suma(ithread+1) + x(i) + shift_ - end do - !$OMP END DO - !$OMP SINGLE - x(1) = shift_ - !$OMP END SINGLE - !$OMP END PARALLEL - call omp_set_nested(is_nested) #else tp = shift_ do i=1,n @@ -119,7 +76,61 @@ subroutine psi_m_exscanv(n,x,info,shift,ibase) 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. + integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk + integer(psb_mpk_), pointer :: sumb(:) + + 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 + first_idx = ithread*wrk + ibase_ + else + first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + end if + + last_idx = min(first_idx + wrk - 1,n - (ione-ibase_)) + if (first_idx<=last_idx) then + sumb(ithread+2) = sumb(ithread+2) + x(first_idx) + do i=first_idx+1,last_idx + sumb(ithread+2) = sumb(ithread+2) + x(i) + x(i) = x(i)+x(i-1) + end do + end if + !$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) = sumb(ithread+1) + x(i) + shift_ + end do + !$OMP END DO + !$OMP SINGLE + x(1) = shift_ + deallocate(sumb) + !$OMP END SINGLE + end subroutine inner_m_exscan +#endif end subroutine psi_m_exscanv subroutine psb_m_mgelp(trans,iperm,x,info) diff --git a/base/serial/psi_s_serial_impl.F90 b/base/serial/psi_s_serial_impl.F90 index ec22ade74..fd1c4cd4a 100644 --- a/base/serial/psi_s_serial_impl.F90 +++ b/base/serial/psi_s_serial_impl.F90 @@ -44,8 +44,8 @@ subroutine psi_s_exscanv(n,x,info,shift,ibase) integer(psb_ipk_), intent(in), optional :: ibase real(psb_spk_) :: shift_, tp, ts - real(psb_spk_), allocatable :: suma(:) - integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk, ibase_ + integer(psb_ipk_) :: ibase_ + logical is_nested, is_parallel if (present(shift)) then shift_ = shift @@ -59,55 +59,14 @@ subroutine psi_s_exscanv(n,x,info,shift,ibase) end if #if defined(OPENMP) - - !$OMP PARALLEL default(none) & - !$OMP shared(suma,nthreads,n,x,shift_,ibase_) & - !$OMP private(ithread,wrk,i,first_idx,last_idx) - - !$OMP SINGLE - nthreads = omp_get_num_threads() - allocate(suma(nthreads+1)) - suma(:) = 0 - !suma(1) = 1 - !$OMP END SINGLE - ithread = omp_get_thread_num() - - - wrk = (n)/nthreads - if (ithread < MOD((n),nthreads)) then - wrk = wrk + 1 - first_idx = ithread*wrk + ibase_ + is_parallel = omp_in_parallel() + if (is_parallel) then + call inner_s_exscan() else - first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ - end if - - last_idx = min(first_idx + wrk - 1,n - (ibase_-ione)) - if (first_idx<=last_idx) then - suma(ithread+2) = suma(ithread+2) + x(first_idx) - do i=first_idx+1,last_idx - suma(ithread+2) = suma(ithread+2) + x(i) - x(i) = x(i)+x(i-1) - end do + !$OMP PARALLEL default(shared) + call inner_s_exscan() + !$OMP END PARALLEL end if - !$OMP BARRIER - !$OMP SINGLE - do i=2,nthreads+1 - suma(i) = suma(i) + suma(i-1) - end do - !$OMP END SINGLE - - !$OMP BARRIER - - !$OMP DO SCHEDULE(STATIC) - do i=1,n - x(i) = suma(ithread+1) + x(i) + shift_ - end do - !$OMP END DO - !$OMP SINGLE - x(1) = shift_ - !$OMP END SINGLE - - !$OMP END PARALLEL #else tp = shift_ do i=1,n @@ -117,7 +76,61 @@ subroutine psi_s_exscanv(n,x,info,shift,ibase) 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. + integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk + real(psb_spk_), pointer :: sumb(:) + + 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 + first_idx = ithread*wrk + ibase_ + else + first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + end if + + last_idx = min(first_idx + wrk - 1,n - (ione-ibase_)) + if (first_idx<=last_idx) then + sumb(ithread+2) = sumb(ithread+2) + x(first_idx) + do i=first_idx+1,last_idx + sumb(ithread+2) = sumb(ithread+2) + x(i) + x(i) = x(i)+x(i-1) + end do + end if + !$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) = sumb(ithread+1) + x(i) + shift_ + end do + !$OMP END DO + !$OMP SINGLE + x(1) = shift_ + deallocate(sumb) + !$OMP END SINGLE + end subroutine inner_s_exscan +#endif end subroutine psi_s_exscanv subroutine psb_m_sgelp(trans,iperm,x,info) diff --git a/base/serial/psi_z_serial_impl.F90 b/base/serial/psi_z_serial_impl.F90 index 9bcdfd7e2..bf0554769 100644 --- a/base/serial/psi_z_serial_impl.F90 +++ b/base/serial/psi_z_serial_impl.F90 @@ -44,8 +44,8 @@ subroutine psi_z_exscanv(n,x,info,shift,ibase) integer(psb_ipk_), intent(in), optional :: ibase complex(psb_dpk_) :: shift_, tp, ts - complex(psb_dpk_), allocatable :: suma(:) - integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk, ibase_ + integer(psb_ipk_) :: ibase_ + logical is_nested, is_parallel if (present(shift)) then shift_ = shift @@ -59,55 +59,14 @@ subroutine psi_z_exscanv(n,x,info,shift,ibase) end if #if defined(OPENMP) - - !$OMP PARALLEL default(none) & - !$OMP shared(suma,nthreads,n,x,shift_,ibase_) & - !$OMP private(ithread,wrk,i,first_idx,last_idx) - - !$OMP SINGLE - nthreads = omp_get_num_threads() - allocate(suma(nthreads+1)) - suma(:) = 0 - !suma(1) = 1 - !$OMP END SINGLE - ithread = omp_get_thread_num() - - - wrk = (n)/nthreads - if (ithread < MOD((n),nthreads)) then - wrk = wrk + 1 - first_idx = ithread*wrk + ibase_ + is_parallel = omp_in_parallel() + if (is_parallel) then + call inner_z_exscan() else - first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ - end if - - last_idx = min(first_idx + wrk - 1,n - (ibase_-ione)) - if (first_idx<=last_idx) then - suma(ithread+2) = suma(ithread+2) + x(first_idx) - do i=first_idx+1,last_idx - suma(ithread+2) = suma(ithread+2) + x(i) - x(i) = x(i)+x(i-1) - end do + !$OMP PARALLEL default(shared) + call inner_z_exscan() + !$OMP END PARALLEL end if - !$OMP BARRIER - !$OMP SINGLE - do i=2,nthreads+1 - suma(i) = suma(i) + suma(i-1) - end do - !$OMP END SINGLE - - !$OMP BARRIER - - !$OMP DO SCHEDULE(STATIC) - do i=1,n - x(i) = suma(ithread+1) + x(i) + shift_ - end do - !$OMP END DO - !$OMP SINGLE - x(1) = shift_ - !$OMP END SINGLE - - !$OMP END PARALLEL #else tp = shift_ do i=1,n @@ -117,7 +76,61 @@ subroutine psi_z_exscanv(n,x,info,shift,ibase) 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. + integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk + complex(psb_dpk_), pointer :: sumb(:) + + 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 + first_idx = ithread*wrk + ibase_ + else + first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + end if + + last_idx = min(first_idx + wrk - 1,n - (ione-ibase_)) + if (first_idx<=last_idx) then + sumb(ithread+2) = sumb(ithread+2) + x(first_idx) + do i=first_idx+1,last_idx + sumb(ithread+2) = sumb(ithread+2) + x(i) + x(i) = x(i)+x(i-1) + end do + end if + !$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) = sumb(ithread+1) + x(i) + shift_ + end do + !$OMP END DO + !$OMP SINGLE + x(1) = shift_ + deallocate(sumb) + !$OMP END SINGLE + end subroutine inner_z_exscan +#endif end subroutine psi_z_exscanv subroutine psb_m_zgelp(trans,iperm,x,info) From 05b684ddbb947e60cb41a09f87878cb61c16a9a8 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Wed, 19 Apr 2023 13:23:48 +0200 Subject: [PATCH 21/63] Updated use of exscan in CSC --- base/serial/impl/psb_c_csc_impl.F90 | 10 ++++------ base/serial/impl/psb_d_csc_impl.F90 | 10 ++++------ base/serial/impl/psb_s_csc_impl.F90 | 10 ++++------ base/serial/impl/psb_z_csc_impl.F90 | 10 ++++------ 4 files changed, 16 insertions(+), 24 deletions(-) diff --git a/base/serial/impl/psb_c_csc_impl.F90 b/base/serial/impl/psb_c_csc_impl.F90 index c573a40d8..7532d5a09 100644 --- a/base/serial/impl/psb_c_csc_impl.F90 +++ b/base/serial/impl/psb_c_csc_impl.F90 @@ -2228,16 +2228,14 @@ subroutine psb_c_mv_csc_from_coo(a,b,info) #if defined(OPENMP) - !$OMP PARALLEL default(none) & - !$OMP shared(nr,a,itemp,nza) & - !$OMP private(i,info) + !$OMP PARALLEL default(shared) !$OMP WORKSHARE a%icp(:) = 0 !$OMP END WORKSHARE !$OMP DO schedule(STATIC) & - !$OMP private(k) + !$OMP private(k,i) do k=1,nza i = itemp(k) !$OMP ATOMIC UPDATE @@ -2245,16 +2243,16 @@ subroutine psb_c_mv_csc_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO + call psi_exscan(nc+1,a%icp,info,shift=ione,ibase=ione) !$OMP END PARALLEL - #else a%icp(:) = 0 do k=1,nza i = itemp(k) a%icp(i) = a%icp(i) + 1 end do -#endif call psi_exscan(nc+1,a%icp,info,shift=ione,ibase=ione) +#endif call a%set_host() diff --git a/base/serial/impl/psb_d_csc_impl.F90 b/base/serial/impl/psb_d_csc_impl.F90 index 891df5a32..38f746de5 100644 --- a/base/serial/impl/psb_d_csc_impl.F90 +++ b/base/serial/impl/psb_d_csc_impl.F90 @@ -2228,16 +2228,14 @@ subroutine psb_d_mv_csc_from_coo(a,b,info) #if defined(OPENMP) - !$OMP PARALLEL default(none) & - !$OMP shared(nr,a,itemp,nza) & - !$OMP private(i,info) + !$OMP PARALLEL default(shared) !$OMP WORKSHARE a%icp(:) = 0 !$OMP END WORKSHARE !$OMP DO schedule(STATIC) & - !$OMP private(k) + !$OMP private(k,i) do k=1,nza i = itemp(k) !$OMP ATOMIC UPDATE @@ -2245,16 +2243,16 @@ subroutine psb_d_mv_csc_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO + call psi_exscan(nc+1,a%icp,info,shift=ione,ibase=ione) !$OMP END PARALLEL - #else a%icp(:) = 0 do k=1,nza i = itemp(k) a%icp(i) = a%icp(i) + 1 end do -#endif call psi_exscan(nc+1,a%icp,info,shift=ione,ibase=ione) +#endif call a%set_host() diff --git a/base/serial/impl/psb_s_csc_impl.F90 b/base/serial/impl/psb_s_csc_impl.F90 index 2bf77184d..d1fb8c4b6 100644 --- a/base/serial/impl/psb_s_csc_impl.F90 +++ b/base/serial/impl/psb_s_csc_impl.F90 @@ -2228,16 +2228,14 @@ subroutine psb_s_mv_csc_from_coo(a,b,info) #if defined(OPENMP) - !$OMP PARALLEL default(none) & - !$OMP shared(nr,a,itemp,nza) & - !$OMP private(i,info) + !$OMP PARALLEL default(shared) !$OMP WORKSHARE a%icp(:) = 0 !$OMP END WORKSHARE !$OMP DO schedule(STATIC) & - !$OMP private(k) + !$OMP private(k,i) do k=1,nza i = itemp(k) !$OMP ATOMIC UPDATE @@ -2245,16 +2243,16 @@ subroutine psb_s_mv_csc_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO + call psi_exscan(nc+1,a%icp,info,shift=ione,ibase=ione) !$OMP END PARALLEL - #else a%icp(:) = 0 do k=1,nza i = itemp(k) a%icp(i) = a%icp(i) + 1 end do -#endif call psi_exscan(nc+1,a%icp,info,shift=ione,ibase=ione) +#endif call a%set_host() diff --git a/base/serial/impl/psb_z_csc_impl.F90 b/base/serial/impl/psb_z_csc_impl.F90 index 22ea36774..2735bcbdd 100644 --- a/base/serial/impl/psb_z_csc_impl.F90 +++ b/base/serial/impl/psb_z_csc_impl.F90 @@ -2228,16 +2228,14 @@ subroutine psb_z_mv_csc_from_coo(a,b,info) #if defined(OPENMP) - !$OMP PARALLEL default(none) & - !$OMP shared(nr,a,itemp,nza) & - !$OMP private(i,info) + !$OMP PARALLEL default(shared) !$OMP WORKSHARE a%icp(:) = 0 !$OMP END WORKSHARE !$OMP DO schedule(STATIC) & - !$OMP private(k) + !$OMP private(k,i) do k=1,nza i = itemp(k) !$OMP ATOMIC UPDATE @@ -2245,16 +2243,16 @@ subroutine psb_z_mv_csc_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO + call psi_exscan(nc+1,a%icp,info,shift=ione,ibase=ione) !$OMP END PARALLEL - #else a%icp(:) = 0 do k=1,nza i = itemp(k) a%icp(i) = a%icp(i) + 1 end do -#endif call psi_exscan(nc+1,a%icp,info,shift=ione,ibase=ione) +#endif call a%set_host() From 08ff37332a53be836255b7ed41b3d08bc405d462 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Wed, 19 Apr 2023 14:06:40 +0200 Subject: [PATCH 22/63] Enable OpenMP in test/pargen --- test/omp/psb_tomp.F90 | 14 +- test/pargen/psb_d_pde2d.F90 | 216 ++++++++++++++++----------- test/pargen/psb_d_pde3d.F90 | 290 ++++++++++++++---------------------- test/pargen/psb_s_pde2d.F90 | 216 ++++++++++++++++----------- test/pargen/psb_s_pde3d.F90 | 290 ++++++++++++++---------------------- 5 files changed, 467 insertions(+), 559 deletions(-) diff --git a/test/omp/psb_tomp.F90 b/test/omp/psb_tomp.F90 index f3d19a250..fda08f4ed 100644 --- a/test/omp/psb_tomp.F90 +++ b/test/omp/psb_tomp.F90 @@ -452,9 +452,6 @@ contains call psb_barrier(ctxt) t1 = psb_wtime() !$omp parallel shared(deltah,myidx,a,desc_a) - ! 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. ! block integer(psb_ipk_) :: i,j,ii,ib,icoeff, ix,iy,iz, ith,nth @@ -639,16 +636,7 @@ contains write(psb_out_unit,'("-total time : ",es12.5)') ttot end if -!!$ !$omp parallel -!!$ !$omp master -!!$ block -!!$ character(len=1024) :: fname -!!$ write(fname,'(a,i4.4,a,i4.4,a)') 'a-',iam,'-',np,'.mtx' -!!$ write(0,*) iam,' Size of A ',a%get_nrows(),a%get_ncols(),a%get_nzeros() -!!$ call a%print(fname,head='Test') -!!$ end block -!!$ !$omp end master -!!$ !$omp end parallel + call psb_erractionrestore(err_act) return 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 d4eeccf24..6e895c004 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 From f3efea0a893cb7b2246e68a768989d7fec566a5b Mon Sep 17 00:00:00 2001 From: sfilippone Date: Thu, 20 Apr 2023 12:31:32 +0200 Subject: [PATCH 23/63] Take out IBASE from exscan, makes no sense. --- base/modules/auxil/psi_c_serial_mod.f90 | 3 +-- base/modules/auxil/psi_d_serial_mod.f90 | 3 +-- base/modules/auxil/psi_e_serial_mod.f90 | 3 +-- base/modules/auxil/psi_i2_serial_mod.f90 | 3 +-- base/modules/auxil/psi_m_serial_mod.f90 | 3 +-- base/modules/auxil/psi_s_serial_mod.f90 | 3 +-- base/modules/auxil/psi_z_serial_mod.f90 | 3 +-- base/serial/impl/psb_c_csc_impl.F90 | 4 ++-- base/serial/impl/psb_c_csr_impl.F90 | 8 ++++---- base/serial/impl/psb_d_csc_impl.F90 | 4 ++-- base/serial/impl/psb_d_csr_impl.F90 | 8 ++++---- base/serial/impl/psb_s_csc_impl.F90 | 4 ++-- base/serial/impl/psb_s_csr_impl.F90 | 8 ++++---- base/serial/impl/psb_z_csc_impl.F90 | 4 ++-- base/serial/impl/psb_z_csr_impl.F90 | 8 ++++---- base/serial/psi_c_serial_impl.F90 | 15 ++++----------- base/serial/psi_d_serial_impl.F90 | 15 ++++----------- base/serial/psi_e_serial_impl.F90 | 15 ++++----------- base/serial/psi_i2_serial_impl.F90 | 15 ++++----------- base/serial/psi_m_serial_impl.F90 | 15 ++++----------- base/serial/psi_s_serial_impl.F90 | 15 ++++----------- base/serial/psi_z_serial_impl.F90 | 15 ++++----------- 22 files changed, 59 insertions(+), 115 deletions(-) diff --git a/base/modules/auxil/psi_c_serial_mod.f90 b/base/modules/auxil/psi_c_serial_mod.f90 index d62ba3bc4..0fdff04ba 100644 --- a/base/modules/auxil/psi_c_serial_mod.f90 +++ b/base/modules/auxil/psi_c_serial_mod.f90 @@ -157,14 +157,13 @@ module psi_c_serial_mod end interface psi_sct interface psi_exscan - subroutine psi_c_exscanv(n,x,info,shift,ibase) + 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 - integer(psb_ipk_), intent(in), optional :: ibase end subroutine psi_c_exscanv end interface psi_exscan diff --git a/base/modules/auxil/psi_d_serial_mod.f90 b/base/modules/auxil/psi_d_serial_mod.f90 index ae88be746..0ce14dbb9 100644 --- a/base/modules/auxil/psi_d_serial_mod.f90 +++ b/base/modules/auxil/psi_d_serial_mod.f90 @@ -157,14 +157,13 @@ module psi_d_serial_mod end interface psi_sct interface psi_exscan - subroutine psi_d_exscanv(n,x,info,shift,ibase) + 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 - integer(psb_ipk_), intent(in), optional :: ibase end subroutine psi_d_exscanv end interface psi_exscan diff --git a/base/modules/auxil/psi_e_serial_mod.f90 b/base/modules/auxil/psi_e_serial_mod.f90 index a5544075b..f0372e016 100644 --- a/base/modules/auxil/psi_e_serial_mod.f90 +++ b/base/modules/auxil/psi_e_serial_mod.f90 @@ -157,14 +157,13 @@ module psi_e_serial_mod end interface psi_sct interface psi_exscan - subroutine psi_e_exscanv(n,x,info,shift,ibase) + 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 - integer(psb_ipk_), intent(in), optional :: ibase end subroutine psi_e_exscanv end interface psi_exscan diff --git a/base/modules/auxil/psi_i2_serial_mod.f90 b/base/modules/auxil/psi_i2_serial_mod.f90 index c0b5a3276..70dd95e1b 100644 --- a/base/modules/auxil/psi_i2_serial_mod.f90 +++ b/base/modules/auxil/psi_i2_serial_mod.f90 @@ -157,14 +157,13 @@ module psi_i2_serial_mod end interface psi_sct interface psi_exscan - subroutine psi_i2_exscanv(n,x,info,shift,ibase) + 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 - integer(psb_ipk_), intent(in), optional :: ibase end subroutine psi_i2_exscanv end interface psi_exscan diff --git a/base/modules/auxil/psi_m_serial_mod.f90 b/base/modules/auxil/psi_m_serial_mod.f90 index ab875f7b9..cfd1348ef 100644 --- a/base/modules/auxil/psi_m_serial_mod.f90 +++ b/base/modules/auxil/psi_m_serial_mod.f90 @@ -157,14 +157,13 @@ module psi_m_serial_mod end interface psi_sct interface psi_exscan - subroutine psi_m_exscanv(n,x,info,shift,ibase) + 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 - integer(psb_ipk_), intent(in), optional :: ibase end subroutine psi_m_exscanv end interface psi_exscan diff --git a/base/modules/auxil/psi_s_serial_mod.f90 b/base/modules/auxil/psi_s_serial_mod.f90 index fee1afc65..25c4a7ef3 100644 --- a/base/modules/auxil/psi_s_serial_mod.f90 +++ b/base/modules/auxil/psi_s_serial_mod.f90 @@ -157,14 +157,13 @@ module psi_s_serial_mod end interface psi_sct interface psi_exscan - subroutine psi_s_exscanv(n,x,info,shift,ibase) + 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 - integer(psb_ipk_), intent(in), optional :: ibase end subroutine psi_s_exscanv end interface psi_exscan diff --git a/base/modules/auxil/psi_z_serial_mod.f90 b/base/modules/auxil/psi_z_serial_mod.f90 index 3ab430ccb..b40cf05ad 100644 --- a/base/modules/auxil/psi_z_serial_mod.f90 +++ b/base/modules/auxil/psi_z_serial_mod.f90 @@ -157,14 +157,13 @@ module psi_z_serial_mod end interface psi_sct interface psi_exscan - subroutine psi_z_exscanv(n,x,info,shift,ibase) + 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 - integer(psb_ipk_), intent(in), optional :: ibase end subroutine psi_z_exscanv end interface psi_exscan diff --git a/base/serial/impl/psb_c_csc_impl.F90 b/base/serial/impl/psb_c_csc_impl.F90 index 7532d5a09..bb5006284 100644 --- a/base/serial/impl/psb_c_csc_impl.F90 +++ b/base/serial/impl/psb_c_csc_impl.F90 @@ -2243,7 +2243,7 @@ subroutine psb_c_mv_csc_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO - call psi_exscan(nc+1,a%icp,info,shift=ione,ibase=ione) + call psi_exscan(nc+1,a%icp,info,shift=ione) !$OMP END PARALLEL #else a%icp(:) = 0 @@ -2251,7 +2251,7 @@ subroutine psb_c_mv_csc_from_coo(a,b,info) i = itemp(k) a%icp(i) = a%icp(i) + 1 end do - call psi_exscan(nc+1,a%icp,info,shift=ione,ibase=ione) + call psi_exscan(nc+1,a%icp,info,shift=ione) #endif call a%set_host() diff --git a/base/serial/impl/psb_c_csr_impl.F90 b/base/serial/impl/psb_c_csr_impl.F90 index b742204d1..06dec27d1 100644 --- a/base/serial/impl/psb_c_csr_impl.F90 +++ b/base/serial/impl/psb_c_csr_impl.F90 @@ -2935,7 +2935,7 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO - call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) + call psi_exscan(nr+1,a%irp,info,shift=ione) !$OMP END PARALLEL #else a%irp(:) = 0 @@ -2943,7 +2943,7 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) i = itemp(k) a%irp(i) = a%irp(i) + 1 end do - call psi_exscan(nr+1,a%irp,info,shift=cone,ibase=ione) + call psi_exscan(nr+1,a%irp,info,shift=ione) #endif call a%set_host() @@ -3103,7 +3103,7 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO - call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) + call psi_exscan(nr+1,a%irp,info,shift=ione) !$OMP END PARALLEL #else a%irp(:) = 0 @@ -3111,7 +3111,7 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) i = itemp(k) a%irp(i) = a%irp(i) + 1 end do - call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) + call psi_exscan(nr+1,a%irp,info,shift=ione) #endif call a%set_host() diff --git a/base/serial/impl/psb_d_csc_impl.F90 b/base/serial/impl/psb_d_csc_impl.F90 index 38f746de5..ec80875a4 100644 --- a/base/serial/impl/psb_d_csc_impl.F90 +++ b/base/serial/impl/psb_d_csc_impl.F90 @@ -2243,7 +2243,7 @@ subroutine psb_d_mv_csc_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO - call psi_exscan(nc+1,a%icp,info,shift=ione,ibase=ione) + call psi_exscan(nc+1,a%icp,info,shift=ione) !$OMP END PARALLEL #else a%icp(:) = 0 @@ -2251,7 +2251,7 @@ subroutine psb_d_mv_csc_from_coo(a,b,info) i = itemp(k) a%icp(i) = a%icp(i) + 1 end do - call psi_exscan(nc+1,a%icp,info,shift=ione,ibase=ione) + call psi_exscan(nc+1,a%icp,info,shift=ione) #endif call a%set_host() diff --git a/base/serial/impl/psb_d_csr_impl.F90 b/base/serial/impl/psb_d_csr_impl.F90 index 86287e324..f071a5b85 100644 --- a/base/serial/impl/psb_d_csr_impl.F90 +++ b/base/serial/impl/psb_d_csr_impl.F90 @@ -2935,7 +2935,7 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO - call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) + call psi_exscan(nr+1,a%irp,info,shift=ione) !$OMP END PARALLEL #else a%irp(:) = 0 @@ -2943,7 +2943,7 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) i = itemp(k) a%irp(i) = a%irp(i) + 1 end do - call psi_exscan(nr+1,a%irp,info,shift=done,ibase=ione) + call psi_exscan(nr+1,a%irp,info,shift=ione) #endif call a%set_host() @@ -3103,7 +3103,7 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO - call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) + call psi_exscan(nr+1,a%irp,info,shift=ione) !$OMP END PARALLEL #else a%irp(:) = 0 @@ -3111,7 +3111,7 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) i = itemp(k) a%irp(i) = a%irp(i) + 1 end do - call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) + call psi_exscan(nr+1,a%irp,info,shift=ione) #endif call a%set_host() diff --git a/base/serial/impl/psb_s_csc_impl.F90 b/base/serial/impl/psb_s_csc_impl.F90 index d1fb8c4b6..fa3fe8808 100644 --- a/base/serial/impl/psb_s_csc_impl.F90 +++ b/base/serial/impl/psb_s_csc_impl.F90 @@ -2243,7 +2243,7 @@ subroutine psb_s_mv_csc_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO - call psi_exscan(nc+1,a%icp,info,shift=ione,ibase=ione) + call psi_exscan(nc+1,a%icp,info,shift=ione) !$OMP END PARALLEL #else a%icp(:) = 0 @@ -2251,7 +2251,7 @@ subroutine psb_s_mv_csc_from_coo(a,b,info) i = itemp(k) a%icp(i) = a%icp(i) + 1 end do - call psi_exscan(nc+1,a%icp,info,shift=ione,ibase=ione) + call psi_exscan(nc+1,a%icp,info,shift=ione) #endif call a%set_host() diff --git a/base/serial/impl/psb_s_csr_impl.F90 b/base/serial/impl/psb_s_csr_impl.F90 index 46ead8fc3..cd2933f7f 100644 --- a/base/serial/impl/psb_s_csr_impl.F90 +++ b/base/serial/impl/psb_s_csr_impl.F90 @@ -2935,7 +2935,7 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO - call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) + call psi_exscan(nr+1,a%irp,info,shift=ione) !$OMP END PARALLEL #else a%irp(:) = 0 @@ -2943,7 +2943,7 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) i = itemp(k) a%irp(i) = a%irp(i) + 1 end do - call psi_exscan(nr+1,a%irp,info,shift=sone,ibase=ione) + call psi_exscan(nr+1,a%irp,info,shift=ione) #endif call a%set_host() @@ -3103,7 +3103,7 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO - call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) + call psi_exscan(nr+1,a%irp,info,shift=ione) !$OMP END PARALLEL #else a%irp(:) = 0 @@ -3111,7 +3111,7 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) i = itemp(k) a%irp(i) = a%irp(i) + 1 end do - call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) + call psi_exscan(nr+1,a%irp,info,shift=ione) #endif call a%set_host() diff --git a/base/serial/impl/psb_z_csc_impl.F90 b/base/serial/impl/psb_z_csc_impl.F90 index 2735bcbdd..28285e4d6 100644 --- a/base/serial/impl/psb_z_csc_impl.F90 +++ b/base/serial/impl/psb_z_csc_impl.F90 @@ -2243,7 +2243,7 @@ subroutine psb_z_mv_csc_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO - call psi_exscan(nc+1,a%icp,info,shift=ione,ibase=ione) + call psi_exscan(nc+1,a%icp,info,shift=ione) !$OMP END PARALLEL #else a%icp(:) = 0 @@ -2251,7 +2251,7 @@ subroutine psb_z_mv_csc_from_coo(a,b,info) i = itemp(k) a%icp(i) = a%icp(i) + 1 end do - call psi_exscan(nc+1,a%icp,info,shift=ione,ibase=ione) + call psi_exscan(nc+1,a%icp,info,shift=ione) #endif call a%set_host() diff --git a/base/serial/impl/psb_z_csr_impl.F90 b/base/serial/impl/psb_z_csr_impl.F90 index b6ec8fe71..88f493351 100644 --- a/base/serial/impl/psb_z_csr_impl.F90 +++ b/base/serial/impl/psb_z_csr_impl.F90 @@ -2935,7 +2935,7 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO - call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) + call psi_exscan(nr+1,a%irp,info,shift=ione) !$OMP END PARALLEL #else a%irp(:) = 0 @@ -2943,7 +2943,7 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) i = itemp(k) a%irp(i) = a%irp(i) + 1 end do - call psi_exscan(nr+1,a%irp,info,shift=zone,ibase=ione) + call psi_exscan(nr+1,a%irp,info,shift=ione) #endif call a%set_host() @@ -3103,7 +3103,7 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) !$OMP END ATOMIC end do !$OMP END DO - call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) + call psi_exscan(nr+1,a%irp,info,shift=ione) !$OMP END PARALLEL #else a%irp(:) = 0 @@ -3111,7 +3111,7 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) i = itemp(k) a%irp(i) = a%irp(i) + 1 end do - call psi_exscan(nr+1,a%irp,info,shift=ione,ibase=ione) + call psi_exscan(nr+1,a%irp,info,shift=ione) #endif call a%set_host() diff --git a/base/serial/psi_c_serial_impl.F90 b/base/serial/psi_c_serial_impl.F90 index 2391becbe..d7c92d3a0 100644 --- a/base/serial/psi_c_serial_impl.F90 +++ b/base/serial/psi_c_serial_impl.F90 @@ -29,7 +29,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_c_exscanv(n,x,info,shift,ibase) +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 @@ -41,10 +41,8 @@ subroutine psi_c_exscanv(n,x,info,shift,ibase) complex(psb_spk_), intent (inout) :: x(:) integer(psb_ipk_), intent(out) :: info complex(psb_spk_), intent(in), optional :: shift - integer(psb_ipk_), intent(in), optional :: ibase complex(psb_spk_) :: shift_, tp, ts - integer(psb_ipk_) :: ibase_ logical is_nested, is_parallel if (present(shift)) then @@ -52,11 +50,6 @@ subroutine psi_c_exscanv(n,x,info,shift,ibase) else shift_ = czero end if - if (present(ibase)) then - ibase_ = ibase - else - ibase_ = ione - end if #if defined(OPENMP) is_parallel = omp_in_parallel() @@ -97,12 +90,12 @@ contains wrk = (n)/nthreads if (ithread < MOD((n),nthreads)) then wrk = wrk + 1 - first_idx = ithread*wrk + ibase_ + first_idx = ithread*wrk + 1 else - first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + first_idx = ithread*wrk + MOD((n),nthreads) + 1 end if - last_idx = min(first_idx + wrk - 1,n - (ione-ibase_)) + last_idx = min(first_idx + wrk - 1,n ) if (first_idx<=last_idx) then sumb(ithread+2) = sumb(ithread+2) + x(first_idx) do i=first_idx+1,last_idx diff --git a/base/serial/psi_d_serial_impl.F90 b/base/serial/psi_d_serial_impl.F90 index 099dd1d46..56bedc846 100644 --- a/base/serial/psi_d_serial_impl.F90 +++ b/base/serial/psi_d_serial_impl.F90 @@ -29,7 +29,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_d_exscanv(n,x,info,shift,ibase) +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 @@ -41,10 +41,8 @@ subroutine psi_d_exscanv(n,x,info,shift,ibase) real(psb_dpk_), intent (inout) :: x(:) integer(psb_ipk_), intent(out) :: info real(psb_dpk_), intent(in), optional :: shift - integer(psb_ipk_), intent(in), optional :: ibase real(psb_dpk_) :: shift_, tp, ts - integer(psb_ipk_) :: ibase_ logical is_nested, is_parallel if (present(shift)) then @@ -52,11 +50,6 @@ subroutine psi_d_exscanv(n,x,info,shift,ibase) else shift_ = dzero end if - if (present(ibase)) then - ibase_ = ibase - else - ibase_ = ione - end if #if defined(OPENMP) is_parallel = omp_in_parallel() @@ -97,12 +90,12 @@ contains wrk = (n)/nthreads if (ithread < MOD((n),nthreads)) then wrk = wrk + 1 - first_idx = ithread*wrk + ibase_ + first_idx = ithread*wrk + 1 else - first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + first_idx = ithread*wrk + MOD((n),nthreads) + 1 end if - last_idx = min(first_idx + wrk - 1,n - (ione-ibase_)) + last_idx = min(first_idx + wrk - 1,n ) if (first_idx<=last_idx) then sumb(ithread+2) = sumb(ithread+2) + x(first_idx) do i=first_idx+1,last_idx diff --git a/base/serial/psi_e_serial_impl.F90 b/base/serial/psi_e_serial_impl.F90 index 10ca93b42..ba9a0b2a5 100644 --- a/base/serial/psi_e_serial_impl.F90 +++ b/base/serial/psi_e_serial_impl.F90 @@ -29,7 +29,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_e_exscanv(n,x,info,shift,ibase) +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 @@ -41,10 +41,8 @@ subroutine psi_e_exscanv(n,x,info,shift,ibase) integer(psb_epk_), intent (inout) :: x(:) integer(psb_ipk_), intent(out) :: info integer(psb_epk_), intent(in), optional :: shift - integer(psb_ipk_), intent(in), optional :: ibase integer(psb_epk_) :: shift_, tp, ts - integer(psb_ipk_) :: ibase_ logical is_nested, is_parallel if (present(shift)) then @@ -52,11 +50,6 @@ subroutine psi_e_exscanv(n,x,info,shift,ibase) else shift_ = ezero end if - if (present(ibase)) then - ibase_ = ibase - else - ibase_ = ione - end if #if defined(OPENMP) is_parallel = omp_in_parallel() @@ -97,12 +90,12 @@ contains wrk = (n)/nthreads if (ithread < MOD((n),nthreads)) then wrk = wrk + 1 - first_idx = ithread*wrk + ibase_ + first_idx = ithread*wrk + 1 else - first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + first_idx = ithread*wrk + MOD((n),nthreads) + 1 end if - last_idx = min(first_idx + wrk - 1,n - (ione-ibase_)) + last_idx = min(first_idx + wrk - 1,n ) if (first_idx<=last_idx) then sumb(ithread+2) = sumb(ithread+2) + x(first_idx) do i=first_idx+1,last_idx diff --git a/base/serial/psi_i2_serial_impl.F90 b/base/serial/psi_i2_serial_impl.F90 index 3ccd35bc7..200e378a2 100644 --- a/base/serial/psi_i2_serial_impl.F90 +++ b/base/serial/psi_i2_serial_impl.F90 @@ -29,7 +29,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_i2_exscanv(n,x,info,shift,ibase) +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 @@ -41,10 +41,8 @@ subroutine psi_i2_exscanv(n,x,info,shift,ibase) integer(psb_i2pk_), intent (inout) :: x(:) integer(psb_ipk_), intent(out) :: info integer(psb_i2pk_), intent(in), optional :: shift - integer(psb_ipk_), intent(in), optional :: ibase integer(psb_i2pk_) :: shift_, tp, ts - integer(psb_ipk_) :: ibase_ logical is_nested, is_parallel if (present(shift)) then @@ -52,11 +50,6 @@ subroutine psi_i2_exscanv(n,x,info,shift,ibase) else shift_ = i2zero end if - if (present(ibase)) then - ibase_ = ibase - else - ibase_ = ione - end if #if defined(OPENMP) is_parallel = omp_in_parallel() @@ -97,12 +90,12 @@ contains wrk = (n)/nthreads if (ithread < MOD((n),nthreads)) then wrk = wrk + 1 - first_idx = ithread*wrk + ibase_ + first_idx = ithread*wrk + 1 else - first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + first_idx = ithread*wrk + MOD((n),nthreads) + 1 end if - last_idx = min(first_idx + wrk - 1,n - (ione-ibase_)) + last_idx = min(first_idx + wrk - 1,n ) if (first_idx<=last_idx) then sumb(ithread+2) = sumb(ithread+2) + x(first_idx) do i=first_idx+1,last_idx diff --git a/base/serial/psi_m_serial_impl.F90 b/base/serial/psi_m_serial_impl.F90 index c3d73e5af..05461e1ea 100644 --- a/base/serial/psi_m_serial_impl.F90 +++ b/base/serial/psi_m_serial_impl.F90 @@ -29,7 +29,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_m_exscanv(n,x,info,shift,ibase) +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 @@ -41,10 +41,8 @@ subroutine psi_m_exscanv(n,x,info,shift,ibase) integer(psb_mpk_), intent (inout) :: x(:) integer(psb_ipk_), intent(out) :: info integer(psb_mpk_), intent(in), optional :: shift - integer(psb_ipk_), intent(in), optional :: ibase integer(psb_mpk_) :: shift_, tp, ts - integer(psb_ipk_) :: ibase_ logical is_nested, is_parallel if (present(shift)) then @@ -52,11 +50,6 @@ subroutine psi_m_exscanv(n,x,info,shift,ibase) else shift_ = mzero end if - if (present(ibase)) then - ibase_ = ibase - else - ibase_ = ione - end if #if defined(OPENMP) is_parallel = omp_in_parallel() @@ -97,12 +90,12 @@ contains wrk = (n)/nthreads if (ithread < MOD((n),nthreads)) then wrk = wrk + 1 - first_idx = ithread*wrk + ibase_ + first_idx = ithread*wrk + 1 else - first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + first_idx = ithread*wrk + MOD((n),nthreads) + 1 end if - last_idx = min(first_idx + wrk - 1,n - (ione-ibase_)) + last_idx = min(first_idx + wrk - 1,n ) if (first_idx<=last_idx) then sumb(ithread+2) = sumb(ithread+2) + x(first_idx) do i=first_idx+1,last_idx diff --git a/base/serial/psi_s_serial_impl.F90 b/base/serial/psi_s_serial_impl.F90 index fd1c4cd4a..6e5eadd78 100644 --- a/base/serial/psi_s_serial_impl.F90 +++ b/base/serial/psi_s_serial_impl.F90 @@ -29,7 +29,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_s_exscanv(n,x,info,shift,ibase) +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 @@ -41,10 +41,8 @@ subroutine psi_s_exscanv(n,x,info,shift,ibase) real(psb_spk_), intent (inout) :: x(:) integer(psb_ipk_), intent(out) :: info real(psb_spk_), intent(in), optional :: shift - integer(psb_ipk_), intent(in), optional :: ibase real(psb_spk_) :: shift_, tp, ts - integer(psb_ipk_) :: ibase_ logical is_nested, is_parallel if (present(shift)) then @@ -52,11 +50,6 @@ subroutine psi_s_exscanv(n,x,info,shift,ibase) else shift_ = szero end if - if (present(ibase)) then - ibase_ = ibase - else - ibase_ = ione - end if #if defined(OPENMP) is_parallel = omp_in_parallel() @@ -97,12 +90,12 @@ contains wrk = (n)/nthreads if (ithread < MOD((n),nthreads)) then wrk = wrk + 1 - first_idx = ithread*wrk + ibase_ + first_idx = ithread*wrk + 1 else - first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + first_idx = ithread*wrk + MOD((n),nthreads) + 1 end if - last_idx = min(first_idx + wrk - 1,n - (ione-ibase_)) + last_idx = min(first_idx + wrk - 1,n ) if (first_idx<=last_idx) then sumb(ithread+2) = sumb(ithread+2) + x(first_idx) do i=first_idx+1,last_idx diff --git a/base/serial/psi_z_serial_impl.F90 b/base/serial/psi_z_serial_impl.F90 index bf0554769..ef13db0bb 100644 --- a/base/serial/psi_z_serial_impl.F90 +++ b/base/serial/psi_z_serial_impl.F90 @@ -29,7 +29,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_z_exscanv(n,x,info,shift,ibase) +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 @@ -41,10 +41,8 @@ subroutine psi_z_exscanv(n,x,info,shift,ibase) complex(psb_dpk_), intent (inout) :: x(:) integer(psb_ipk_), intent(out) :: info complex(psb_dpk_), intent(in), optional :: shift - integer(psb_ipk_), intent(in), optional :: ibase complex(psb_dpk_) :: shift_, tp, ts - integer(psb_ipk_) :: ibase_ logical is_nested, is_parallel if (present(shift)) then @@ -52,11 +50,6 @@ subroutine psi_z_exscanv(n,x,info,shift,ibase) else shift_ = zzero end if - if (present(ibase)) then - ibase_ = ibase - else - ibase_ = ione - end if #if defined(OPENMP) is_parallel = omp_in_parallel() @@ -97,12 +90,12 @@ contains wrk = (n)/nthreads if (ithread < MOD((n),nthreads)) then wrk = wrk + 1 - first_idx = ithread*wrk + ibase_ + first_idx = ithread*wrk + 1 else - first_idx = ithread*wrk + MOD((n),nthreads) + ibase_ + first_idx = ithread*wrk + MOD((n),nthreads) + 1 end if - last_idx = min(first_idx + wrk - 1,n - (ione-ibase_)) + last_idx = min(first_idx + wrk - 1,n ) if (first_idx<=last_idx) then sumb(ithread+2) = sumb(ithread+2) + x(first_idx) do i=first_idx+1,last_idx From 5bc02fb2e6b47d0e6559f3a6951b266dd25f3dc1 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 21 Apr 2023 08:55:20 +0200 Subject: [PATCH 24/63] Take out redundant statements in SPINS --- base/tools/psb_cspins.F90 | 10 ++-------- base/tools/psb_dspins.F90 | 10 ++-------- base/tools/psb_sspins.F90 | 10 ++-------- base/tools/psb_zspins.F90 | 10 ++-------- 4 files changed, 8 insertions(+), 32 deletions(-) diff --git a/base/tools/psb_cspins.F90 b/base/tools/psb_cspins.F90 index 66e03ed9d..0f5fc9dfb 100644 --- a/base/tools/psb_cspins.F90 +++ b/base/tools/psb_cspins.F90 @@ -73,7 +73,7 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ integer(psb_ipk_), allocatable :: ila(:),jla(:) - integer(psb_ipk_) :: i,k, ith, nth + integer(psb_ipk_) :: i,k integer(psb_lpk_) :: nnl integer(psb_lpk_), allocatable :: lila(:),ljla(:) complex(psb_spk_), allocatable :: lval(:) @@ -85,13 +85,7 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) ctxt = desc_a%get_context() call psb_info(ctxt, me, np) -#if defined(OPENMP) - nth = omp_get_num_threads() - ith = omp_get_thread_num() -#else - nth = 1 - ith = 0 -#endif + if (nz < 0) then info = 1111 call psb_errpush(info,name) diff --git a/base/tools/psb_dspins.F90 b/base/tools/psb_dspins.F90 index 2e11c5110..06f913b54 100644 --- a/base/tools/psb_dspins.F90 +++ b/base/tools/psb_dspins.F90 @@ -73,7 +73,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ integer(psb_ipk_), allocatable :: ila(:),jla(:) - integer(psb_ipk_) :: i,k, ith, nth + integer(psb_ipk_) :: i,k integer(psb_lpk_) :: nnl integer(psb_lpk_), allocatable :: lila(:),ljla(:) real(psb_dpk_), allocatable :: lval(:) @@ -85,13 +85,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) ctxt = desc_a%get_context() call psb_info(ctxt, me, np) -#if defined(OPENMP) - nth = omp_get_num_threads() - ith = omp_get_thread_num() -#else - nth = 1 - ith = 0 -#endif + if (nz < 0) then info = 1111 call psb_errpush(info,name) diff --git a/base/tools/psb_sspins.F90 b/base/tools/psb_sspins.F90 index 90fa9e2da..56ef9c97f 100644 --- a/base/tools/psb_sspins.F90 +++ b/base/tools/psb_sspins.F90 @@ -73,7 +73,7 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ integer(psb_ipk_), allocatable :: ila(:),jla(:) - integer(psb_ipk_) :: i,k, ith, nth + integer(psb_ipk_) :: i,k integer(psb_lpk_) :: nnl integer(psb_lpk_), allocatable :: lila(:),ljla(:) real(psb_spk_), allocatable :: lval(:) @@ -85,13 +85,7 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) ctxt = desc_a%get_context() call psb_info(ctxt, me, np) -#if defined(OPENMP) - nth = omp_get_num_threads() - ith = omp_get_thread_num() -#else - nth = 1 - ith = 0 -#endif + if (nz < 0) then info = 1111 call psb_errpush(info,name) diff --git a/base/tools/psb_zspins.F90 b/base/tools/psb_zspins.F90 index 74e2d5dc7..d483f198a 100644 --- a/base/tools/psb_zspins.F90 +++ b/base/tools/psb_zspins.F90 @@ -73,7 +73,7 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ integer(psb_ipk_), allocatable :: ila(:),jla(:) - integer(psb_ipk_) :: i,k, ith, nth + integer(psb_ipk_) :: i,k integer(psb_lpk_) :: nnl integer(psb_lpk_), allocatable :: lila(:),ljla(:) complex(psb_dpk_), allocatable :: lval(:) @@ -85,13 +85,7 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) ctxt = desc_a%get_context() call psb_info(ctxt, me, np) -#if defined(OPENMP) - nth = omp_get_num_threads() - ith = omp_get_thread_num() -#else - nth = 1 - ith = 0 -#endif + if (nz < 0) then info = 1111 call psb_errpush(info,name) From 74a821752031efcc74c94dcd22a5fd6d196039c7 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 21 Apr 2023 12:02:18 +0200 Subject: [PATCH 25/63] Fixed silly bug in EXSCAN and usage in CSR_IMPL --- base/serial/impl/psb_c_csr_impl.F90 | 4 ++-- base/serial/impl/psb_d_csr_impl.F90 | 4 ++-- base/serial/impl/psb_s_csr_impl.F90 | 4 ++-- base/serial/impl/psb_z_csr_impl.F90 | 4 ++-- base/serial/psi_c_serial_impl.F90 | 30 ++++++++++++++++------------- base/serial/psi_d_serial_impl.F90 | 30 ++++++++++++++++------------- base/serial/psi_e_serial_impl.F90 | 30 ++++++++++++++++------------- base/serial/psi_i2_serial_impl.F90 | 30 ++++++++++++++++------------- base/serial/psi_m_serial_impl.F90 | 30 ++++++++++++++++------------- base/serial/psi_s_serial_impl.F90 | 30 ++++++++++++++++------------- base/serial/psi_z_serial_impl.F90 | 30 ++++++++++++++++------------- 11 files changed, 127 insertions(+), 99 deletions(-) diff --git a/base/serial/impl/psb_c_csr_impl.F90 b/base/serial/impl/psb_c_csr_impl.F90 index 06dec27d1..7c7452a08 100644 --- a/base/serial/impl/psb_c_csr_impl.F90 +++ b/base/serial/impl/psb_c_csr_impl.F90 @@ -2931,7 +2931,7 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) do k=1,nza i = itemp(k) !$OMP ATOMIC UPDATE - a%irp(i+1) = a%irp(i+1) + 1 + a%irp(i) = a%irp(i) + 1 !$OMP END ATOMIC end do !$OMP END DO @@ -3099,7 +3099,7 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) do k=1,nza i = itemp(k) !$OMP ATOMIC UPDATE - a%irp(i+1) = a%irp(i+1) + 1 + a%irp(i) = a%irp(i) + 1 !$OMP END ATOMIC end do !$OMP END DO diff --git a/base/serial/impl/psb_d_csr_impl.F90 b/base/serial/impl/psb_d_csr_impl.F90 index f071a5b85..56273b499 100644 --- a/base/serial/impl/psb_d_csr_impl.F90 +++ b/base/serial/impl/psb_d_csr_impl.F90 @@ -2931,7 +2931,7 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) do k=1,nza i = itemp(k) !$OMP ATOMIC UPDATE - a%irp(i+1) = a%irp(i+1) + 1 + a%irp(i) = a%irp(i) + 1 !$OMP END ATOMIC end do !$OMP END DO @@ -3099,7 +3099,7 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) do k=1,nza i = itemp(k) !$OMP ATOMIC UPDATE - a%irp(i+1) = a%irp(i+1) + 1 + a%irp(i) = a%irp(i) + 1 !$OMP END ATOMIC end do !$OMP END DO diff --git a/base/serial/impl/psb_s_csr_impl.F90 b/base/serial/impl/psb_s_csr_impl.F90 index cd2933f7f..17e73934a 100644 --- a/base/serial/impl/psb_s_csr_impl.F90 +++ b/base/serial/impl/psb_s_csr_impl.F90 @@ -2931,7 +2931,7 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) do k=1,nza i = itemp(k) !$OMP ATOMIC UPDATE - a%irp(i+1) = a%irp(i+1) + 1 + a%irp(i) = a%irp(i) + 1 !$OMP END ATOMIC end do !$OMP END DO @@ -3099,7 +3099,7 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) do k=1,nza i = itemp(k) !$OMP ATOMIC UPDATE - a%irp(i+1) = a%irp(i+1) + 1 + a%irp(i) = a%irp(i) + 1 !$OMP END ATOMIC end do !$OMP END DO diff --git a/base/serial/impl/psb_z_csr_impl.F90 b/base/serial/impl/psb_z_csr_impl.F90 index 88f493351..f88008d81 100644 --- a/base/serial/impl/psb_z_csr_impl.F90 +++ b/base/serial/impl/psb_z_csr_impl.F90 @@ -2931,7 +2931,7 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) do k=1,nza i = itemp(k) !$OMP ATOMIC UPDATE - a%irp(i+1) = a%irp(i+1) + 1 + a%irp(i) = a%irp(i) + 1 !$OMP END ATOMIC end do !$OMP END DO @@ -3099,7 +3099,7 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) do k=1,nza i = itemp(k) !$OMP ATOMIC UPDATE - a%irp(i+1) = a%irp(i+1) + 1 + a%irp(i) = a%irp(i) + 1 !$OMP END ATOMIC end do !$OMP END DO diff --git a/base/serial/psi_c_serial_impl.F90 b/base/serial/psi_c_serial_impl.F90 index d7c92d3a0..a3898349b 100644 --- a/base/serial/psi_c_serial_impl.F90 +++ b/base/serial/psi_c_serial_impl.F90 @@ -43,6 +43,7 @@ subroutine psi_c_exscanv(n,x,info,shift) 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 @@ -76,9 +77,11 @@ contains ! 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. - integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk - complex(psb_spk_), pointer :: sumb(:) + ! 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() @@ -90,19 +93,21 @@ contains wrk = (n)/nthreads if (ithread < MOD((n),nthreads)) then wrk = wrk + 1 - first_idx = ithread*wrk + 1 + idxstart = ithread*wrk + 1 else - first_idx = ithread*wrk + MOD((n),nthreads) + 1 + idxstart = ithread*wrk + MOD((n),nthreads) + 1 end if - last_idx = min(first_idx + wrk - 1,n ) - if (first_idx<=last_idx) then - sumb(ithread+2) = sumb(ithread+2) + x(first_idx) - do i=first_idx+1,last_idx - sumb(ithread+2) = sumb(ithread+2) + x(i) - x(i) = x(i)+x(i-1) + 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 @@ -115,11 +120,10 @@ contains !$OMP DO SCHEDULE(STATIC) do i=1,n - x(i) = sumb(ithread+1) + x(i) + shift_ + x(i) = x(i) + sumb(ithread+1) + shift_ end do !$OMP END DO !$OMP SINGLE - x(1) = shift_ deallocate(sumb) !$OMP END SINGLE end subroutine inner_c_exscan diff --git a/base/serial/psi_d_serial_impl.F90 b/base/serial/psi_d_serial_impl.F90 index 56bedc846..1b5b14424 100644 --- a/base/serial/psi_d_serial_impl.F90 +++ b/base/serial/psi_d_serial_impl.F90 @@ -43,6 +43,7 @@ subroutine psi_d_exscanv(n,x,info,shift) 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 @@ -76,9 +77,11 @@ contains ! 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. - integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk - real(psb_dpk_), pointer :: sumb(:) + ! 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() @@ -90,19 +93,21 @@ contains wrk = (n)/nthreads if (ithread < MOD((n),nthreads)) then wrk = wrk + 1 - first_idx = ithread*wrk + 1 + idxstart = ithread*wrk + 1 else - first_idx = ithread*wrk + MOD((n),nthreads) + 1 + idxstart = ithread*wrk + MOD((n),nthreads) + 1 end if - last_idx = min(first_idx + wrk - 1,n ) - if (first_idx<=last_idx) then - sumb(ithread+2) = sumb(ithread+2) + x(first_idx) - do i=first_idx+1,last_idx - sumb(ithread+2) = sumb(ithread+2) + x(i) - x(i) = x(i)+x(i-1) + 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 @@ -115,11 +120,10 @@ contains !$OMP DO SCHEDULE(STATIC) do i=1,n - x(i) = sumb(ithread+1) + x(i) + shift_ + x(i) = x(i) + sumb(ithread+1) + shift_ end do !$OMP END DO !$OMP SINGLE - x(1) = shift_ deallocate(sumb) !$OMP END SINGLE end subroutine inner_d_exscan diff --git a/base/serial/psi_e_serial_impl.F90 b/base/serial/psi_e_serial_impl.F90 index ba9a0b2a5..9cdcdf0e4 100644 --- a/base/serial/psi_e_serial_impl.F90 +++ b/base/serial/psi_e_serial_impl.F90 @@ -43,6 +43,7 @@ subroutine psi_e_exscanv(n,x,info,shift) 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 @@ -76,9 +77,11 @@ contains ! 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. - integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk - integer(psb_epk_), pointer :: sumb(:) + ! 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() @@ -90,19 +93,21 @@ contains wrk = (n)/nthreads if (ithread < MOD((n),nthreads)) then wrk = wrk + 1 - first_idx = ithread*wrk + 1 + idxstart = ithread*wrk + 1 else - first_idx = ithread*wrk + MOD((n),nthreads) + 1 + idxstart = ithread*wrk + MOD((n),nthreads) + 1 end if - last_idx = min(first_idx + wrk - 1,n ) - if (first_idx<=last_idx) then - sumb(ithread+2) = sumb(ithread+2) + x(first_idx) - do i=first_idx+1,last_idx - sumb(ithread+2) = sumb(ithread+2) + x(i) - x(i) = x(i)+x(i-1) + 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 @@ -115,11 +120,10 @@ contains !$OMP DO SCHEDULE(STATIC) do i=1,n - x(i) = sumb(ithread+1) + x(i) + shift_ + x(i) = x(i) + sumb(ithread+1) + shift_ end do !$OMP END DO !$OMP SINGLE - x(1) = shift_ deallocate(sumb) !$OMP END SINGLE end subroutine inner_e_exscan diff --git a/base/serial/psi_i2_serial_impl.F90 b/base/serial/psi_i2_serial_impl.F90 index 200e378a2..d25617a90 100644 --- a/base/serial/psi_i2_serial_impl.F90 +++ b/base/serial/psi_i2_serial_impl.F90 @@ -43,6 +43,7 @@ subroutine psi_i2_exscanv(n,x,info,shift) 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 @@ -76,9 +77,11 @@ contains ! 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. - integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk - integer(psb_i2pk_), pointer :: sumb(:) + ! 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() @@ -90,19 +93,21 @@ contains wrk = (n)/nthreads if (ithread < MOD((n),nthreads)) then wrk = wrk + 1 - first_idx = ithread*wrk + 1 + idxstart = ithread*wrk + 1 else - first_idx = ithread*wrk + MOD((n),nthreads) + 1 + idxstart = ithread*wrk + MOD((n),nthreads) + 1 end if - last_idx = min(first_idx + wrk - 1,n ) - if (first_idx<=last_idx) then - sumb(ithread+2) = sumb(ithread+2) + x(first_idx) - do i=first_idx+1,last_idx - sumb(ithread+2) = sumb(ithread+2) + x(i) - x(i) = x(i)+x(i-1) + 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 @@ -115,11 +120,10 @@ contains !$OMP DO SCHEDULE(STATIC) do i=1,n - x(i) = sumb(ithread+1) + x(i) + shift_ + x(i) = x(i) + sumb(ithread+1) + shift_ end do !$OMP END DO !$OMP SINGLE - x(1) = shift_ deallocate(sumb) !$OMP END SINGLE end subroutine inner_i2_exscan diff --git a/base/serial/psi_m_serial_impl.F90 b/base/serial/psi_m_serial_impl.F90 index 05461e1ea..05c8e60fa 100644 --- a/base/serial/psi_m_serial_impl.F90 +++ b/base/serial/psi_m_serial_impl.F90 @@ -43,6 +43,7 @@ subroutine psi_m_exscanv(n,x,info,shift) 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 @@ -76,9 +77,11 @@ contains ! 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. - integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk - integer(psb_mpk_), pointer :: sumb(:) + ! 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() @@ -90,19 +93,21 @@ contains wrk = (n)/nthreads if (ithread < MOD((n),nthreads)) then wrk = wrk + 1 - first_idx = ithread*wrk + 1 + idxstart = ithread*wrk + 1 else - first_idx = ithread*wrk + MOD((n),nthreads) + 1 + idxstart = ithread*wrk + MOD((n),nthreads) + 1 end if - last_idx = min(first_idx + wrk - 1,n ) - if (first_idx<=last_idx) then - sumb(ithread+2) = sumb(ithread+2) + x(first_idx) - do i=first_idx+1,last_idx - sumb(ithread+2) = sumb(ithread+2) + x(i) - x(i) = x(i)+x(i-1) + 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 @@ -115,11 +120,10 @@ contains !$OMP DO SCHEDULE(STATIC) do i=1,n - x(i) = sumb(ithread+1) + x(i) + shift_ + x(i) = x(i) + sumb(ithread+1) + shift_ end do !$OMP END DO !$OMP SINGLE - x(1) = shift_ deallocate(sumb) !$OMP END SINGLE end subroutine inner_m_exscan diff --git a/base/serial/psi_s_serial_impl.F90 b/base/serial/psi_s_serial_impl.F90 index 6e5eadd78..26a57e687 100644 --- a/base/serial/psi_s_serial_impl.F90 +++ b/base/serial/psi_s_serial_impl.F90 @@ -43,6 +43,7 @@ subroutine psi_s_exscanv(n,x,info,shift) 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 @@ -76,9 +77,11 @@ contains ! 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. - integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk - real(psb_spk_), pointer :: sumb(:) + ! 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() @@ -90,19 +93,21 @@ contains wrk = (n)/nthreads if (ithread < MOD((n),nthreads)) then wrk = wrk + 1 - first_idx = ithread*wrk + 1 + idxstart = ithread*wrk + 1 else - first_idx = ithread*wrk + MOD((n),nthreads) + 1 + idxstart = ithread*wrk + MOD((n),nthreads) + 1 end if - last_idx = min(first_idx + wrk - 1,n ) - if (first_idx<=last_idx) then - sumb(ithread+2) = sumb(ithread+2) + x(first_idx) - do i=first_idx+1,last_idx - sumb(ithread+2) = sumb(ithread+2) + x(i) - x(i) = x(i)+x(i-1) + 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 @@ -115,11 +120,10 @@ contains !$OMP DO SCHEDULE(STATIC) do i=1,n - x(i) = sumb(ithread+1) + x(i) + shift_ + x(i) = x(i) + sumb(ithread+1) + shift_ end do !$OMP END DO !$OMP SINGLE - x(1) = shift_ deallocate(sumb) !$OMP END SINGLE end subroutine inner_s_exscan diff --git a/base/serial/psi_z_serial_impl.F90 b/base/serial/psi_z_serial_impl.F90 index ef13db0bb..0b15b2d61 100644 --- a/base/serial/psi_z_serial_impl.F90 +++ b/base/serial/psi_z_serial_impl.F90 @@ -43,6 +43,7 @@ subroutine psi_z_exscanv(n,x,info,shift) 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 @@ -76,9 +77,11 @@ contains ! 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. - integer(psb_ipk_) :: i,ithread,nthreads,first_idx,last_idx,wrk - complex(psb_dpk_), pointer :: sumb(:) + ! 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() @@ -90,19 +93,21 @@ contains wrk = (n)/nthreads if (ithread < MOD((n),nthreads)) then wrk = wrk + 1 - first_idx = ithread*wrk + 1 + idxstart = ithread*wrk + 1 else - first_idx = ithread*wrk + MOD((n),nthreads) + 1 + idxstart = ithread*wrk + MOD((n),nthreads) + 1 end if - last_idx = min(first_idx + wrk - 1,n ) - if (first_idx<=last_idx) then - sumb(ithread+2) = sumb(ithread+2) + x(first_idx) - do i=first_idx+1,last_idx - sumb(ithread+2) = sumb(ithread+2) + x(i) - x(i) = x(i)+x(i-1) + 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 @@ -115,11 +120,10 @@ contains !$OMP DO SCHEDULE(STATIC) do i=1,n - x(i) = sumb(ithread+1) + x(i) + shift_ + x(i) = x(i) + sumb(ithread+1) + shift_ end do !$OMP END DO !$OMP SINGLE - x(1) = shift_ deallocate(sumb) !$OMP END SINGLE end subroutine inner_z_exscan From 40cc78854a6dfd1386a769828e21dd611792fce1 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 21 Apr 2023 13:41:16 +0200 Subject: [PATCH 26/63] Improve implementation of fix_coo using exscan --- base/modules/serial/psb_c_base_mat_mod.F90 | 12 - base/modules/serial/psb_d_base_mat_mod.F90 | 12 - base/modules/serial/psb_s_base_mat_mod.F90 | 12 - base/modules/serial/psb_z_base_mat_mod.F90 | 12 - base/serial/impl/psb_c_coo_impl.F90 | 795 +-------------------- base/serial/impl/psb_d_coo_impl.F90 | 795 +-------------------- base/serial/impl/psb_s_coo_impl.F90 | 795 +-------------------- base/serial/impl/psb_z_coo_impl.F90 | 795 +-------------------- 8 files changed, 92 insertions(+), 3136 deletions(-) diff --git a/base/modules/serial/psb_c_base_mat_mod.F90 b/base/modules/serial/psb_c_base_mat_mod.F90 index 7a7bbb1f5..a5dd0fd03 100644 --- a/base/modules/serial/psb_c_base_mat_mod.F90 +++ b/base/modules/serial/psb_c_base_mat_mod.F90 @@ -1866,18 +1866,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) diff --git a/base/modules/serial/psb_d_base_mat_mod.F90 b/base/modules/serial/psb_d_base_mat_mod.F90 index eb49905d7..fac0af20a 100644 --- a/base/modules/serial/psb_d_base_mat_mod.F90 +++ b/base/modules/serial/psb_d_base_mat_mod.F90 @@ -1866,18 +1866,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) diff --git a/base/modules/serial/psb_s_base_mat_mod.F90 b/base/modules/serial/psb_s_base_mat_mod.F90 index 79c8222b8..186ae5777 100644 --- a/base/modules/serial/psb_s_base_mat_mod.F90 +++ b/base/modules/serial/psb_s_base_mat_mod.F90 @@ -1866,18 +1866,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) diff --git a/base/modules/serial/psb_z_base_mat_mod.F90 b/base/modules/serial/psb_z_base_mat_mod.F90 index 5b6ca07b7..3ce9074f7 100644 --- a/base/modules/serial/psb_z_base_mat_mod.F90 +++ b/base/modules/serial/psb_z_base_mat_mod.F90 @@ -1866,18 +1866,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) diff --git a/base/serial/impl/psb_c_coo_impl.F90 b/base/serial/impl/psb_c_coo_impl.F90 index c9be113ed..da6e97ca5 100644 --- a/base/serial/impl/psb_c_coo_impl.F90 +++ b/base/serial/impl/psb_c_coo_impl.F90 @@ -3573,7 +3573,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 @@ -3632,8 +3632,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_ @@ -3677,7 +3675,7 @@ subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf 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 @@ -3760,8 +3758,8 @@ subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf ! 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 private(s,i,j,k,ithread,idxstart,idxend,work,nxt_val,old_val,saved_elem, & + !$OMP first_elem,last_elem,nzl,iret,act_row) reduction(max: info) !$OMP SINGLE nthreads = omp_get_num_threads() @@ -3774,72 +3772,32 @@ 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 - - !$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 - - ! -------------------------------------- + idxend = idxstart + work - 1 + !write(0,*) 'fix_coo_inner: trying with exscan' + call psi_exscan(nr+1,iaux,info,shift=ione) !$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 @@ -3848,7 +3806,7 @@ subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf ! 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 @@ -3877,45 +3835,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 @@ -3923,7 +3843,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 @@ -3952,7 +3872,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 @@ -3981,7 +3901,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 @@ -4186,7 +4106,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 @@ -4200,22 +4120,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 @@ -4345,676 +4265,6 @@ 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 - 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 - 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 @@ -8347,3 +7597,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_d_coo_impl.F90 b/base/serial/impl/psb_d_coo_impl.F90 index bb845f4b2..08276552e 100644 --- a/base/serial/impl/psb_d_coo_impl.F90 +++ b/base/serial/impl/psb_d_coo_impl.F90 @@ -3573,7 +3573,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 @@ -3632,8 +3632,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_ @@ -3677,7 +3675,7 @@ subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf 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 @@ -3760,8 +3758,8 @@ subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf ! 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 private(s,i,j,k,ithread,idxstart,idxend,work,nxt_val,old_val,saved_elem, & + !$OMP first_elem,last_elem,nzl,iret,act_row) reduction(max: info) !$OMP SINGLE nthreads = omp_get_num_threads() @@ -3774,72 +3772,32 @@ 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 - - !$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 - - ! -------------------------------------- + idxend = idxstart + work - 1 + !write(0,*) 'fix_coo_inner: trying with exscan' + call psi_exscan(nr+1,iaux,info,shift=ione) !$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 @@ -3848,7 +3806,7 @@ subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf ! 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 @@ -3877,45 +3835,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 @@ -3923,7 +3843,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 @@ -3952,7 +3872,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 @@ -3981,7 +3901,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 @@ -4186,7 +4106,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 @@ -4200,22 +4120,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 @@ -4345,676 +4265,6 @@ 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 - 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 - 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 @@ -8347,3 +7597,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_s_coo_impl.F90 b/base/serial/impl/psb_s_coo_impl.F90 index 0b2016844..65bc5e10f 100644 --- a/base/serial/impl/psb_s_coo_impl.F90 +++ b/base/serial/impl/psb_s_coo_impl.F90 @@ -3573,7 +3573,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 @@ -3632,8 +3632,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_ @@ -3677,7 +3675,7 @@ subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf 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 @@ -3760,8 +3758,8 @@ subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf ! 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 private(s,i,j,k,ithread,idxstart,idxend,work,nxt_val,old_val,saved_elem, & + !$OMP first_elem,last_elem,nzl,iret,act_row) reduction(max: info) !$OMP SINGLE nthreads = omp_get_num_threads() @@ -3774,72 +3772,32 @@ 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 - - !$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 - - ! -------------------------------------- + idxend = idxstart + work - 1 + !write(0,*) 'fix_coo_inner: trying with exscan' + call psi_exscan(nr+1,iaux,info,shift=ione) !$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 @@ -3848,7 +3806,7 @@ subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf ! 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 @@ -3877,45 +3835,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 @@ -3923,7 +3843,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 @@ -3952,7 +3872,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 @@ -3981,7 +3901,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 @@ -4186,7 +4106,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 @@ -4200,22 +4120,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 @@ -4345,676 +4265,6 @@ 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 - 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 - 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 @@ -8347,3 +7597,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_z_coo_impl.F90 b/base/serial/impl/psb_z_coo_impl.F90 index 14410f23d..721d2edac 100644 --- a/base/serial/impl/psb_z_coo_impl.F90 +++ b/base/serial/impl/psb_z_coo_impl.F90 @@ -3573,7 +3573,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 @@ -3632,8 +3632,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_ @@ -3677,7 +3675,7 @@ subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf 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 @@ -3760,8 +3758,8 @@ subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf ! 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 private(s,i,j,k,ithread,idxstart,idxend,work,nxt_val,old_val,saved_elem, & + !$OMP first_elem,last_elem,nzl,iret,act_row) reduction(max: info) !$OMP SINGLE nthreads = omp_get_num_threads() @@ -3774,72 +3772,32 @@ 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 - - !$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 - - ! -------------------------------------- + idxend = idxstart + work - 1 + !write(0,*) 'fix_coo_inner: trying with exscan' + call psi_exscan(nr+1,iaux,info,shift=ione) !$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 @@ -3848,7 +3806,7 @@ subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf ! 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 @@ -3877,45 +3835,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 @@ -3923,7 +3843,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 @@ -3952,7 +3872,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 @@ -3981,7 +3901,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 @@ -4186,7 +4106,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 @@ -4200,22 +4120,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 @@ -4345,676 +4265,6 @@ 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 - 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 - 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 @@ -8347,3 +7597,4 @@ subroutine psb_lz_cp_coo_from_icoo(a,b,info) return end subroutine psb_lz_cp_coo_from_icoo + From 7e5dc20e0310e3524f57c9b209d89f0a2b12ce93 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Thu, 27 Apr 2023 13:05:46 +0200 Subject: [PATCH 27/63] Define new options for BSRCH, clean interface --- base/modules/auxil/psb_c_qsort_mod.f90 | 1 - base/modules/auxil/psb_d_qsort_mod.f90 | 5 +- base/modules/auxil/psb_e_qsort_mod.f90 | 5 +- base/modules/auxil/psb_i2_qsort_mod.f90 | 5 +- base/modules/auxil/psb_m_qsort_mod.f90 | 5 +- base/modules/auxil/psb_s_qsort_mod.f90 | 5 +- base/modules/auxil/psb_z_qsort_mod.f90 | 1 - base/modules/psb_const_mod.F90 | 16 ++-- base/serial/impl/psb_c_coo_impl.F90 | 13 ++- base/serial/impl/psb_d_coo_impl.F90 | 13 ++- base/serial/impl/psb_s_coo_impl.F90 | 13 ++- base/serial/impl/psb_z_coo_impl.F90 | 13 ++- base/serial/sort/psb_c_qsort_impl.f90 | 1 + base/serial/sort/psb_d_msort_impl.f90 | 58 ----------- base/serial/sort/psb_d_qsort_impl.f90 | 122 ++++++++++++++++++++++++ base/serial/sort/psb_e_msort_impl.f90 | 58 ----------- base/serial/sort/psb_e_qsort_impl.f90 | 122 ++++++++++++++++++++++++ base/serial/sort/psb_m_msort_impl.f90 | 58 ----------- base/serial/sort/psb_m_qsort_impl.f90 | 122 ++++++++++++++++++++++++ base/serial/sort/psb_s_msort_impl.f90 | 58 ----------- base/serial/sort/psb_s_qsort_impl.f90 | 122 ++++++++++++++++++++++++ base/serial/sort/psb_z_qsort_impl.f90 | 1 + base/tools/psb_cspins.F90 | 19 +++- base/tools/psb_dspins.F90 | 19 +++- base/tools/psb_sspins.F90 | 19 +++- base/tools/psb_zspins.F90 | 19 +++- test/omp/psb_tomp.F90 | 26 ++++- test/pargen/runs/ppde.inp | 4 +- 28 files changed, 641 insertions(+), 282 deletions(-) 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_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_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_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_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_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_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/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/serial/impl/psb_c_coo_impl.F90 b/base/serial/impl/psb_c_coo_impl.F90 index da6e97ca5..53bc34f6a 100644 --- a/base/serial/impl/psb_c_coo_impl.F90 +++ b/base/serial/impl/psb_c_coo_impl.F90 @@ -3674,6 +3674,7 @@ subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf 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,idxstart,idxend,first_elem,last_elem,s,nthreads,ithread integer(psb_ipk_) :: saved_elem,old_val,nxt_val,err,act_row,act_col,maxthreads @@ -3757,7 +3758,7 @@ 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 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) reduction(max: info) @@ -3782,7 +3783,10 @@ subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf !write(0,*) 'fix_coo_inner: trying with exscan' call psi_exscan(nr+1,iaux,info,shift=ione) !$OMP BARRIER - + !$OMP SINGLE + t0 = omp_get_wtime() + !$OMP END SINGLE + ! ------------------ Sorting and buffers ------------------- ! Let's use an auxiliary buffer, 'idxaux', to get indices leaving @@ -3803,7 +3807,10 @@ subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf end do !$OMP BARRIER - + !$OMP SINGLE + t1 = omp_get_wtime() + write(0,*) '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=idxstart,idxend diff --git a/base/serial/impl/psb_d_coo_impl.F90 b/base/serial/impl/psb_d_coo_impl.F90 index 08276552e..030dc8676 100644 --- a/base/serial/impl/psb_d_coo_impl.F90 +++ b/base/serial/impl/psb_d_coo_impl.F90 @@ -3674,6 +3674,7 @@ subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf 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,idxstart,idxend,first_elem,last_elem,s,nthreads,ithread integer(psb_ipk_) :: saved_elem,old_val,nxt_val,err,act_row,act_col,maxthreads @@ -3757,7 +3758,7 @@ 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 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) reduction(max: info) @@ -3782,7 +3783,10 @@ subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf !write(0,*) 'fix_coo_inner: trying with exscan' call psi_exscan(nr+1,iaux,info,shift=ione) !$OMP BARRIER - + !$OMP SINGLE + t0 = omp_get_wtime() + !$OMP END SINGLE + ! ------------------ Sorting and buffers ------------------- ! Let's use an auxiliary buffer, 'idxaux', to get indices leaving @@ -3803,7 +3807,10 @@ subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf end do !$OMP BARRIER - + !$OMP SINGLE + t1 = omp_get_wtime() + write(0,*) '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=idxstart,idxend diff --git a/base/serial/impl/psb_s_coo_impl.F90 b/base/serial/impl/psb_s_coo_impl.F90 index 65bc5e10f..fb19d523e 100644 --- a/base/serial/impl/psb_s_coo_impl.F90 +++ b/base/serial/impl/psb_s_coo_impl.F90 @@ -3674,6 +3674,7 @@ subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf 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,idxstart,idxend,first_elem,last_elem,s,nthreads,ithread integer(psb_ipk_) :: saved_elem,old_val,nxt_val,err,act_row,act_col,maxthreads @@ -3757,7 +3758,7 @@ 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 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) reduction(max: info) @@ -3782,7 +3783,10 @@ subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf !write(0,*) 'fix_coo_inner: trying with exscan' call psi_exscan(nr+1,iaux,info,shift=ione) !$OMP BARRIER - + !$OMP SINGLE + t0 = omp_get_wtime() + !$OMP END SINGLE + ! ------------------ Sorting and buffers ------------------- ! Let's use an auxiliary buffer, 'idxaux', to get indices leaving @@ -3803,7 +3807,10 @@ subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf end do !$OMP BARRIER - + !$OMP SINGLE + t1 = omp_get_wtime() + write(0,*) '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=idxstart,idxend diff --git a/base/serial/impl/psb_z_coo_impl.F90 b/base/serial/impl/psb_z_coo_impl.F90 index 721d2edac..ba14eeba1 100644 --- a/base/serial/impl/psb_z_coo_impl.F90 +++ b/base/serial/impl/psb_z_coo_impl.F90 @@ -3674,6 +3674,7 @@ subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf 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,idxstart,idxend,first_elem,last_elem,s,nthreads,ithread integer(psb_ipk_) :: saved_elem,old_val,nxt_val,err,act_row,act_col,maxthreads @@ -3757,7 +3758,7 @@ 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 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) reduction(max: info) @@ -3782,7 +3783,10 @@ subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf !write(0,*) 'fix_coo_inner: trying with exscan' call psi_exscan(nr+1,iaux,info,shift=ione) !$OMP BARRIER - + !$OMP SINGLE + t0 = omp_get_wtime() + !$OMP END SINGLE + ! ------------------ Sorting and buffers ------------------- ! Let's use an auxiliary buffer, 'idxaux', to get indices leaving @@ -3803,7 +3807,10 @@ subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf end do !$OMP BARRIER - + !$OMP SINGLE + t1 = omp_get_wtime() + write(0,*) '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=idxstart,idxend 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..4d6918e70 100644 --- a/base/serial/sort/psb_d_qsort_impl.f90 +++ b/base/serial/sort/psb_d_qsort_impl.f90 @@ -40,6 +40,128 @@ ! 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) then + ipos = m + exit + end if + m = m - 1 + end do + else + do while (mn) .or. (m<1)) then + m = 1 + do while (m<=n) + if (v(m)>=key) then + ipos = m + exit + end if + m = m + 1 + end do + else + do while (m>n) + if (v(m)>=key) then + m=m-1 + else + exit + end if + end do + end if + 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..8be3cd780 100644 --- a/base/serial/sort/psb_e_qsort_impl.f90 +++ b/base/serial/sort/psb_e_qsort_impl.f90 @@ -40,6 +40,128 @@ ! 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) then + ipos = m + exit + end if + m = m - 1 + end do + else + do while (mn) .or. (m<1)) then + m = 1 + do while (m<=n) + if (v(m)>=key) then + ipos = m + exit + end if + m = m + 1 + end do + else + do while (m>n) + if (v(m)>=key) then + m=m-1 + else + exit + end if + end do + end if + 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..460bff434 100644 --- a/base/serial/sort/psb_m_qsort_impl.f90 +++ b/base/serial/sort/psb_m_qsort_impl.f90 @@ -40,6 +40,128 @@ ! 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) then + ipos = m + exit + end if + m = m - 1 + end do + else + do while (mn) .or. (m<1)) then + m = 1 + do while (m<=n) + if (v(m)>=key) then + ipos = m + exit + end if + m = m + 1 + end do + else + do while (m>n) + if (v(m)>=key) then + m=m-1 + else + exit + end if + end do + end if + 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..44a46e0ab 100644 --- a/base/serial/sort/psb_s_qsort_impl.f90 +++ b/base/serial/sort/psb_s_qsort_impl.f90 @@ -40,6 +40,128 @@ ! 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) then + ipos = m + exit + end if + m = m - 1 + end do + else + do while (mn) .or. (m<1)) then + m = 1 + do while (m<=n) + if (v(m)>=key) then + ipos = m + exit + end if + m = m + 1 + end do + else + do while (m>n) + if (v(m)>=key) then + m=m-1 + else + exit + end if + end do + end if + 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_cspins.F90 b/base/tools/psb_cspins.F90 index 0f5fc9dfb..f523a529f 100644 --- a/base/tools/psb_cspins.F90 +++ b/base/tools/psb_cspins.F90 @@ -135,7 +135,7 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) goto 9999 end if #if defined(OPENMP) - !$omp parallel private(ila,jla,nrow,ncol) + !$omp parallel private(ila,jla,nrow,ncol,nnl,k) #endif 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,& @@ -198,9 +198,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,& @@ -210,7 +219,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) @@ -229,8 +238,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 06f913b54..3b7e0e805 100644 --- a/base/tools/psb_dspins.F90 +++ b/base/tools/psb_dspins.F90 @@ -135,7 +135,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) goto 9999 end if #if defined(OPENMP) - !$omp parallel private(ila,jla,nrow,ncol) + !$omp parallel private(ila,jla,nrow,ncol,nnl,k) #endif 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,& @@ -198,9 +198,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,& @@ -210,7 +219,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) @@ -229,8 +238,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 56ef9c97f..9781eaae2 100644 --- a/base/tools/psb_sspins.F90 +++ b/base/tools/psb_sspins.F90 @@ -135,7 +135,7 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) goto 9999 end if #if defined(OPENMP) - !$omp parallel private(ila,jla,nrow,ncol) + !$omp parallel private(ila,jla,nrow,ncol,nnl,k) #endif 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,& @@ -198,9 +198,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,& @@ -210,7 +219,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) @@ -229,8 +238,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 d483f198a..36b0b5a5d 100644 --- a/base/tools/psb_zspins.F90 +++ b/base/tools/psb_zspins.F90 @@ -135,7 +135,7 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) goto 9999 end if #if defined(OPENMP) - !$omp parallel private(ila,jla,nrow,ncol) + !$omp parallel private(ila,jla,nrow,ncol,nnl,k) #endif 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,& @@ -198,9 +198,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,& @@ -210,7 +219,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) @@ -229,8 +238,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/test/omp/psb_tomp.F90 b/test/omp/psb_tomp.F90 index fda08f4ed..79097ca81 100644 --- a/test/omp/psb_tomp.F90 +++ b/test/omp/psb_tomp.F90 @@ -736,6 +736,30 @@ program psb_d_pde3d 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 ! @@ -756,6 +780,7 @@ program psb_d_pde3d 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. ! @@ -858,7 +883,6 @@ program psb_d_pde3d write(psb_out_unit,'("Storage format for DESC_A: ",a)') desc_a%get_fmt() end if - ! ! cleanup storage and exit ! diff --git a/test/pargen/runs/ppde.inp b/test/pargen/runs/ppde.inp index fb7af68c4..40e3358d9 100644 --- a/test/pargen/runs/ppde.inp +++ b/test/pargen/runs/ppde.inp @@ -2,10 +2,10 @@ BICGSTAB Iterative method BICGSTAB CGS BICG BICGSTABL RGMRES FCG CGR BJAC Preconditioner NONE DIAG BJAC CSR Storage format for matrix A: CSR COO -040 Domain size (acutal system is this**3 (pde3d) or **2 (pde2d) ) +140 Domain size (acutal system is this**3 (pde3d) or **2 (pde2d) ) 3 Partition: 1 BLOCK 3 3D 2 Stopping criterion 1 2 -0100 MAXIT +0200 MAXIT 05 ITRACE 002 IRST restart for RGMRES and BiCGSTABL INVK Block Solver ILU,ILUT,INVK,AINVT,AORTH From 494e29dd2eac32b8ebbf72ab16c6fabd26dbed0b Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 23 May 2023 15:56:48 +0200 Subject: [PATCH 28/63] Cosmetic adjustments to COO and BSRCH --- base/serial/impl/psb_c_coo_impl.F90 | 11 +++++------ base/serial/impl/psb_d_coo_impl.F90 | 11 +++++------ base/serial/impl/psb_s_coo_impl.F90 | 11 +++++------ base/serial/impl/psb_z_coo_impl.F90 | 11 +++++------ base/serial/sort/psb_d_qsort_impl.f90 | 23 ++++++++++------------- base/serial/sort/psb_e_qsort_impl.f90 | 23 ++++++++++------------- base/serial/sort/psb_m_qsort_impl.f90 | 23 ++++++++++------------- base/serial/sort/psb_s_qsort_impl.f90 | 23 ++++++++++------------- 8 files changed, 60 insertions(+), 76 deletions(-) diff --git a/base/serial/impl/psb_c_coo_impl.F90 b/base/serial/impl/psb_c_coo_impl.F90 index 8f1f54ae3..03939afe7 100644 --- a/base/serial/impl/psb_c_coo_impl.F90 +++ b/base/serial/impl/psb_c_coo_impl.F90 @@ -3669,7 +3669,7 @@ 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 @@ -3759,7 +3759,7 @@ subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf !$OMP PARALLEL default(none) & !$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) reduction(max: info) + !$OMP first_elem,last_elem,nzl,iret,act_row,i1,i2) reduction(max: info) !$OMP SINGLE nthreads = omp_get_num_threads() @@ -3783,7 +3783,7 @@ subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf call psi_exscan(nr+1,iaux,info,shift=ione) !$OMP BARRIER !$OMP SINGLE - t0 = omp_get_wtime() + !t0 = omp_get_wtime() !$OMP END SINGLE ! ------------------ Sorting and buffers ------------------- @@ -3793,7 +3793,6 @@ subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf 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) @@ -3807,8 +3806,8 @@ subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf !$OMP BARRIER !$OMP SINGLE - t1 = omp_get_wtime() - write(0,*) 'Srt&Cpy :',t1-t0 + !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' diff --git a/base/serial/impl/psb_d_coo_impl.F90 b/base/serial/impl/psb_d_coo_impl.F90 index 5d50788ab..9597c5f5a 100644 --- a/base/serial/impl/psb_d_coo_impl.F90 +++ b/base/serial/impl/psb_d_coo_impl.F90 @@ -3669,7 +3669,7 @@ 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 @@ -3759,7 +3759,7 @@ subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf !$OMP PARALLEL default(none) & !$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) reduction(max: info) + !$OMP first_elem,last_elem,nzl,iret,act_row,i1,i2) reduction(max: info) !$OMP SINGLE nthreads = omp_get_num_threads() @@ -3783,7 +3783,7 @@ subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf call psi_exscan(nr+1,iaux,info,shift=ione) !$OMP BARRIER !$OMP SINGLE - t0 = omp_get_wtime() + !t0 = omp_get_wtime() !$OMP END SINGLE ! ------------------ Sorting and buffers ------------------- @@ -3793,7 +3793,6 @@ subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf 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) @@ -3807,8 +3806,8 @@ subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf !$OMP BARRIER !$OMP SINGLE - t1 = omp_get_wtime() - write(0,*) 'Srt&Cpy :',t1-t0 + !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' diff --git a/base/serial/impl/psb_s_coo_impl.F90 b/base/serial/impl/psb_s_coo_impl.F90 index 837eb4292..174d3e077 100644 --- a/base/serial/impl/psb_s_coo_impl.F90 +++ b/base/serial/impl/psb_s_coo_impl.F90 @@ -3669,7 +3669,7 @@ 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 @@ -3759,7 +3759,7 @@ subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf !$OMP PARALLEL default(none) & !$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) reduction(max: info) + !$OMP first_elem,last_elem,nzl,iret,act_row,i1,i2) reduction(max: info) !$OMP SINGLE nthreads = omp_get_num_threads() @@ -3783,7 +3783,7 @@ subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf call psi_exscan(nr+1,iaux,info,shift=ione) !$OMP BARRIER !$OMP SINGLE - t0 = omp_get_wtime() + !t0 = omp_get_wtime() !$OMP END SINGLE ! ------------------ Sorting and buffers ------------------- @@ -3793,7 +3793,6 @@ subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf 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) @@ -3807,8 +3806,8 @@ subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf !$OMP BARRIER !$OMP SINGLE - t1 = omp_get_wtime() - write(0,*) 'Srt&Cpy :',t1-t0 + !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' diff --git a/base/serial/impl/psb_z_coo_impl.F90 b/base/serial/impl/psb_z_coo_impl.F90 index 21ae86584..2ccc614a9 100644 --- a/base/serial/impl/psb_z_coo_impl.F90 +++ b/base/serial/impl/psb_z_coo_impl.F90 @@ -3669,7 +3669,7 @@ 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 @@ -3759,7 +3759,7 @@ subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf !$OMP PARALLEL default(none) & !$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) reduction(max: info) + !$OMP first_elem,last_elem,nzl,iret,act_row,i1,i2) reduction(max: info) !$OMP SINGLE nthreads = omp_get_num_threads() @@ -3783,7 +3783,7 @@ subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf call psi_exscan(nr+1,iaux,info,shift=ione) !$OMP BARRIER !$OMP SINGLE - t0 = omp_get_wtime() + !t0 = omp_get_wtime() !$OMP END SINGLE ! ------------------ Sorting and buffers ------------------- @@ -3793,7 +3793,6 @@ subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf 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) @@ -3807,8 +3806,8 @@ subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf !$OMP BARRIER !$OMP SINGLE - t1 = omp_get_wtime() - write(0,*) 'Srt&Cpy :',t1-t0 + !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' diff --git a/base/serial/sort/psb_d_qsort_impl.f90 b/base/serial/sort/psb_d_qsort_impl.f90 index 4d6918e70..8e4b1d213 100644 --- a/base/serial/sort/psb_d_qsort_impl.f90 +++ b/base/serial/sort/psb_d_qsort_impl.f90 @@ -44,8 +44,8 @@ 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(:) + real(psb_dpk_) :: key + real(psb_dpk_) :: v(:) integer(psb_ipk_), optional :: dir, find integer(psb_ipk_) :: lb, ub, m, i, k, dir_, find_ @@ -95,40 +95,37 @@ real(psb_dpk_) :: v(:) if ((m>n) .or. (m<1)) then m = n do while (m>=1) - if (v(m)<=key) then - ipos = m - exit - end if + 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) then - ipos = m - exit - end if + if (v(m)>=key) exit m = m + 1 end do else - do while (m>n) - if (v(m)>=key) then + 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 diff --git a/base/serial/sort/psb_e_qsort_impl.f90 b/base/serial/sort/psb_e_qsort_impl.f90 index 8be3cd780..c70f80519 100644 --- a/base/serial/sort/psb_e_qsort_impl.f90 +++ b/base/serial/sort/psb_e_qsort_impl.f90 @@ -44,8 +44,8 @@ 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_epk_) :: key + integer(psb_epk_) :: v(:) integer(psb_ipk_), optional :: dir, find integer(psb_ipk_) :: lb, ub, m, i, k, dir_, find_ @@ -95,40 +95,37 @@ integer(psb_epk_) :: v(:) if ((m>n) .or. (m<1)) then m = n do while (m>=1) - if (v(m)<=key) then - ipos = m - exit - end if + 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) then - ipos = m - exit - end if + if (v(m)>=key) exit m = m + 1 end do else - do while (m>n) - if (v(m)>=key) then + 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 diff --git a/base/serial/sort/psb_m_qsort_impl.f90 b/base/serial/sort/psb_m_qsort_impl.f90 index 460bff434..6b70c3a07 100644 --- a/base/serial/sort/psb_m_qsort_impl.f90 +++ b/base/serial/sort/psb_m_qsort_impl.f90 @@ -44,8 +44,8 @@ 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_mpk_) :: key + integer(psb_mpk_) :: v(:) integer(psb_ipk_), optional :: dir, find integer(psb_ipk_) :: lb, ub, m, i, k, dir_, find_ @@ -95,40 +95,37 @@ integer(psb_mpk_) :: v(:) if ((m>n) .or. (m<1)) then m = n do while (m>=1) - if (v(m)<=key) then - ipos = m - exit - end if + 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) then - ipos = m - exit - end if + if (v(m)>=key) exit m = m + 1 end do else - do while (m>n) - if (v(m)>=key) then + 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 diff --git a/base/serial/sort/psb_s_qsort_impl.f90 b/base/serial/sort/psb_s_qsort_impl.f90 index 44a46e0ab..cae325464 100644 --- a/base/serial/sort/psb_s_qsort_impl.f90 +++ b/base/serial/sort/psb_s_qsort_impl.f90 @@ -44,8 +44,8 @@ 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(:) + real(psb_spk_) :: key + real(psb_spk_) :: v(:) integer(psb_ipk_), optional :: dir, find integer(psb_ipk_) :: lb, ub, m, i, k, dir_, find_ @@ -95,40 +95,37 @@ real(psb_spk_) :: v(:) if ((m>n) .or. (m<1)) then m = n do while (m>=1) - if (v(m)<=key) then - ipos = m - exit - end if + 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) then - ipos = m - exit - end if + if (v(m)>=key) exit m = m + 1 end do else - do while (m>n) - if (v(m)>=key) then + 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 From 1941affe7a8969bbea6bec721003dad131597b7d Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 30 May 2023 12:26:58 +0200 Subject: [PATCH 29/63] Exposed error in AMG test when not parallelizing generation loop --- base/modules/auxil/psb_e_realloc_mod.F90 | 12 +++++--- base/modules/desc/psb_gen_block_map_mod.F90 | 2 +- base/modules/desc/psb_hash_map_mod.F90 | 33 +++++++++++++++------ base/modules/desc/psb_hash_mod.F90 | 7 ++++- base/tools/psb_dspins.F90 | 8 +++-- test/pargen/psb_d_pde3d.F90 | 1 + 6 files changed, 45 insertions(+), 18 deletions(-) diff --git a/base/modules/auxil/psb_e_realloc_mod.F90 b/base/modules/auxil/psb_e_realloc_mod.F90 index 0f2431fde..e11abd7c6 100644 --- a/base/modules/auxil/psb_e_realloc_mod.F90 +++ b/base/modules/auxil/psb_e_realloc_mod.F90 @@ -139,7 +139,7 @@ Contains name='psb_r_m_e_rk1' call psb_erractionsave(err_act) info=psb_success_ - if (debug) write(psb_err_unit,*) 'reallocate D',len + if (debug) write(psb_err_unit,*) 'e_reallocate D',len if (present(lb)) then lb_ = lb @@ -170,7 +170,7 @@ Contains End If else dim = 0 - Allocate(rrax(lb_:ub_),stat=info) + Allocate(rrax(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & @@ -178,6 +178,7 @@ Contains goto 9999 end if endif + if (debug) write(psb_err_unit,*) 'reallocate 2 info',info if (present(pad)) then !$omp parallel do private(i) shared(dim,len) do i=lb_-1+dim+1,lb_-1+len @@ -187,8 +188,9 @@ Contains call psb_erractionrestore(err_act) return -9999 continue +9999 continue info = err + !write(0,*) 'e_realloc : ',info call psb_error_handler(err_act) return @@ -986,7 +988,8 @@ Contains call psb_erractionsave(err_act) info = psb_success_ - if (psb_errstatus_fatal()) then + if (psb_errstatus_fatal()) then + write(0,*) 'From ensure_size: errstatus_fatal()' info=psb_err_from_subroutine_ goto 9999 end if @@ -1028,6 +1031,7 @@ Contains !$OMP END CRITICAL if (info /= psb_success_) then + write(0,*) 'From ensure_size: ',info,psb_err_from_subroutine_ info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') goto 9999 diff --git a/base/modules/desc/psb_gen_block_map_mod.F90 b/base/modules/desc/psb_gen_block_map_mod.F90 index 2c20a547f..f0c433e02 100644 --- a/base/modules/desc/psb_gen_block_map_mod.F90 +++ b/base/modules/desc/psb_gen_block_map_mod.F90 @@ -488,7 +488,7 @@ contains integer(psb_ipk_) :: iam, np logical :: owned_ - write(0,*) 'block_g2lv2' + !write(0,*) 'block_g2lv2' info = 0 ctxt = idxmap%get_ctxt() call psb_info(ctxt,iam,np) diff --git a/base/modules/desc/psb_hash_map_mod.F90 b/base/modules/desc/psb_hash_map_mod.F90 index eac8cc7ab..4e04a3719 100644 --- a/base/modules/desc/psb_hash_map_mod.F90 +++ b/base/modules/desc/psb_hash_map_mod.F90 @@ -515,7 +515,6 @@ contains endif end if enddo - else write(0,*) 'Hash status: invalid ',idxmap%get_state() idxout(1:is) = -1 @@ -655,7 +654,7 @@ contains #endif logical, volatile :: isLoopValid info = psb_success_ - name = 'hash_g2l_ins' + name = 'hash_g2lv1_ins' call psb_erractionsave(err_act) ctxt = idxmap%get_ctxt() @@ -679,7 +678,7 @@ contains mglob = idxmap%get_gr() nrow = idxmap%get_lr() - + !write(0,*) me,name,' before loop ',psb_errstatus_fatal() if (use_openmp) then #ifdef OPENMP !call OMP_init_lock(ins_lck) @@ -751,6 +750,7 @@ contains & pad=-1_psb_lpk_,addsz=laddsz) 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/)) @@ -832,6 +832,7 @@ contains & 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/)) @@ -883,38 +884,42 @@ contains ! 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 !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, so this lock is relatively rare). ncol = idxmap%get_lc() - nxt = ncol + 1 + 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) - + !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) + !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 psb_ensure_size(ncol,idxmap%loc_to_glob,info,& & pad=-1_psb_lpk_,addsz=laddsz) - 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/)) @@ -996,6 +1001,7 @@ contains & 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/)) @@ -1069,6 +1075,7 @@ contains 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' call psb_errpush(psb_err_from_subroutine_ai_,name,& &a_err='psb_ensure_size',i_err=(/info/)) isLoopValid = .false. @@ -1113,9 +1120,11 @@ contains 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) + 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. @@ -1162,6 +1171,7 @@ contains & pad=-1_psb_lpk_,addsz=laddsz) if (info /= psb_success_) then info=1 + write(0,*) 'Error spot 5' call psb_errpush(psb_err_from_subroutine_ai_,name,& & a_err='psb_ensure_size',i_err=(/info/)) isLoopValid = .false. @@ -1205,6 +1215,7 @@ contains & 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/)) @@ -1239,6 +1250,7 @@ contains #endif if (.not. isLoopValid) goto 9999 end if + !write(0,*) me,name,' after loop ',psb_errstatus_fatal() call psb_erractionrestore(err_act) return @@ -1252,6 +1264,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(:) @@ -1264,7 +1277,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 c3c5ba20b..68e10a05e 100644 --- a/base/modules/desc/psb_hash_mod.F90 +++ b/base/modules/desc/psb_hash_mod.F90 @@ -407,6 +407,7 @@ 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 !$omp critical(hashsearchins) @@ -440,11 +441,15 @@ contains end if end if !$omp end critical(hashsearchins) - if (info /= HashOk) return + 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) diff --git a/base/tools/psb_dspins.F90 b/base/tools/psb_dspins.F90 index 3b7e0e805..094d0a4b1 100644 --- a/base/tools/psb_dspins.F90 +++ b/base/tools/psb_dspins.F90 @@ -137,10 +137,12 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) #if defined(OPENMP) !$omp parallel private(ila,jla,nrow,ncol,nnl,k) #endif + !write(0,*) me,' Before g2l ',psb_errstatus_fatal() 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/)) @@ -148,7 +150,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 @@ -181,7 +183,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) call psb_errpush(info,name) !goto 9999 end if - + !write(0,*) me,' after csput',psb_errstatus_fatal() #if defined(OPENMP) !$omp end parallel #endif diff --git a/test/pargen/psb_d_pde3d.F90 b/test/pargen/psb_d_pde3d.F90 index 6e895c004..eebc5ad8c 100644 --- a/test/pargen/psb_d_pde3d.F90 +++ b/test/pargen/psb_d_pde3d.F90 @@ -737,6 +737,7 @@ program psb_d_pde3d ! ! allocate and fill in the coefficient matrix, rhs and initial guess ! + call psb_cd_set_large_threshold(100_psb_lpk_) call psb_barrier(ctxt) t1 = psb_wtime() call psb_gen_pde3d(ctxt,idim,a,bv,xxv,desc_a,afmt,info,partition=ipart) From db0e4db507027444f5c93e489596398c893571fb Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 2 Jun 2023 11:06:53 +0200 Subject: [PATCH 30/63] Minimize debug sttements in hash_ins --- base/modules/auxil/psb_e_realloc_mod.F90 | 12 ++++-------- base/modules/desc/psb_hash_map_mod.F90 | 12 +++++++++++- base/modules/desc/psb_hash_mod.F90 | 2 +- 3 files changed, 16 insertions(+), 10 deletions(-) diff --git a/base/modules/auxil/psb_e_realloc_mod.F90 b/base/modules/auxil/psb_e_realloc_mod.F90 index e11abd7c6..0f2431fde 100644 --- a/base/modules/auxil/psb_e_realloc_mod.F90 +++ b/base/modules/auxil/psb_e_realloc_mod.F90 @@ -139,7 +139,7 @@ Contains name='psb_r_m_e_rk1' call psb_erractionsave(err_act) info=psb_success_ - if (debug) write(psb_err_unit,*) 'e_reallocate D',len + if (debug) write(psb_err_unit,*) 'reallocate D',len if (present(lb)) then lb_ = lb @@ -170,7 +170,7 @@ Contains End If else dim = 0 - Allocate(rrax(lb_:ub_),stat=info) + Allocate(rrax(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & @@ -178,7 +178,6 @@ Contains goto 9999 end if endif - if (debug) write(psb_err_unit,*) 'reallocate 2 info',info if (present(pad)) then !$omp parallel do private(i) shared(dim,len) do i=lb_-1+dim+1,lb_-1+len @@ -188,9 +187,8 @@ Contains call psb_erractionrestore(err_act) return -9999 continue +9999 continue info = err - !write(0,*) 'e_realloc : ',info call psb_error_handler(err_act) return @@ -988,8 +986,7 @@ Contains call psb_erractionsave(err_act) info = psb_success_ - if (psb_errstatus_fatal()) then - write(0,*) 'From ensure_size: errstatus_fatal()' + if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -1031,7 +1028,6 @@ Contains !$OMP END CRITICAL if (info /= psb_success_) then - write(0,*) 'From ensure_size: ',info,psb_err_from_subroutine_ info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') goto 9999 diff --git a/base/modules/desc/psb_hash_map_mod.F90 b/base/modules/desc/psb_hash_map_mod.F90 index 4e04a3719..b7f53879c 100644 --- a/base/modules/desc/psb_hash_map_mod.F90 +++ b/base/modules/desc/psb_hash_map_mod.F90 @@ -375,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 @@ -414,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 @@ -503,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 @@ -541,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 @@ -704,6 +708,7 @@ contains ! $ 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 @@ -790,6 +795,7 @@ contains ! $ 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 @@ -867,10 +873,11 @@ contains ! $ 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) + !$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 @@ -905,6 +912,7 @@ contains ! Index not found !write(0,*) me,name,' b hsik ',psb_errstatus_fatal() call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + 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 @@ -918,6 +926,7 @@ contains ncol = MAX(ncol,nxt) 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,& @@ -958,6 +967,7 @@ contains !$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 diff --git a/base/modules/desc/psb_hash_mod.F90 b/base/modules/desc/psb_hash_mod.F90 index 68e10a05e..9e45e1f07 100644 --- a/base/modules/desc/psb_hash_mod.F90 +++ b/base/modules/desc/psb_hash_mod.F90 @@ -449,7 +449,7 @@ contains hk = hk - hd if (hk < 0) hk = hk + hsize end do - write(0,*) 'In searchinskey 3: ', info + !write(0,*) 'In searchinskey 3: ', info end subroutine psb_hash_lsearchinskey recursive subroutine psb_hash_isearchinskey(key,val,nextval,hash,info) From 347352fe1e5b3ba8f8ebfa085c34c010a8474df0 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 2 Jun 2023 11:07:23 +0200 Subject: [PATCH 31/63] Make spins work in OpenMP from either par or serial --- base/tools/psb_cspins.F90 | 123 ++++++++++++++++++++++++++++++++---- base/tools/psb_dspins.F90 | 119 +++++++++++++++++++++++++++++++--- base/tools/psb_sspins.F90 | 123 ++++++++++++++++++++++++++++++++---- base/tools/psb_zspins.F90 | 123 ++++++++++++++++++++++++++++++++---- test/pargen/psb_d_pde3d.F90 | 1 - 5 files changed, 445 insertions(+), 44 deletions(-) diff --git a/base/tools/psb_cspins.F90 b/base/tools/psb_cspins.F90 index f523a529f..e5f2731d0 100644 --- a/base/tools/psb_cspins.F90 +++ b/base/tools/psb_cspins.F90 @@ -135,28 +135,132 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) goto 9999 end if #if defined(OPENMP) - !$omp parallel private(ila,jla,nrow,ncol,nnl,k) -#endif + 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.) + 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 + 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 + goto 9999 end if - + if (a%is_remote_build()) then nnl = count(ila(1:nz)<0) if (nnl > 0) then @@ -179,11 +283,8 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) else info = psb_err_invalid_a_and_cd_state_ call psb_errpush(info,name) - !goto 9999 + goto 9999 end if - -#if defined(OPENMP) - !$omp end parallel #endif if (info /= 0) goto 9999 endif diff --git a/base/tools/psb_dspins.F90 b/base/tools/psb_dspins.F90 index 094d0a4b1..cdeaa9314 100644 --- a/base/tools/psb_dspins.F90 +++ b/base/tools/psb_dspins.F90 @@ -135,18 +135,120 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) goto 9999 end if #if defined(OPENMP) - !$omp parallel private(ila,jla,nrow,ncol,nnl,k) -#endif + 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.) - !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 + goto 9999 end if nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() @@ -156,9 +258,9 @@ 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) if (nnl > 0) then @@ -181,11 +283,8 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) else info = psb_err_invalid_a_and_cd_state_ call psb_errpush(info,name) - !goto 9999 + goto 9999 end if - !write(0,*) me,' after csput',psb_errstatus_fatal() -#if defined(OPENMP) - !$omp end parallel #endif if (info /= 0) goto 9999 endif diff --git a/base/tools/psb_sspins.F90 b/base/tools/psb_sspins.F90 index 9781eaae2..39e4ad799 100644 --- a/base/tools/psb_sspins.F90 +++ b/base/tools/psb_sspins.F90 @@ -135,28 +135,132 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) goto 9999 end if #if defined(OPENMP) - !$omp parallel private(ila,jla,nrow,ncol,nnl,k) -#endif + 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.) + 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 + 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 + goto 9999 end if - + if (a%is_remote_build()) then nnl = count(ila(1:nz)<0) if (nnl > 0) then @@ -179,11 +283,8 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) else info = psb_err_invalid_a_and_cd_state_ call psb_errpush(info,name) - !goto 9999 + goto 9999 end if - -#if defined(OPENMP) - !$omp end parallel #endif if (info /= 0) goto 9999 endif diff --git a/base/tools/psb_zspins.F90 b/base/tools/psb_zspins.F90 index 36b0b5a5d..0c0ff91fd 100644 --- a/base/tools/psb_zspins.F90 +++ b/base/tools/psb_zspins.F90 @@ -135,28 +135,132 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) goto 9999 end if #if defined(OPENMP) - !$omp parallel private(ila,jla,nrow,ncol,nnl,k) -#endif + 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.) + 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 + 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 + goto 9999 end if - + if (a%is_remote_build()) then nnl = count(ila(1:nz)<0) if (nnl > 0) then @@ -179,11 +283,8 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) else info = psb_err_invalid_a_and_cd_state_ call psb_errpush(info,name) - !goto 9999 + goto 9999 end if - -#if defined(OPENMP) - !$omp end parallel #endif if (info /= 0) goto 9999 endif diff --git a/test/pargen/psb_d_pde3d.F90 b/test/pargen/psb_d_pde3d.F90 index eebc5ad8c..6e895c004 100644 --- a/test/pargen/psb_d_pde3d.F90 +++ b/test/pargen/psb_d_pde3d.F90 @@ -737,7 +737,6 @@ program psb_d_pde3d ! ! allocate and fill in the coefficient matrix, rhs and initial guess ! - call psb_cd_set_large_threshold(100_psb_lpk_) call psb_barrier(ctxt) t1 = psb_wtime() call psb_gen_pde3d(ctxt,idim,a,bv,xxv,desc_a,afmt,info,partition=ipart) From 677789469cf82441d9b253ac8583c728652dca24 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Wed, 21 Jun 2023 12:14:47 +0200 Subject: [PATCH 32/63] Reworked ensure_size --- base/modules/auxil/psb_c_hsort_x_mod.f90 | 6 +-- base/modules/auxil/psb_c_realloc_mod.F90 | 48 +++++++++++------------ base/modules/auxil/psb_d_hsort_x_mod.f90 | 6 +-- base/modules/auxil/psb_d_realloc_mod.F90 | 48 +++++++++++------------ base/modules/auxil/psb_e_realloc_mod.F90 | 48 +++++++++++------------ base/modules/auxil/psb_i2_realloc_mod.F90 | 48 +++++++++++------------ base/modules/auxil/psb_i_hsort_x_mod.f90 | 6 +-- base/modules/auxil/psb_l_hsort_x_mod.f90 | 6 +-- base/modules/auxil/psb_m_realloc_mod.F90 | 48 +++++++++++------------ base/modules/auxil/psb_s_hsort_x_mod.f90 | 6 +-- base/modules/auxil/psb_s_realloc_mod.F90 | 48 +++++++++++------------ base/modules/auxil/psb_z_hsort_x_mod.f90 | 6 +-- base/modules/auxil/psb_z_realloc_mod.F90 | 48 +++++++++++------------ 13 files changed, 179 insertions(+), 193 deletions(-) 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_realloc_mod.F90 b/base/modules/auxil/psb_c_realloc_mod.F90 index 9e6af5a88..4cea46832 100644 --- a/base/modules/auxil/psb_c_realloc_mod.F90 +++ b/base/modules/auxil/psb_c_realloc_mod.F90 @@ -1009,18 +1009,17 @@ Contains !!$ 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 +1032,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 +1085,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_realloc_mod.F90 b/base/modules/auxil/psb_d_realloc_mod.F90 index 672b4677f..f30435fe7 100644 --- a/base/modules/auxil/psb_d_realloc_mod.F90 +++ b/base/modules/auxil/psb_d_realloc_mod.F90 @@ -1009,18 +1009,17 @@ Contains !!$ 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 +1032,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 +1085,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_realloc_mod.F90 b/base/modules/auxil/psb_e_realloc_mod.F90 index 0f2431fde..0cf321f49 100644 --- a/base/modules/auxil/psb_e_realloc_mod.F90 +++ b/base/modules/auxil/psb_e_realloc_mod.F90 @@ -1009,18 +1009,17 @@ Contains !!$ 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 +1032,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 +1085,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_realloc_mod.F90 b/base/modules/auxil/psb_i2_realloc_mod.F90 index 22e85d36d..cebd86959 100644 --- a/base/modules/auxil/psb_i2_realloc_mod.F90 +++ b/base/modules/auxil/psb_i2_realloc_mod.F90 @@ -1009,18 +1009,17 @@ Contains !!$ 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 +1032,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 +1085,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_realloc_mod.F90 b/base/modules/auxil/psb_m_realloc_mod.F90 index c81ed83af..42b981b48 100644 --- a/base/modules/auxil/psb_m_realloc_mod.F90 +++ b/base/modules/auxil/psb_m_realloc_mod.F90 @@ -1009,18 +1009,17 @@ Contains !!$ 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 +1032,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 +1085,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_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_realloc_mod.F90 b/base/modules/auxil/psb_s_realloc_mod.F90 index 0b2873e30..8d2d5af1e 100644 --- a/base/modules/auxil/psb_s_realloc_mod.F90 +++ b/base/modules/auxil/psb_s_realloc_mod.F90 @@ -1009,18 +1009,17 @@ Contains !!$ 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 +1032,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 +1085,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_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_realloc_mod.F90 b/base/modules/auxil/psb_z_realloc_mod.F90 index e6eeac2f7..e81b767ad 100644 --- a/base/modules/auxil/psb_z_realloc_mod.F90 +++ b/base/modules/auxil/psb_z_realloc_mod.F90 @@ -1009,18 +1009,17 @@ Contains !!$ 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 +1032,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 +1085,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) From a66778f2706db6c498fc45efb22994a76128cfd4 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Wed, 21 Jun 2023 12:21:27 +0200 Subject: [PATCH 33/63] Improve coo and merge development --- base/modules/auxil/psb_c_hsort_x_mod.f90 | 6 +-- base/modules/auxil/psb_c_realloc_mod.F90 | 52 ++++++++++++----------- base/modules/auxil/psb_d_hsort_x_mod.f90 | 6 +-- base/modules/auxil/psb_d_realloc_mod.F90 | 52 ++++++++++++----------- base/modules/auxil/psb_e_realloc_mod.F90 | 52 ++++++++++++----------- base/modules/auxil/psb_i2_realloc_mod.F90 | 52 ++++++++++++----------- base/modules/auxil/psb_i_hsort_x_mod.f90 | 6 +-- base/modules/auxil/psb_l_hsort_x_mod.f90 | 6 +-- base/modules/auxil/psb_m_realloc_mod.F90 | 52 ++++++++++++----------- base/modules/auxil/psb_s_hsort_x_mod.f90 | 6 +-- base/modules/auxil/psb_s_realloc_mod.F90 | 52 ++++++++++++----------- base/modules/auxil/psb_z_hsort_x_mod.f90 | 6 +-- base/modules/auxil/psb_z_realloc_mod.F90 | 52 ++++++++++++----------- base/serial/impl/psb_c_coo_impl.F90 | 6 +-- base/serial/impl/psb_d_coo_impl.F90 | 6 +-- base/serial/impl/psb_s_coo_impl.F90 | 6 +-- base/serial/impl/psb_z_coo_impl.F90 | 6 +-- 17 files changed, 219 insertions(+), 205 deletions(-) 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_realloc_mod.F90 b/base/modules/auxil/psb_c_realloc_mod.F90 index 9e6af5a88..11aebdd89 100644 --- a/base/modules/auxil/psb_c_realloc_mod.F90 +++ b/base/modules/auxil/psb_c_realloc_mod.F90 @@ -790,7 +790,9 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:) = vin(:) + !$omp end workshare endif endif @@ -836,7 +838,9 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:,:) = vin(:,:) + !$omp end workshare endif endif @@ -1009,18 +1013,17 @@ Contains !!$ 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 +1036,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 +1089,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_realloc_mod.F90 b/base/modules/auxil/psb_d_realloc_mod.F90 index 672b4677f..79c7864d7 100644 --- a/base/modules/auxil/psb_d_realloc_mod.F90 +++ b/base/modules/auxil/psb_d_realloc_mod.F90 @@ -790,7 +790,9 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:) = vin(:) + !$omp end workshare endif endif @@ -836,7 +838,9 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:,:) = vin(:,:) + !$omp end workshare endif endif @@ -1009,18 +1013,17 @@ Contains !!$ 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 +1036,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 +1089,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_realloc_mod.F90 b/base/modules/auxil/psb_e_realloc_mod.F90 index 0f2431fde..2cdbe6ffd 100644 --- a/base/modules/auxil/psb_e_realloc_mod.F90 +++ b/base/modules/auxil/psb_e_realloc_mod.F90 @@ -790,7 +790,9 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:) = vin(:) + !$omp end workshare endif endif @@ -836,7 +838,9 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:,:) = vin(:,:) + !$omp end workshare endif endif @@ -1009,18 +1013,17 @@ Contains !!$ 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 +1036,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 +1089,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_realloc_mod.F90 b/base/modules/auxil/psb_i2_realloc_mod.F90 index 22e85d36d..b89c641fb 100644 --- a/base/modules/auxil/psb_i2_realloc_mod.F90 +++ b/base/modules/auxil/psb_i2_realloc_mod.F90 @@ -790,7 +790,9 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:) = vin(:) + !$omp end workshare endif endif @@ -836,7 +838,9 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:,:) = vin(:,:) + !$omp end workshare endif endif @@ -1009,18 +1013,17 @@ Contains !!$ 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 +1036,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 +1089,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_realloc_mod.F90 b/base/modules/auxil/psb_m_realloc_mod.F90 index c81ed83af..a2261bd6f 100644 --- a/base/modules/auxil/psb_m_realloc_mod.F90 +++ b/base/modules/auxil/psb_m_realloc_mod.F90 @@ -790,7 +790,9 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:) = vin(:) + !$omp end workshare endif endif @@ -836,7 +838,9 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:,:) = vin(:,:) + !$omp end workshare endif endif @@ -1009,18 +1013,17 @@ Contains !!$ 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 +1036,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 +1089,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_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_realloc_mod.F90 b/base/modules/auxil/psb_s_realloc_mod.F90 index 0b2873e30..28e82312c 100644 --- a/base/modules/auxil/psb_s_realloc_mod.F90 +++ b/base/modules/auxil/psb_s_realloc_mod.F90 @@ -790,7 +790,9 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:) = vin(:) + !$omp end workshare endif endif @@ -836,7 +838,9 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:,:) = vin(:,:) + !$omp end workshare endif endif @@ -1009,18 +1013,17 @@ Contains !!$ 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 +1036,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 +1089,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_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_realloc_mod.F90 b/base/modules/auxil/psb_z_realloc_mod.F90 index e6eeac2f7..a699fadbe 100644 --- a/base/modules/auxil/psb_z_realloc_mod.F90 +++ b/base/modules/auxil/psb_z_realloc_mod.F90 @@ -790,7 +790,9 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:) = vin(:) + !$omp end workshare endif endif @@ -836,7 +838,9 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:,:) = vin(:,:) + !$omp end workshare endif endif @@ -1009,18 +1013,17 @@ Contains !!$ 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 +1036,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 +1089,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/impl/psb_c_coo_impl.F90 b/base/serial/impl/psb_c_coo_impl.F90 index 03939afe7..a8ea36138 100644 --- a/base/serial/impl/psb_c_coo_impl.F90 +++ b/base/serial/impl/psb_c_coo_impl.F90 @@ -4563,7 +4563,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 @@ -4630,7 +4630,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 @@ -4680,7 +4680,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 diff --git a/base/serial/impl/psb_d_coo_impl.F90 b/base/serial/impl/psb_d_coo_impl.F90 index 9597c5f5a..86a5d84ac 100644 --- a/base/serial/impl/psb_d_coo_impl.F90 +++ b/base/serial/impl/psb_d_coo_impl.F90 @@ -4563,7 +4563,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 @@ -4630,7 +4630,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 @@ -4680,7 +4680,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 diff --git a/base/serial/impl/psb_s_coo_impl.F90 b/base/serial/impl/psb_s_coo_impl.F90 index 174d3e077..d857b74f2 100644 --- a/base/serial/impl/psb_s_coo_impl.F90 +++ b/base/serial/impl/psb_s_coo_impl.F90 @@ -4563,7 +4563,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 @@ -4630,7 +4630,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 @@ -4680,7 +4680,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 diff --git a/base/serial/impl/psb_z_coo_impl.F90 b/base/serial/impl/psb_z_coo_impl.F90 index 2ccc614a9..ac39bcba1 100644 --- a/base/serial/impl/psb_z_coo_impl.F90 +++ b/base/serial/impl/psb_z_coo_impl.F90 @@ -4563,7 +4563,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 @@ -4630,7 +4630,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 @@ -4680,7 +4680,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 From d378266f334004a143ea29b8e03dade3692456c9 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Wed, 21 Jun 2023 13:37:23 +0200 Subject: [PATCH 34/63] Fix synatx error --- base/modules/auxil/psb_c_realloc_mod.F90 | 2 +- base/modules/auxil/psb_d_realloc_mod.F90 | 2 +- base/modules/auxil/psb_e_realloc_mod.F90 | 2 +- base/modules/auxil/psb_i2_realloc_mod.F90 | 2 +- base/modules/auxil/psb_m_realloc_mod.F90 | 2 +- base/modules/auxil/psb_s_realloc_mod.F90 | 2 +- base/modules/auxil/psb_z_realloc_mod.F90 | 2 +- 7 files changed, 7 insertions(+), 7 deletions(-) diff --git a/base/modules/auxil/psb_c_realloc_mod.F90 b/base/modules/auxil/psb_c_realloc_mod.F90 index 11aebdd89..f5f46fcde 100644 --- a/base/modules/auxil/psb_c_realloc_mod.F90 +++ b/base/modules/auxil/psb_c_realloc_mod.F90 @@ -1021,7 +1021,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz)) + isz = max(len,1,isz+addsz) else isz = max(len,1,int(1.25*isz)) endif diff --git a/base/modules/auxil/psb_d_realloc_mod.F90 b/base/modules/auxil/psb_d_realloc_mod.F90 index 79c7864d7..9f994e498 100644 --- a/base/modules/auxil/psb_d_realloc_mod.F90 +++ b/base/modules/auxil/psb_d_realloc_mod.F90 @@ -1021,7 +1021,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz)) + isz = max(len,1,isz+addsz) else isz = max(len,1,int(1.25*isz)) endif diff --git a/base/modules/auxil/psb_e_realloc_mod.F90 b/base/modules/auxil/psb_e_realloc_mod.F90 index 2cdbe6ffd..5b9c38be4 100644 --- a/base/modules/auxil/psb_e_realloc_mod.F90 +++ b/base/modules/auxil/psb_e_realloc_mod.F90 @@ -1021,7 +1021,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz)) + isz = max(len,1,isz+addsz) else isz = max(len,1,int(1.25*isz)) endif diff --git a/base/modules/auxil/psb_i2_realloc_mod.F90 b/base/modules/auxil/psb_i2_realloc_mod.F90 index b89c641fb..4a25a44ec 100644 --- a/base/modules/auxil/psb_i2_realloc_mod.F90 +++ b/base/modules/auxil/psb_i2_realloc_mod.F90 @@ -1021,7 +1021,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz)) + isz = max(len,1,isz+addsz) else isz = max(len,1,int(1.25*isz)) endif diff --git a/base/modules/auxil/psb_m_realloc_mod.F90 b/base/modules/auxil/psb_m_realloc_mod.F90 index a2261bd6f..26584fbd3 100644 --- a/base/modules/auxil/psb_m_realloc_mod.F90 +++ b/base/modules/auxil/psb_m_realloc_mod.F90 @@ -1021,7 +1021,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz)) + isz = max(len,1,isz+addsz) else isz = max(len,1,int(1.25*isz)) endif diff --git a/base/modules/auxil/psb_s_realloc_mod.F90 b/base/modules/auxil/psb_s_realloc_mod.F90 index 28e82312c..1392bc18a 100644 --- a/base/modules/auxil/psb_s_realloc_mod.F90 +++ b/base/modules/auxil/psb_s_realloc_mod.F90 @@ -1021,7 +1021,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz)) + isz = max(len,1,isz+addsz) else isz = max(len,1,int(1.25*isz)) endif diff --git a/base/modules/auxil/psb_z_realloc_mod.F90 b/base/modules/auxil/psb_z_realloc_mod.F90 index a699fadbe..c9201e835 100644 --- a/base/modules/auxil/psb_z_realloc_mod.F90 +++ b/base/modules/auxil/psb_z_realloc_mod.F90 @@ -1021,7 +1021,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz)) + isz = max(len,1,isz+addsz) else isz = max(len,1,int(1.25*isz)) endif From 402354dbd88216e9addd45abdd21b1186ee000b6 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Thu, 22 Jun 2023 11:52:08 +0200 Subject: [PATCH 35/63] Fix syntax issue --- base/modules/auxil/psb_c_realloc_mod.F90 | 2 +- base/modules/auxil/psb_d_realloc_mod.F90 | 2 +- base/modules/auxil/psb_e_realloc_mod.F90 | 2 +- base/modules/auxil/psb_i2_realloc_mod.F90 | 2 +- base/modules/auxil/psb_m_realloc_mod.F90 | 2 +- base/modules/auxil/psb_s_realloc_mod.F90 | 2 +- base/modules/auxil/psb_z_realloc_mod.F90 | 2 +- 7 files changed, 7 insertions(+), 7 deletions(-) diff --git a/base/modules/auxil/psb_c_realloc_mod.F90 b/base/modules/auxil/psb_c_realloc_mod.F90 index 4cea46832..231fde3f8 100644 --- a/base/modules/auxil/psb_c_realloc_mod.F90 +++ b/base/modules/auxil/psb_c_realloc_mod.F90 @@ -1017,7 +1017,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz)) + isz = max(len,1,isz+addsz) else isz = max(len,1,int(1.25*isz)) endif diff --git a/base/modules/auxil/psb_d_realloc_mod.F90 b/base/modules/auxil/psb_d_realloc_mod.F90 index f30435fe7..cb48fc669 100644 --- a/base/modules/auxil/psb_d_realloc_mod.F90 +++ b/base/modules/auxil/psb_d_realloc_mod.F90 @@ -1017,7 +1017,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz)) + isz = max(len,1,isz+addsz) else isz = max(len,1,int(1.25*isz)) endif diff --git a/base/modules/auxil/psb_e_realloc_mod.F90 b/base/modules/auxil/psb_e_realloc_mod.F90 index 0cf321f49..1bf45e30c 100644 --- a/base/modules/auxil/psb_e_realloc_mod.F90 +++ b/base/modules/auxil/psb_e_realloc_mod.F90 @@ -1017,7 +1017,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz)) + isz = max(len,1,isz+addsz) else isz = max(len,1,int(1.25*isz)) endif diff --git a/base/modules/auxil/psb_i2_realloc_mod.F90 b/base/modules/auxil/psb_i2_realloc_mod.F90 index cebd86959..cbf4d58a9 100644 --- a/base/modules/auxil/psb_i2_realloc_mod.F90 +++ b/base/modules/auxil/psb_i2_realloc_mod.F90 @@ -1017,7 +1017,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz)) + isz = max(len,1,isz+addsz) else isz = max(len,1,int(1.25*isz)) endif diff --git a/base/modules/auxil/psb_m_realloc_mod.F90 b/base/modules/auxil/psb_m_realloc_mod.F90 index 42b981b48..e0e486ecd 100644 --- a/base/modules/auxil/psb_m_realloc_mod.F90 +++ b/base/modules/auxil/psb_m_realloc_mod.F90 @@ -1017,7 +1017,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz)) + isz = max(len,1,isz+addsz) else isz = max(len,1,int(1.25*isz)) endif diff --git a/base/modules/auxil/psb_s_realloc_mod.F90 b/base/modules/auxil/psb_s_realloc_mod.F90 index 8d2d5af1e..676caf31f 100644 --- a/base/modules/auxil/psb_s_realloc_mod.F90 +++ b/base/modules/auxil/psb_s_realloc_mod.F90 @@ -1017,7 +1017,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz)) + isz = max(len,1,isz+addsz) else isz = max(len,1,int(1.25*isz)) endif diff --git a/base/modules/auxil/psb_z_realloc_mod.F90 b/base/modules/auxil/psb_z_realloc_mod.F90 index e81b767ad..652d3c99a 100644 --- a/base/modules/auxil/psb_z_realloc_mod.F90 +++ b/base/modules/auxil/psb_z_realloc_mod.F90 @@ -1017,7 +1017,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz)) + isz = max(len,1,isz+addsz) else isz = max(len,1,int(1.25*isz)) endif From 2f403e0df75a9d41d5a5664355c6d043bba9f477 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Wed, 28 Jun 2023 11:16:53 +0200 Subject: [PATCH 36/63] Rework cp_{from|to}_fmt for better OpenMP performance --- base/modules/auxil/psb_c_realloc_mod.F90 | 10 +++-- base/modules/auxil/psb_d_realloc_mod.F90 | 10 +++-- base/modules/auxil/psb_e_realloc_mod.F90 | 10 +++-- base/modules/auxil/psb_i2_realloc_mod.F90 | 10 +++-- base/modules/auxil/psb_m_realloc_mod.F90 | 10 +++-- base/modules/auxil/psb_s_realloc_mod.F90 | 10 +++-- base/modules/auxil/psb_z_realloc_mod.F90 | 10 +++-- base/serial/impl/psb_c_csc_impl.F90 | 49 ++++++++++++++++++++--- base/serial/impl/psb_c_csr_impl.F90 | 49 ++++++++++++++++++++--- base/serial/impl/psb_d_csc_impl.F90 | 49 ++++++++++++++++++++--- base/serial/impl/psb_d_csr_impl.F90 | 49 ++++++++++++++++++++--- base/serial/impl/psb_s_csc_impl.F90 | 49 ++++++++++++++++++++--- base/serial/impl/psb_s_csr_impl.F90 | 49 ++++++++++++++++++++--- base/serial/impl/psb_z_csc_impl.F90 | 49 ++++++++++++++++++++--- base/serial/impl/psb_z_csr_impl.F90 | 49 ++++++++++++++++++++--- 15 files changed, 386 insertions(+), 76 deletions(-) diff --git a/base/modules/auxil/psb_c_realloc_mod.F90 b/base/modules/auxil/psb_c_realloc_mod.F90 index f5f46fcde..c042f2e6a 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,9 +790,11 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else - !$omp workshare - vout(:) = vin(:) - !$omp end workshare + !$omp parallel do private(i) + do i=lb,lb+isz-1 + vout(i) = vin(i) + end do + !$omp end parallel do endif endif diff --git a/base/modules/auxil/psb_d_realloc_mod.F90 b/base/modules/auxil/psb_d_realloc_mod.F90 index 9f994e498..f1fac1433 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,9 +790,11 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else - !$omp workshare - vout(:) = vin(:) - !$omp end workshare + !$omp parallel do private(i) + do i=lb,lb+isz-1 + vout(i) = vin(i) + end do + !$omp end parallel do endif endif diff --git a/base/modules/auxil/psb_e_realloc_mod.F90 b/base/modules/auxil/psb_e_realloc_mod.F90 index 5b9c38be4..3f8b67f85 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,9 +790,11 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else - !$omp workshare - vout(:) = vin(:) - !$omp end workshare + !$omp parallel do private(i) + do i=lb,lb+isz-1 + vout(i) = vin(i) + end do + !$omp end parallel do endif endif diff --git a/base/modules/auxil/psb_i2_realloc_mod.F90 b/base/modules/auxil/psb_i2_realloc_mod.F90 index 4a25a44ec..c6babd682 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,9 +790,11 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else - !$omp workshare - vout(:) = vin(:) - !$omp end workshare + !$omp parallel do private(i) + do i=lb,lb+isz-1 + vout(i) = vin(i) + end do + !$omp end parallel do endif endif diff --git a/base/modules/auxil/psb_m_realloc_mod.F90 b/base/modules/auxil/psb_m_realloc_mod.F90 index 26584fbd3..2027d9b72 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,9 +790,11 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else - !$omp workshare - vout(:) = vin(:) - !$omp end workshare + !$omp parallel do private(i) + do i=lb,lb+isz-1 + vout(i) = vin(i) + end do + !$omp end parallel do endif endif diff --git a/base/modules/auxil/psb_s_realloc_mod.F90 b/base/modules/auxil/psb_s_realloc_mod.F90 index 1392bc18a..1c0ca7dfb 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,9 +790,11 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else - !$omp workshare - vout(:) = vin(:) - !$omp end workshare + !$omp parallel do private(i) + do i=lb,lb+isz-1 + vout(i) = vin(i) + end do + !$omp end parallel do endif endif diff --git a/base/modules/auxil/psb_z_realloc_mod.F90 b/base/modules/auxil/psb_z_realloc_mod.F90 index c9201e835..ece5680da 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,9 +790,11 @@ Contains call psb_errpush(info,name,a_err=char_err) goto 9999 else - !$omp workshare - vout(:) = vin(:) - !$omp end workshare + !$omp parallel do private(i) + do i=lb,lb+isz-1 + vout(i) = vin(i) + end do + !$omp end parallel do endif endif diff --git a/base/serial/impl/psb_c_csc_impl.F90 b/base/serial/impl/psb_c_csc_impl.F90 index d8837b76a..54332d063 100644 --- a/base/serial/impl/psb_c_csc_impl.F90 +++ b/base/serial/impl/psb_c_csc_impl.F90 @@ -2329,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 @@ -2443,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 477796467..f06bf5493 100644 --- a/base/serial/impl/psb_c_csr_impl.F90 +++ b/base/serial/impl/psb_c_csr_impl.F90 @@ -3190,9 +3190,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 @@ -3276,9 +3295,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 diff --git a/base/serial/impl/psb_d_csc_impl.F90 b/base/serial/impl/psb_d_csc_impl.F90 index a50d50267..1761b0514 100644 --- a/base/serial/impl/psb_d_csc_impl.F90 +++ b/base/serial/impl/psb_d_csc_impl.F90 @@ -2329,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 @@ -2443,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 10518a2d0..529fed79d 100644 --- a/base/serial/impl/psb_d_csr_impl.F90 +++ b/base/serial/impl/psb_d_csr_impl.F90 @@ -3190,9 +3190,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 @@ -3276,9 +3295,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 diff --git a/base/serial/impl/psb_s_csc_impl.F90 b/base/serial/impl/psb_s_csc_impl.F90 index dc4ca30b0..a66b7dc09 100644 --- a/base/serial/impl/psb_s_csc_impl.F90 +++ b/base/serial/impl/psb_s_csc_impl.F90 @@ -2329,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 @@ -2443,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 22ceb6e57..cb9e413d9 100644 --- a/base/serial/impl/psb_s_csr_impl.F90 +++ b/base/serial/impl/psb_s_csr_impl.F90 @@ -3190,9 +3190,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 @@ -3276,9 +3295,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 diff --git a/base/serial/impl/psb_z_csc_impl.F90 b/base/serial/impl/psb_z_csc_impl.F90 index 035d0e831..e5516bd97 100644 --- a/base/serial/impl/psb_z_csc_impl.F90 +++ b/base/serial/impl/psb_z_csc_impl.F90 @@ -2329,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 @@ -2443,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 60839e5da..4c976e14e 100644 --- a/base/serial/impl/psb_z_csr_impl.F90 +++ b/base/serial/impl/psb_z_csr_impl.F90 @@ -3190,9 +3190,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 @@ -3276,9 +3295,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 From bb9f213551200577899fd86ad9cef01a1e096d17 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 18 Jul 2023 18:19:03 +0200 Subject: [PATCH 37/63] Define and implement OMP version of TRIL/TRIU --- base/modules/serial/psb_c_base_mat_mod.F90 | 89 +++ base/modules/serial/psb_d_base_mat_mod.F90 | 89 +++ base/modules/serial/psb_s_base_mat_mod.F90 | 89 +++ base/modules/serial/psb_z_base_mat_mod.F90 | 89 +++ base/serial/impl/psb_c_coo_impl.F90 | 597 +++++++++++++++++++++ base/serial/impl/psb_d_coo_impl.F90 | 597 +++++++++++++++++++++ base/serial/impl/psb_s_coo_impl.F90 | 597 +++++++++++++++++++++ base/serial/impl/psb_z_coo_impl.F90 | 597 +++++++++++++++++++++ 8 files changed, 2744 insertions(+) diff --git a/base/modules/serial/psb_c_base_mat_mod.F90 b/base/modules/serial/psb_c_base_mat_mod.F90 index a5dd0fd03..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 @@ -1894,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_d_base_mat_mod.F90 b/base/modules/serial/psb_d_base_mat_mod.F90 index fac0af20a..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 @@ -1894,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_s_base_mat_mod.F90 b/base/modules/serial/psb_s_base_mat_mod.F90 index 186ae5777..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 @@ -1894,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_z_base_mat_mod.F90 b/base/modules/serial/psb_z_base_mat_mod.F90 index 3ce9074f7..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 @@ -1894,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/serial/impl/psb_c_coo_impl.F90 b/base/serial/impl/psb_c_coo_impl.F90 index a8ea36138..f740b3a71 100644 --- a/base/serial/impl/psb_c_coo_impl.F90 +++ b/base/serial/impl/psb_c_coo_impl.F90 @@ -3489,6 +3489,603 @@ subroutine psb_c_coo_mv_from(a,b) end subroutine psb_c_coo_mv_from +! +! CSR 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, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-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 + end do + 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 diff --git a/base/serial/impl/psb_d_coo_impl.F90 b/base/serial/impl/psb_d_coo_impl.F90 index 86a5d84ac..1aafe2e40 100644 --- a/base/serial/impl/psb_d_coo_impl.F90 +++ b/base/serial/impl/psb_d_coo_impl.F90 @@ -3489,6 +3489,603 @@ subroutine psb_d_coo_mv_from(a,b) end subroutine psb_d_coo_mv_from +! +! CSR 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, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-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 + end do + 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 diff --git a/base/serial/impl/psb_s_coo_impl.F90 b/base/serial/impl/psb_s_coo_impl.F90 index d857b74f2..d99017bfc 100644 --- a/base/serial/impl/psb_s_coo_impl.F90 +++ b/base/serial/impl/psb_s_coo_impl.F90 @@ -3489,6 +3489,603 @@ subroutine psb_s_coo_mv_from(a,b) end subroutine psb_s_coo_mv_from +! +! CSR 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, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-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 + end do + 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 diff --git a/base/serial/impl/psb_z_coo_impl.F90 b/base/serial/impl/psb_z_coo_impl.F90 index ac39bcba1..5532c7f16 100644 --- a/base/serial/impl/psb_z_coo_impl.F90 +++ b/base/serial/impl/psb_z_coo_impl.F90 @@ -3489,6 +3489,603 @@ subroutine psb_z_coo_mv_from(a,b) end subroutine psb_z_coo_mv_from +! +! CSR 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, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-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 + end do + 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 From 5e691d5bffc858592527a6f13c010f39ff7d98d8 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Mon, 24 Jul 2023 13:21:20 +0200 Subject: [PATCH 38/63] Some improvements for openmp vector updates --- base/modules/auxil/psb_c_realloc_mod.F90 | 18 ------------------ base/modules/auxil/psb_d_realloc_mod.F90 | 18 ------------------ base/modules/auxil/psb_e_realloc_mod.F90 | 18 ------------------ base/modules/auxil/psb_i2_realloc_mod.F90 | 18 ------------------ base/modules/auxil/psb_m_realloc_mod.F90 | 18 ------------------ base/modules/auxil/psb_s_realloc_mod.F90 | 18 ------------------ base/modules/auxil/psb_z_realloc_mod.F90 | 18 ------------------ base/modules/serial/psb_c_base_vect_mod.F90 | 6 +++++- base/modules/serial/psb_d_base_vect_mod.F90 | 6 +++++- base/modules/serial/psb_i_base_vect_mod.F90 | 6 +++++- base/modules/serial/psb_l_base_vect_mod.F90 | 6 +++++- base/modules/serial/psb_s_base_vect_mod.F90 | 6 +++++- base/modules/serial/psb_z_base_vect_mod.F90 | 6 +++++- 13 files changed, 30 insertions(+), 132 deletions(-) diff --git a/base/modules/auxil/psb_c_realloc_mod.F90 b/base/modules/auxil/psb_c_realloc_mod.F90 index c042f2e6a..9b22bee78 100644 --- a/base/modules/auxil/psb_c_realloc_mod.F90 +++ b/base/modules/auxil/psb_c_realloc_mod.F90 @@ -997,24 +997,6 @@ 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 isz = psb_size(v) If (len > isz) Then #if defined(OPENMP) diff --git a/base/modules/auxil/psb_d_realloc_mod.F90 b/base/modules/auxil/psb_d_realloc_mod.F90 index f1fac1433..ca85e0ec0 100644 --- a/base/modules/auxil/psb_d_realloc_mod.F90 +++ b/base/modules/auxil/psb_d_realloc_mod.F90 @@ -997,24 +997,6 @@ 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 isz = psb_size(v) If (len > isz) Then #if defined(OPENMP) diff --git a/base/modules/auxil/psb_e_realloc_mod.F90 b/base/modules/auxil/psb_e_realloc_mod.F90 index 3f8b67f85..06a6d0348 100644 --- a/base/modules/auxil/psb_e_realloc_mod.F90 +++ b/base/modules/auxil/psb_e_realloc_mod.F90 @@ -997,24 +997,6 @@ 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 isz = psb_size(v) If (len > isz) Then #if defined(OPENMP) diff --git a/base/modules/auxil/psb_i2_realloc_mod.F90 b/base/modules/auxil/psb_i2_realloc_mod.F90 index c6babd682..146bdf7e1 100644 --- a/base/modules/auxil/psb_i2_realloc_mod.F90 +++ b/base/modules/auxil/psb_i2_realloc_mod.F90 @@ -997,24 +997,6 @@ 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 isz = psb_size(v) If (len > isz) Then #if defined(OPENMP) diff --git a/base/modules/auxil/psb_m_realloc_mod.F90 b/base/modules/auxil/psb_m_realloc_mod.F90 index 2027d9b72..4d2f93160 100644 --- a/base/modules/auxil/psb_m_realloc_mod.F90 +++ b/base/modules/auxil/psb_m_realloc_mod.F90 @@ -997,24 +997,6 @@ 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 isz = psb_size(v) If (len > isz) Then #if defined(OPENMP) diff --git a/base/modules/auxil/psb_s_realloc_mod.F90 b/base/modules/auxil/psb_s_realloc_mod.F90 index 1c0ca7dfb..f064e6068 100644 --- a/base/modules/auxil/psb_s_realloc_mod.F90 +++ b/base/modules/auxil/psb_s_realloc_mod.F90 @@ -997,24 +997,6 @@ 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 isz = psb_size(v) If (len > isz) Then #if defined(OPENMP) diff --git a/base/modules/auxil/psb_z_realloc_mod.F90 b/base/modules/auxil/psb_z_realloc_mod.F90 index ece5680da..e9eb26d36 100644 --- a/base/modules/auxil/psb_z_realloc_mod.F90 +++ b/base/modules/auxil/psb_z_realloc_mod.F90 @@ -997,24 +997,6 @@ 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 isz = psb_size(v) If (len > isz) Then #if defined(OPENMP) 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_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_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_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 From ca82520b88f404833295697e1a3921bd76c11c52 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 1 Aug 2023 10:16:22 +0200 Subject: [PATCH 39/63] Reworked CSR TRIL/TRIU for OpenMP --- base/serial/impl/psb_c_coo_impl.F90 | 2 +- base/serial/impl/psb_c_csr_impl.F90 | 304 +++++++++++++++++++++++++++- base/serial/impl/psb_d_coo_impl.F90 | 2 +- base/serial/impl/psb_d_csr_impl.F90 | 304 +++++++++++++++++++++++++++- base/serial/impl/psb_s_coo_impl.F90 | 2 +- base/serial/impl/psb_s_csr_impl.F90 | 304 +++++++++++++++++++++++++++- base/serial/impl/psb_z_coo_impl.F90 | 2 +- base/serial/impl/psb_z_csr_impl.F90 | 304 +++++++++++++++++++++++++++- 8 files changed, 1212 insertions(+), 12 deletions(-) diff --git a/base/serial/impl/psb_c_coo_impl.F90 b/base/serial/impl/psb_c_coo_impl.F90 index f740b3a71..b800ce22d 100644 --- a/base/serial/impl/psb_c_coo_impl.F90 +++ b/base/serial/impl/psb_c_coo_impl.F90 @@ -3490,7 +3490,7 @@ end subroutine psb_c_coo_mv_from ! -! CSR implementation of tril/triu +! COO implementation of tril/triu ! subroutine psb_c_coo_tril(a,l,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,u) diff --git a/base/serial/impl/psb_c_csr_impl.F90 b/base/serial/impl/psb_c_csr_impl.F90 index f06bf5493..6c3ecec6e 100644 --- a/base/serial/impl/psb_c_csr_impl.F90 +++ b/base/serial/impl/psb_c_csr_impl.F90 @@ -2289,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) @@ -2359,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) @@ -2443,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) @@ -2511,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) diff --git a/base/serial/impl/psb_d_coo_impl.F90 b/base/serial/impl/psb_d_coo_impl.F90 index 1aafe2e40..5452ab2b7 100644 --- a/base/serial/impl/psb_d_coo_impl.F90 +++ b/base/serial/impl/psb_d_coo_impl.F90 @@ -3490,7 +3490,7 @@ end subroutine psb_d_coo_mv_from ! -! CSR implementation of tril/triu +! COO implementation of tril/triu ! subroutine psb_d_coo_tril(a,l,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,u) diff --git a/base/serial/impl/psb_d_csr_impl.F90 b/base/serial/impl/psb_d_csr_impl.F90 index 529fed79d..5b6673427 100644 --- a/base/serial/impl/psb_d_csr_impl.F90 +++ b/base/serial/impl/psb_d_csr_impl.F90 @@ -2289,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) @@ -2359,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) @@ -2443,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) @@ -2511,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) diff --git a/base/serial/impl/psb_s_coo_impl.F90 b/base/serial/impl/psb_s_coo_impl.F90 index d99017bfc..cfc4a2f9d 100644 --- a/base/serial/impl/psb_s_coo_impl.F90 +++ b/base/serial/impl/psb_s_coo_impl.F90 @@ -3490,7 +3490,7 @@ end subroutine psb_s_coo_mv_from ! -! CSR implementation of tril/triu +! COO implementation of tril/triu ! subroutine psb_s_coo_tril(a,l,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,u) diff --git a/base/serial/impl/psb_s_csr_impl.F90 b/base/serial/impl/psb_s_csr_impl.F90 index cb9e413d9..dbe7a4bea 100644 --- a/base/serial/impl/psb_s_csr_impl.F90 +++ b/base/serial/impl/psb_s_csr_impl.F90 @@ -2289,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) @@ -2359,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) @@ -2443,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) @@ -2511,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) diff --git a/base/serial/impl/psb_z_coo_impl.F90 b/base/serial/impl/psb_z_coo_impl.F90 index 5532c7f16..fb4aa48e3 100644 --- a/base/serial/impl/psb_z_coo_impl.F90 +++ b/base/serial/impl/psb_z_coo_impl.F90 @@ -3490,7 +3490,7 @@ end subroutine psb_z_coo_mv_from ! -! CSR implementation of tril/triu +! COO implementation of tril/triu ! subroutine psb_z_coo_tril(a,l,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,u) diff --git a/base/serial/impl/psb_z_csr_impl.F90 b/base/serial/impl/psb_z_csr_impl.F90 index 4c976e14e..9322105e9 100644 --- a/base/serial/impl/psb_z_csr_impl.F90 +++ b/base/serial/impl/psb_z_csr_impl.F90 @@ -2289,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) @@ -2359,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) @@ -2443,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) @@ -2511,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) From 08c1ab0cd1189ca65c8607b880e67b96160b2de7 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Mon, 21 Aug 2023 16:32:55 +0200 Subject: [PATCH 40/63] Fix tril/triu in COO for non-OMP paths. --- base/serial/impl/psb_c_coo_impl.F90 | 59 ++++++++++++++--------------- base/serial/impl/psb_d_coo_impl.F90 | 59 ++++++++++++++--------------- base/serial/impl/psb_s_coo_impl.F90 | 59 ++++++++++++++--------------- base/serial/impl/psb_z_coo_impl.F90 | 59 ++++++++++++++--------------- 4 files changed, 116 insertions(+), 120 deletions(-) diff --git a/base/serial/impl/psb_c_coo_impl.F90 b/base/serial/impl/psb_c_coo_impl.F90 index b800ce22d..6cc5fd3aa 100644 --- a/base/serial/impl/psb_c_coo_impl.F90 +++ b/base/serial/impl/psb_c_coo_impl.F90 @@ -4013,25 +4013,24 @@ subroutine psb_c_coo_triu(a,u,info,& 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, irp=>a%irp) - do i=imin_,imax_ - do k=irp(i),irp(i+1)-1 - j = ja(k) - if ((jmin_<=j).and.(j<=jmax_)) then - if ((ja(k)-i)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, irp=>a%irp) - do i=imin_,imax_ - do k=irp(i),irp(i+1)-1 - if ((jmin_<=j).and.(j<=jmax_)) then - if ((ja(k)-i)>=diag_) then - nzin = nzin + 1 - u%ia(nzin) = i - u%ja(nzin) = ja(k) - u%val(nzin) = val(k) - end if + 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 + u%ia(nzin) = i + u%ja(nzin) = ja(k) + u%val(nzin) = val(k) end if - end do - end do + end if + end do loop2 end associate call u%set_nzeros(nzin) end if diff --git a/base/serial/impl/psb_d_coo_impl.F90 b/base/serial/impl/psb_d_coo_impl.F90 index 5452ab2b7..9f9f43565 100644 --- a/base/serial/impl/psb_d_coo_impl.F90 +++ b/base/serial/impl/psb_d_coo_impl.F90 @@ -4013,25 +4013,24 @@ subroutine psb_d_coo_triu(a,u,info,& 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, irp=>a%irp) - do i=imin_,imax_ - do k=irp(i),irp(i+1)-1 - j = ja(k) - if ((jmin_<=j).and.(j<=jmax_)) then - if ((ja(k)-i)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, irp=>a%irp) - do i=imin_,imax_ - do k=irp(i),irp(i+1)-1 - if ((jmin_<=j).and.(j<=jmax_)) then - if ((ja(k)-i)>=diag_) then - nzin = nzin + 1 - u%ia(nzin) = i - u%ja(nzin) = ja(k) - u%val(nzin) = val(k) - end if + 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 + u%ia(nzin) = i + u%ja(nzin) = ja(k) + u%val(nzin) = val(k) end if - end do - end do + end if + end do loop2 end associate call u%set_nzeros(nzin) end if diff --git a/base/serial/impl/psb_s_coo_impl.F90 b/base/serial/impl/psb_s_coo_impl.F90 index cfc4a2f9d..83285cdf0 100644 --- a/base/serial/impl/psb_s_coo_impl.F90 +++ b/base/serial/impl/psb_s_coo_impl.F90 @@ -4013,25 +4013,24 @@ subroutine psb_s_coo_triu(a,u,info,& 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, irp=>a%irp) - do i=imin_,imax_ - do k=irp(i),irp(i+1)-1 - j = ja(k) - if ((jmin_<=j).and.(j<=jmax_)) then - if ((ja(k)-i)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, irp=>a%irp) - do i=imin_,imax_ - do k=irp(i),irp(i+1)-1 - if ((jmin_<=j).and.(j<=jmax_)) then - if ((ja(k)-i)>=diag_) then - nzin = nzin + 1 - u%ia(nzin) = i - u%ja(nzin) = ja(k) - u%val(nzin) = val(k) - end if + 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 + u%ia(nzin) = i + u%ja(nzin) = ja(k) + u%val(nzin) = val(k) end if - end do - end do + end if + end do loop2 end associate call u%set_nzeros(nzin) end if diff --git a/base/serial/impl/psb_z_coo_impl.F90 b/base/serial/impl/psb_z_coo_impl.F90 index fb4aa48e3..3d9562ef8 100644 --- a/base/serial/impl/psb_z_coo_impl.F90 +++ b/base/serial/impl/psb_z_coo_impl.F90 @@ -4013,25 +4013,24 @@ subroutine psb_z_coo_triu(a,u,info,& 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, irp=>a%irp) - do i=imin_,imax_ - do k=irp(i),irp(i+1)-1 - j = ja(k) - if ((jmin_<=j).and.(j<=jmax_)) then - if ((ja(k)-i)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, irp=>a%irp) - do i=imin_,imax_ - do k=irp(i),irp(i+1)-1 - if ((jmin_<=j).and.(j<=jmax_)) then - if ((ja(k)-i)>=diag_) then - nzin = nzin + 1 - u%ia(nzin) = i - u%ja(nzin) = ja(k) - u%val(nzin) = val(k) - end if + 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 + u%ia(nzin) = i + u%ja(nzin) = ja(k) + u%val(nzin) = val(k) end if - end do - end do + end if + end do loop2 end associate call u%set_nzeros(nzin) end if From 3aa748b0e3780f691ee4a58dd1746cc18a0a6ab7 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Mon, 21 Aug 2023 17:22:16 +0200 Subject: [PATCH 41/63] Finish dual OMP/notOMP g2lv1_ins --- base/modules/desc/psb_hash_map_mod.F90 | 721 ++++++++++++------------- 1 file changed, 355 insertions(+), 366 deletions(-) diff --git a/base/modules/desc/psb_hash_map_mod.F90 b/base/modules/desc/psb_hash_map_mod.F90 index b7f53879c..058dbb8d5 100644 --- a/base/modules/desc/psb_hash_map_mod.F90 +++ b/base/modules/desc/psb_hash_map_mod.F90 @@ -652,7 +652,7 @@ contains integer(psb_ipk_) :: me, np character(len=20) :: name,ch_err logical, allocatable :: mask_(:) - logical :: use_openmp = .true. +!!$ logical :: use_openmp = .true. #ifdef OPENMP integer(kind = OMP_lock_kind) :: ins_lck #endif @@ -683,119 +683,32 @@ contains mglob = idxmap%get_gr() nrow = idxmap%get_lr() !write(0,*) me,name,' before loop ',psb_errstatus_fatal() - if (use_openmp) then #ifdef OPENMP - !call OMP_init_lock(ins_lck) + !call OMP_init_lock(ins_lck) - if (idxmap%is_bld()) then + 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 - !$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) - - ! 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() - 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 - ! Index not found - 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 1' - 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) - end if - end if - else - idx(i) = -1 - end if - !call OMP_unset_lock(ins_lck) - end if - else - idx(i) = lip - end if - else - idx(i) = -1 - end if - - end do - ! $ OMP END PARALLEL DO - !$omp end critical(hash_g2l_ins) + isLoopValid = .true. + ncol = idxmap%get_lc() + if (present(mask)) then + mask_ = mask + else + allocate(mask_(size(idx))) + mask_ = .true. + end if - if (.not. isLoopValid) then - goto 9999 - end if - else - !$omp critical(hash_g2l_ins) + if (present(lidx)) then + if (present(mask)) then + !$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 + ! $ 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 @@ -812,6 +725,7 @@ contains & 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). @@ -823,9 +737,11 @@ contains 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 ! 'nxt' is not equal to 'tlip' when the key is already inside ! the hash map. In that case 'tlip' is the value corresponding @@ -838,7 +754,7 @@ contains & pad=-1_psb_lpk_,addsz=laddsz) if (info /= psb_success_) then - !write(0,*) 'Error spot 2' + !write(0,*) 'Error spot 1' call psb_errpush(psb_err_from_subroutine_ai_,name,& &a_err='psb_ensure_size',i_err=(/info/)) @@ -858,160 +774,160 @@ contains else idx(i) = lip end if - - end do - ! $ OMP END PARALLEL DO - !$omp end critical(hash_g2l_ins) - - if (.not. isLoopValid) then - goto 9999 + else + idx(i) = -1 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(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) + else + !$omp critical(hash_g2l_ins) - ! 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 - !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, 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) - !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) - 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 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/)) - - isLoopValid = .false. - idx(i) = -1 - else - idx(i) = lip - idxmap%loc_to_glob(nxt) = ip - call idxmap%set_lc(ncol) - end if - end if - else + ! $ 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() + 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) end if - !call OMP_unset_lock(ins_lck) end if else - idx(i) = lip + idx(i) = -1 end if - else - idx(i) = -1 + !call OMP_unset_lock(ins_lck) end if - - end do - ! $ OMP END PARALLEL DO - !$omp end critical(hash_g2l_ins) - - if (.not. isLoopValid) then - goto 9999 + else + idx(i) = lip 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 + + end do + ! $ OMP END PARALLEL DO + !$omp end critical(hash_g2l_ins) + + if (.not. isLoopValid) then + goto 9999 + end if + 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) + !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. + !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 !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). + ! is often already existing, so this lock is relatively rare). ncol = idxmap%get_lc() - nxt = ncol + 1 + 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) - + !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) + 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 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 4' + !write(0,*) 'Error spot 3', info call psb_errpush(psb_err_from_subroutine_ai_,name,& &a_err='psb_ensure_size',i_err=(/info/)) @@ -1028,116 +944,145 @@ contains end if !call OMP_unset_lock(ins_lck) end if - else idx(i) = lip end if - - end do - ! $ OMP END PARALLEL DO - !$omp end critical(hash_g2l_ins) - - if (.not. isLoopValid) then - goto 9999 + else + idx(i) = -1 end if - end if - end if - else - ! Wrong state - idx = -1 - info = -1 - end if - !call OMP_destroy_lock(ins_lck) -#endif - else if (.not.use_openmp) then -#ifdef OPENMP - ! $ omp parallel - ! $ omp critical - !write(0,*) 'In cnv: ',omp_get_num_threads() -#endif - isLoopValid = .true. - if (idxmap%is_bld()) then + end do + ! $ OMP END PARALLEL DO + !$omp end critical(hash_g2l_ins) - if (present(lidx)) then - if (present(mask)) then - do i = 1, is + 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() - 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 - !write(0,*) 'Error spot' - call psb_errpush(psb_err_from_subroutine_ai_,name,& - &a_err='psb_ensure_size',i_err=(/info/)) - isLoopValid = .false. - end if - idxmap%loc_to_glob(nxt) = ip + 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 + ! '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 4' + 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/)) - isLoopValid = .false. + 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 if (.not.present(mask)) then + else + idx(i) = lip + end if - do i = 1, is - ncol = idxmap%get_lc() - 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 + 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) - lip = tlip - if (info >=0) then - if (nxt == lip) then - ncol = max(nxt,ncol) + 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' + !write(0,*) 'Error spot' call psb_errpush(psb_err_from_subroutine_ai_,name,& &a_err='psb_ensure_size',i_err=(/info/)) - isLoopValid = .false. + isLoopValid = .false. end if idxmap%loc_to_glob(nxt) = ip call idxmap%set_lc(ncol) @@ -1151,66 +1096,71 @@ contains end if idx(i) = lip info = psb_success_ - enddo + else + idx(i) = -1 + end if + enddo - end if + else if (.not.present(mask)) then - else if (.not.present(lidx)) then + do i = 1, is + ncol = idxmap%get_lc() + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle + endif + call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& + & idxmap%glb_lc,ncol) + if (lip < 0) then + nxt = lidx(i) + if (nxt <= nrow) then + idx(i) = -1 + cycle + endif + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + lip = tlip - if (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 + 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. + end if + idxmap%loc_to_glob(nxt) = ip + call idxmap%set_lc(ncol) endif - 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 - 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 5' - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & 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 - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='SearchInsKeyVal',i_err=(/info/)) - isLoopValid = .false. - end if - idx(i) = lip info = psb_success_ else - idx(i) = -1 + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='SearchInsKeyVal',i_err=(/info/)) + isLoopValid = .false. end if - enddo - else if (.not.present(mask)) then + end if + idx(i) = lip + info = psb_success_ + enddo - do i = 1, is - ncol = idxmap%get_lc() - ip = idx(i) + end if + + else if (.not.present(lidx)) then + + 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 @@ -1225,41 +1175,80 @@ contains & pad=-1_psb_lpk_,addsz=laddsz) if (info /= psb_success_) then info=1 - write(0,*) 'Error spot 6' - 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/)) + & 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/)) - isLoopValid = .false. + & a_err='SearchInsKeyVal',i_err=(/info/)) + isLoopValid = .false. end if idx(i) = lip info = psb_success_ - enddo + else + idx(i) = -1 + end if + enddo + else if (.not.present(mask)) then + + do i = 1, is + ncol = idxmap%get_lc() + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle + endif + nxt = ncol + 1 + call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& + & idxmap%glb_lc,ncol) + if (lip < 0) then + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + lip = tlip + end if + + if (info >=0) then + if (nxt == lip) then + ncol = nxt + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& + & pad=-1_psb_lpk_,addsz=laddsz) + if (info /= psb_success_) then + info=1 + 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 -#ifdef OPENMP - ! $ omp end critical - ! $ omp end parallel - -#endif - if (.not. isLoopValid) goto 9999 + 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 From 26bf4c5d699aec0a94f59e4b9231ffa170bce3fe Mon Sep 17 00:00:00 2001 From: sfilippone Date: Mon, 21 Aug 2023 17:26:37 +0200 Subject: [PATCH 42/63] Fixed COO csput for OMP/not OMP --- base/serial/impl/psb_c_coo_impl.F90 | 14 +++++--------- base/serial/impl/psb_d_coo_impl.F90 | 14 +++++--------- base/serial/impl/psb_s_coo_impl.F90 | 14 +++++--------- base/serial/impl/psb_z_coo_impl.F90 | 14 +++++--------- 4 files changed, 20 insertions(+), 36 deletions(-) diff --git a/base/serial/impl/psb_c_coo_impl.F90 b/base/serial/impl/psb_c_coo_impl.F90 index 6cc5fd3aa..3e75820fc 100644 --- a/base/serial/impl/psb_c_coo_impl.F90 +++ b/base/serial/impl/psb_c_coo_impl.F90 @@ -2875,18 +2875,14 @@ 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) - else - nzaold = nza - nza = nza + nz - call a%set_nzeros(nza) -#if defined(OPENMP) - !write(0,*) 'From thread ',omp_get_thread_num(),nzaold,nz,nza,a%get_nzeros() -#endif end if !$omp end critical if (info /= 0) goto 9999 - call psb_inner_ins(nz,ia,ja,val,nzaold,a%ia,a%ja,a%val,isza,& + call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& & imin,imax,jmin,jmax,info) + + !write(0,*) 'From CSPUT :',nza,nzaold + call a%set_nzeros(nza) call a%set_sorted(.false.) else if (a%is_upd()) then @@ -2961,7 +2957,7 @@ contains end do !$OMP END PARALLEL DO - !nza = nza + nz + nza = nza + nz #else do i=1, nz ir = ia(i) diff --git a/base/serial/impl/psb_d_coo_impl.F90 b/base/serial/impl/psb_d_coo_impl.F90 index 9f9f43565..86d93ed6b 100644 --- a/base/serial/impl/psb_d_coo_impl.F90 +++ b/base/serial/impl/psb_d_coo_impl.F90 @@ -2875,18 +2875,14 @@ 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) - else - nzaold = nza - nza = nza + nz - call a%set_nzeros(nza) -#if defined(OPENMP) - !write(0,*) 'From thread ',omp_get_thread_num(),nzaold,nz,nza,a%get_nzeros() -#endif end if !$omp end critical if (info /= 0) goto 9999 - call psb_inner_ins(nz,ia,ja,val,nzaold,a%ia,a%ja,a%val,isza,& + call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& & imin,imax,jmin,jmax,info) + + !write(0,*) 'From CSPUT :',nza,nzaold + call a%set_nzeros(nza) call a%set_sorted(.false.) else if (a%is_upd()) then @@ -2961,7 +2957,7 @@ contains end do !$OMP END PARALLEL DO - !nza = nza + nz + nza = nza + nz #else do i=1, nz ir = ia(i) diff --git a/base/serial/impl/psb_s_coo_impl.F90 b/base/serial/impl/psb_s_coo_impl.F90 index 83285cdf0..8791f8972 100644 --- a/base/serial/impl/psb_s_coo_impl.F90 +++ b/base/serial/impl/psb_s_coo_impl.F90 @@ -2875,18 +2875,14 @@ 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) - else - nzaold = nza - nza = nza + nz - call a%set_nzeros(nza) -#if defined(OPENMP) - !write(0,*) 'From thread ',omp_get_thread_num(),nzaold,nz,nza,a%get_nzeros() -#endif end if !$omp end critical if (info /= 0) goto 9999 - call psb_inner_ins(nz,ia,ja,val,nzaold,a%ia,a%ja,a%val,isza,& + call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& & imin,imax,jmin,jmax,info) + + !write(0,*) 'From CSPUT :',nza,nzaold + call a%set_nzeros(nza) call a%set_sorted(.false.) else if (a%is_upd()) then @@ -2961,7 +2957,7 @@ contains end do !$OMP END PARALLEL DO - !nza = nza + nz + nza = nza + nz #else do i=1, nz ir = ia(i) diff --git a/base/serial/impl/psb_z_coo_impl.F90 b/base/serial/impl/psb_z_coo_impl.F90 index 3d9562ef8..952b97517 100644 --- a/base/serial/impl/psb_z_coo_impl.F90 +++ b/base/serial/impl/psb_z_coo_impl.F90 @@ -2875,18 +2875,14 @@ 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) - else - nzaold = nza - nza = nza + nz - call a%set_nzeros(nza) -#if defined(OPENMP) - !write(0,*) 'From thread ',omp_get_thread_num(),nzaold,nz,nza,a%get_nzeros() -#endif end if !$omp end critical if (info /= 0) goto 9999 - call psb_inner_ins(nz,ia,ja,val,nzaold,a%ia,a%ja,a%val,isza,& + call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& & imin,imax,jmin,jmax,info) + + !write(0,*) 'From CSPUT :',nza,nzaold + call a%set_nzeros(nza) call a%set_sorted(.false.) else if (a%is_upd()) then @@ -2961,7 +2957,7 @@ contains end do !$OMP END PARALLEL DO - !nza = nza + nz + nza = nza + nz #else do i=1, nz ir = ia(i) From f001ebbad39ac46f9258bf674704bd2b2858fefa Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 22 Aug 2023 10:22:46 +0200 Subject: [PATCH 43/63] Final fix for COO on OMP --- base/serial/impl/psb_c_coo_impl.F90 | 14 ++++++++------ base/serial/impl/psb_d_coo_impl.F90 | 14 ++++++++------ base/serial/impl/psb_s_coo_impl.F90 | 14 ++++++++------ base/serial/impl/psb_z_coo_impl.F90 | 14 ++++++++------ 4 files changed, 32 insertions(+), 24 deletions(-) diff --git a/base/serial/impl/psb_c_coo_impl.F90 b/base/serial/impl/psb_c_coo_impl.F90 index 3e75820fc..46391deee 100644 --- a/base/serial/impl/psb_c_coo_impl.F90 +++ b/base/serial/impl/psb_c_coo_impl.F90 @@ -2864,7 +2864,9 @@ subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) if (nz == 0) return 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() @@ -2875,14 +2877,15 @@ 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) + else + nzaold = nza + nza = nza + nz + call a%set_nzeros(nza) end if !$omp end critical if (info /= 0) goto 9999 - call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& + call psb_inner_ins(nz,ia,ja,val,nzaold,a%ia,a%ja,a%val,isza,& & imin,imax,jmin,jmax,info) - - !write(0,*) 'From CSPUT :',nza,nzaold - call a%set_nzeros(nza) call a%set_sorted(.false.) else if (a%is_upd()) then @@ -2956,7 +2959,6 @@ contains end if end do !$OMP END PARALLEL DO - nza = nza + nz #else do i=1, nz diff --git a/base/serial/impl/psb_d_coo_impl.F90 b/base/serial/impl/psb_d_coo_impl.F90 index 86d93ed6b..c2babf8e0 100644 --- a/base/serial/impl/psb_d_coo_impl.F90 +++ b/base/serial/impl/psb_d_coo_impl.F90 @@ -2864,7 +2864,9 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) if (nz == 0) return 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() @@ -2875,14 +2877,15 @@ 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) + else + nzaold = nza + nza = nza + nz + call a%set_nzeros(nza) end if !$omp end critical if (info /= 0) goto 9999 - call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& + call psb_inner_ins(nz,ia,ja,val,nzaold,a%ia,a%ja,a%val,isza,& & imin,imax,jmin,jmax,info) - - !write(0,*) 'From CSPUT :',nza,nzaold - call a%set_nzeros(nza) call a%set_sorted(.false.) else if (a%is_upd()) then @@ -2956,7 +2959,6 @@ contains end if end do !$OMP END PARALLEL DO - nza = nza + nz #else do i=1, nz diff --git a/base/serial/impl/psb_s_coo_impl.F90 b/base/serial/impl/psb_s_coo_impl.F90 index 8791f8972..402c608a6 100644 --- a/base/serial/impl/psb_s_coo_impl.F90 +++ b/base/serial/impl/psb_s_coo_impl.F90 @@ -2864,7 +2864,9 @@ subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) if (nz == 0) return 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() @@ -2875,14 +2877,15 @@ 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) + else + nzaold = nza + nza = nza + nz + call a%set_nzeros(nza) end if !$omp end critical if (info /= 0) goto 9999 - call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& + call psb_inner_ins(nz,ia,ja,val,nzaold,a%ia,a%ja,a%val,isza,& & imin,imax,jmin,jmax,info) - - !write(0,*) 'From CSPUT :',nza,nzaold - call a%set_nzeros(nza) call a%set_sorted(.false.) else if (a%is_upd()) then @@ -2956,7 +2959,6 @@ contains end if end do !$OMP END PARALLEL DO - nza = nza + nz #else do i=1, nz diff --git a/base/serial/impl/psb_z_coo_impl.F90 b/base/serial/impl/psb_z_coo_impl.F90 index 952b97517..542f842e0 100644 --- a/base/serial/impl/psb_z_coo_impl.F90 +++ b/base/serial/impl/psb_z_coo_impl.F90 @@ -2864,7 +2864,9 @@ subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) if (nz == 0) return 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() @@ -2875,14 +2877,15 @@ 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) + else + nzaold = nza + nza = nza + nz + call a%set_nzeros(nza) end if !$omp end critical if (info /= 0) goto 9999 - call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& + call psb_inner_ins(nz,ia,ja,val,nzaold,a%ia,a%ja,a%val,isza,& & imin,imax,jmin,jmax,info) - - !write(0,*) 'From CSPUT :',nza,nzaold - call a%set_nzeros(nza) call a%set_sorted(.false.) else if (a%is_upd()) then @@ -2956,7 +2959,6 @@ contains end if end do !$OMP END PARALLEL DO - nza = nza + nz #else do i=1, nz From f4f37924e239a97e8722e93e61e3124fac3d9719 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Thu, 24 Aug 2023 09:15:25 +0200 Subject: [PATCH 44/63] Update contributor list --- README.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/README.md b/README.md index d2f19f95e..86bb2805a 100644 --- a/README.md +++ b/README.md @@ -121,6 +121,8 @@ Salvatore Filippone Contributors (roughly reverse cronological order): +Andea Di Iorio +Stefano Petrilli Soren Rasmussen Zaak Beekman Ambra Abdullahi Hassan From 1af76c067c8cd65f3a77d33459d0e1fc11c59c26 Mon Sep 17 00:00:00 2001 From: wlthr Date: Sat, 26 Aug 2023 10:53:00 +0200 Subject: [PATCH 45/63] added parallel double precision spspmm implementations --- base/modules/Makefile | 6 +- base/modules/serial/psb_d_csr_mat_mod.f90 | 8 + base/modules/serial/psb_d_mat_mod.F90 | 5 +- base/modules/serial/psb_d_rb_idx_tree_mod.f90 | 91 ++++ base/modules/serial/psb_rb_idx_tree_mod.f90 | 5 + base/serial/impl/Makefile | 2 +- base/serial/impl/psb_d_csr_impl.F90 | 424 +++++++++++++++++- base/serial/impl/psb_d_rb_idx_tree_impl.F90 | 284 ++++++++++++ util/Makefile | 2 +- 9 files changed, 815 insertions(+), 12 deletions(-) create mode 100644 base/modules/serial/psb_d_rb_idx_tree_mod.f90 create mode 100644 base/modules/serial/psb_rb_idx_tree_mod.f90 create mode 100644 base/serial/impl/psb_d_rb_idx_tree_impl.F90 diff --git a/base/modules/Makefile b/base/modules/Makefile index 399add1f0..d14a24eec 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -64,7 +64,8 @@ SERIAL_MODS=serial/psb_s_serial_mod.o serial/psb_d_serial_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_d_rb_idx_tree_mod.o serial/psb_rb_idx_tree_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 #\ @@ -270,6 +271,9 @@ 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 +serial/psb_d_rb_idx_tree_mod.o: serial/psb_d_csr_mat_mod.o +serial/psb_rb_idx_tree_mod.o: serial/psb_d_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/serial/psb_d_csr_mat_mod.f90 b/base/modules/serial/psb_d_csr_mat_mod.f90 index d0aa622bb..74cf8fff9 100644 --- a/base/modules/serial/psb_d_csr_mat_mod.f90 +++ b/base/modules/serial/psb_d_csr_mat_mod.f90 @@ -46,6 +46,14 @@ module psb_d_csr_mat_mod use psb_d_base_mat_mod + 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 + integer(psb_ipk_) :: spspmm_impl = spspmm_serial + !> \namespace psb_base_mod \class psb_d_csr_sparse_mat !! \extends psb_d_base_mat_mod::psb_d_base_sparse_mat !! diff --git a/base/modules/serial/psb_d_mat_mod.F90 b/base/modules/serial/psb_d_mat_mod.F90 index 8f967ce1b..9e613b29e 100644 --- a/base/modules/serial/psb_d_mat_mod.F90 +++ b/base/modules/serial/psb_d_mat_mod.F90 @@ -79,7 +79,10 @@ module psb_d_mat_mod use psb_d_base_mat_mod - use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat, psb_ld_csr_sparse_mat + use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat, psb_ld_csr_sparse_mat, & + spspmm_impl, spspmm_serial, spspmm_omp_gustavson, & + spspmm_omp_gustavson_1d, spspmm_serial_rb_tree, & + spspmm_omp_rb_tree, spspmm_omp_two_pass use psb_d_csc_mat_mod, only : psb_d_csc_sparse_mat, psb_ld_csc_sparse_mat type :: psb_dspmat_type diff --git a/base/modules/serial/psb_d_rb_idx_tree_mod.f90 b/base/modules/serial/psb_d_rb_idx_tree_mod.f90 new file mode 100644 index 000000000..afdd831de --- /dev/null +++ b/base/modules/serial/psb_d_rb_idx_tree_mod.f90 @@ -0,0 +1,91 @@ +! 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 +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 \ No newline at end of file diff --git a/base/modules/serial/psb_rb_idx_tree_mod.f90 b/base/modules/serial/psb_rb_idx_tree_mod.f90 new file mode 100644 index 000000000..e93554f10 --- /dev/null +++ b/base/modules/serial/psb_rb_idx_tree_mod.f90 @@ -0,0 +1,5 @@ +module psb_rb_idx_tree_mod + use psb_const_mod + + use psb_d_rb_idx_tree_mod +end module psb_rb_idx_tree_mod \ No newline at end of file diff --git a/base/serial/impl/Makefile b/base/serial/impl/Makefile index 000887418..ddcdaf96a 100644 --- a/base/serial/impl/Makefile +++ b/base/serial/impl/Makefile @@ -10,7 +10,7 @@ BOBJS=psb_base_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_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 diff --git a/base/serial/impl/psb_d_csr_impl.F90 b/base/serial/impl/psb_d_csr_impl.F90 index 10518a2d0..1e39b892a 100644 --- a/base/serial/impl/psb_d_csr_impl.F90 +++ b/base/serial/impl/psb_d_csr_impl.F90 @@ -3349,13 +3349,30 @@ subroutine psb_dcsrspspmm(a,b,c,info) goto 9999 endif - ! 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) + 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() @@ -3434,9 +3451,400 @@ contains 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 - end subroutine csr_spspmm + 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(start_idx) + nnz) = vals(1:nnz) + c%ja(c%irp(start_idx):c%irp(start_idx) + nnz) = 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(start_idx) + nnz) = vals(1:nnz) + c%ja(c%irp(start_idx):c%irp(start_idx) + nnz) = 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 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..8495a8134 --- /dev/null +++ b/base/serial/impl/psb_d_rb_idx_tree_impl.F90 @@ -0,0 +1,284 @@ +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_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 \ No newline at end of file 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 \ From 0fe95c3c76881ecd03b1e2170fd1799492115e0d Mon Sep 17 00:00:00 2001 From: wlthr Date: Mon, 28 Aug 2023 10:37:41 +0200 Subject: [PATCH 46/63] added use statement --- base/modules/Makefile | 2 +- base/serial/impl/psb_d_rb_idx_tree_impl.F90 | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/base/modules/Makefile b/base/modules/Makefile index d14a24eec..0d90b9f16 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -271,7 +271,7 @@ 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 -serial/psb_d_rb_idx_tree_mod.o: serial/psb_d_csr_mat_mod.o +serial/psb_d_rb_idx_tree_mod.o: serial/psb_d_csr_mat_mod.o psb_realloc_mod.o serial/psb_rb_idx_tree_mod.o: serial/psb_d_rb_idx_tree_mod.o error.o psb_realloc_mod.o: psb_error_mod.o diff --git a/base/serial/impl/psb_d_rb_idx_tree_impl.F90 b/base/serial/impl/psb_d_rb_idx_tree_impl.F90 index 8495a8134..a6bdc86f2 100644 --- a/base/serial/impl/psb_d_rb_idx_tree_impl.F90 +++ b/base/serial/impl/psb_d_rb_idx_tree_impl.F90 @@ -226,6 +226,7 @@ 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 From 0185b79b2a0d1decba51d6b75c38c397b7c516cd Mon Sep 17 00:00:00 2001 From: wlthr Date: Mon, 28 Aug 2023 11:04:00 +0200 Subject: [PATCH 47/63] added setter for d_csr_spspmm implementation --- base/modules/serial/psb_d_csr_mat_mod.f90 | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/base/modules/serial/psb_d_csr_mat_mod.f90 b/base/modules/serial/psb_d_csr_mat_mod.f90 index 74cf8fff9..cabedb363 100644 --- a/base/modules/serial/psb_d_csr_mat_mod.f90 +++ b/base/modules/serial/psb_d_csr_mat_mod.f90 @@ -1301,4 +1301,15 @@ contains end subroutine ld_csr_free + subroutine set_d_csr_spspmm_impl(impl_id) + integer(psb_ipk_), intent(in) :: impl_id + + if (impl_id < 0 .or. impl_id > 5) then + write (*,*) "Invalid implementation id, impl id set to serial" + spspmm_impl = spspmm_serial + else + spspmm_impl = impl_id + end if + end subroutine + end module psb_d_csr_mat_mod From 2322a9ce6188915d3ffa9377b5c08a8151e42b06 Mon Sep 17 00:00:00 2001 From: wlthr Date: Mon, 28 Aug 2023 11:06:30 +0200 Subject: [PATCH 48/63] using end_idx to copy data from threads in gustavson and gustavson_1d --- base/serial/impl/psb_d_csr_impl.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/base/serial/impl/psb_d_csr_impl.F90 b/base/serial/impl/psb_d_csr_impl.F90 index 880bebf8a..16f5e26e5 100644 --- a/base/serial/impl/psb_d_csr_impl.F90 +++ b/base/serial/impl/psb_d_csr_impl.F90 @@ -3892,8 +3892,8 @@ contains call psb_realloc(c%irp(ma + 1), c%ja, info) !$omp end single - c%val(c%irp(start_idx):c%irp(start_idx) + nnz) = vals(1:nnz) - c%ja(c%irp(start_idx):c%irp(start_idx) + nnz) = col_inds(1:nnz) + 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 @@ -4011,8 +4011,8 @@ contains call psb_realloc(c%irp(ma + 1), c%ja, info) !$omp end single - c%val(c%irp(start_idx):c%irp(start_idx) + nnz) = vals(1:nnz) - c%ja(c%irp(start_idx):c%irp(start_idx) + nnz) = col_inds(1:nnz) + 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 From 7b45994b70a67f31f4569cb0e751fc0c4b65288d Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 29 Aug 2023 05:07:55 -0400 Subject: [PATCH 49/63] Setter/getter for SPSPMM algorithm in base_mat_mod --- base/modules/serial/psb_base_mat_mod.F90 | 28 +++++++++++++++++++++++ base/modules/serial/psb_d_csr_mat_mod.f90 | 24 ++----------------- 2 files changed, 30 insertions(+), 22 deletions(-) diff --git a/base/modules/serial/psb_base_mat_mod.F90 b/base/modules/serial/psb_base_mat_mod.F90 index af4e4c6f1..07bfbd504 100644 --- a/base/modules/serial/psb_base_mat_mod.F90 +++ b/base/modules/serial/psb_base_mat_mod.F90 @@ -73,6 +73,16 @@ 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 + integer(psb_ipk_), save :: spspmm_impl = spspmm_serial + + ! !> \namespace psb_base_mod \class psb_base_sparse_mat !! The basic data about your matrix. @@ -1904,4 +1914,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_d_csr_mat_mod.f90 b/base/modules/serial/psb_d_csr_mat_mod.f90 index cabedb363..21036d5f1 100644 --- a/base/modules/serial/psb_d_csr_mat_mod.f90 +++ b/base/modules/serial/psb_d_csr_mat_mod.f90 @@ -45,15 +45,6 @@ module psb_d_csr_mat_mod use psb_d_base_mat_mod - - 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 - integer(psb_ipk_) :: spspmm_impl = spspmm_serial - !> \namespace psb_base_mod \class psb_d_csr_sparse_mat !! \extends psb_d_base_mat_mod::psb_d_base_sparse_mat !! @@ -586,8 +577,8 @@ module psb_d_csr_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_d_csr_scals end interface - - !> \namespace psb_base_mod \class psb_ld_csr_sparse_mat + + !> \namespace psb_base_mod \class psb_ld_csr_sparse_mat !! \extends psb_ld_base_mat_mod::psb_ld_base_sparse_mat !! !! psb_ld_csr_sparse_mat type and the related methods. @@ -1301,15 +1292,4 @@ contains end subroutine ld_csr_free - subroutine set_d_csr_spspmm_impl(impl_id) - integer(psb_ipk_), intent(in) :: impl_id - - if (impl_id < 0 .or. impl_id > 5) then - write (*,*) "Invalid implementation id, impl id set to serial" - spspmm_impl = spspmm_serial - else - spspmm_impl = impl_id - end if - end subroutine - end module psb_d_csr_mat_mod From d0cacda995a98e4b7d3e57ca404421d03d2cc192 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 29 Aug 2023 16:19:56 +0200 Subject: [PATCH 50/63] Moved various modules related to RB around, into auxil, update Makefile. --- README.md | 1 + base/modules/Makefile | 18 +- base/modules/auxil/psb_d_rb_idx_tree_mod.f90 | 128 +++++ base/modules/auxil/psb_rb_idx_tree_mod.f90 | 49 ++ base/modules/auxil/psb_sort_mod.f90 | 3 +- .../sort => modules/auxil}/psi_acx_mod.f90 | 0 .../sort => modules/auxil}/psi_alcx_mod.f90 | 0 .../sort => modules/auxil}/psi_lcx_mod.f90 | 0 base/modules/serial/psb_d_rb_idx_tree_mod.f90 | 91 ---- base/modules/serial/psb_rb_idx_tree_mod.f90 | 5 - base/serial/impl/psb_d_rb_idx_tree_impl.F90 | 504 ++++++++++-------- base/serial/sort/Makefile | 4 +- 12 files changed, 467 insertions(+), 336 deletions(-) create mode 100644 base/modules/auxil/psb_d_rb_idx_tree_mod.f90 create mode 100644 base/modules/auxil/psb_rb_idx_tree_mod.f90 rename base/{serial/sort => modules/auxil}/psi_acx_mod.f90 (100%) rename base/{serial/sort => modules/auxil}/psi_alcx_mod.f90 (100%) rename base/{serial/sort => modules/auxil}/psi_lcx_mod.f90 (100%) delete mode 100644 base/modules/serial/psb_d_rb_idx_tree_mod.f90 delete mode 100644 base/modules/serial/psb_rb_idx_tree_mod.f90 diff --git a/README.md b/README.md index 86bb2805a..a9813f5e3 100644 --- a/README.md +++ b/README.md @@ -121,6 +121,7 @@ Salvatore Filippone Contributors (roughly reverse cronological order): +Dimitri Walther Andea Di Iorio Stefano Petrilli Soren Rasmussen diff --git a/base/modules/Makefile b/base/modules/Makefile index 0d90b9f16..8fa63f920 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -60,12 +60,12 @@ 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_d_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_d_rb_idx_tree_mod.o serial/psb_rb_idx_tree_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 #\ @@ -166,6 +166,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 @@ -175,6 +176,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 \ @@ -193,7 +195,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 \ @@ -226,7 +229,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 \ @@ -271,8 +277,8 @@ 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 -serial/psb_d_rb_idx_tree_mod.o: serial/psb_d_csr_mat_mod.o psb_realloc_mod.o -serial/psb_rb_idx_tree_mod.o: serial/psb_d_rb_idx_tree_mod.o +auxil/psb_d_rb_idx_tree_mod.o: serial/psb_d_csr_mat_mod.o psb_realloc_mod.o +auxil/psb_rb_idx_tree_mod.o: auxil/psb_d_rb_idx_tree_mod.o error.o psb_realloc_mod.o: psb_error_mod.o psb_error_impl.o: psb_penv_mod.o 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_rb_idx_tree_mod.f90 b/base/modules/auxil/psb_rb_idx_tree_mod.f90 new file mode 100644 index 000000000..9d151389d --- /dev/null +++ b/base/modules/auxil/psb_rb_idx_tree_mod.f90 @@ -0,0 +1,49 @@ +! +! 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_d_rb_idx_tree_mod +end module psb_rb_idx_tree_mod 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/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/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/serial/psb_d_rb_idx_tree_mod.f90 b/base/modules/serial/psb_d_rb_idx_tree_mod.f90 deleted file mode 100644 index afdd831de..000000000 --- a/base/modules/serial/psb_d_rb_idx_tree_mod.f90 +++ /dev/null @@ -1,91 +0,0 @@ -! 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 -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 \ No newline at end of file diff --git a/base/modules/serial/psb_rb_idx_tree_mod.f90 b/base/modules/serial/psb_rb_idx_tree_mod.f90 deleted file mode 100644 index e93554f10..000000000 --- a/base/modules/serial/psb_rb_idx_tree_mod.f90 +++ /dev/null @@ -1,5 +0,0 @@ -module psb_rb_idx_tree_mod - use psb_const_mod - - use psb_d_rb_idx_tree_mod -end module psb_rb_idx_tree_mod \ No newline at end of file diff --git a/base/serial/impl/psb_d_rb_idx_tree_impl.F90 b/base/serial/impl/psb_d_rb_idx_tree_impl.F90 index a6bdc86f2..9b63d51cc 100644 --- a/base/serial/impl/psb_d_rb_idx_tree_impl.F90 +++ b/base/serial/impl/psb_d_rb_idx_tree_impl.F90 @@ -1,285 +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 + 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 => this%root + current => current%right + end if + end do - do while (associated(current)) - previous => current + if (idx < previous%idx) then + new_node%parent => previous + previous%left => new_node + else + new_node%parent => previous + previous%right => new_node + end if - if (idx == current%idx) then - current%val = current%val + val - deallocate(new_node) - return - else if (idx < current%idx) then - current => current%left - else + call psb_d_rb_idx_tree_fix_insertion(this, new_node) - current => current%right - end if - end do + this%nnz = this%nnz + 1 +end subroutine psb_d_rb_idx_tree_insert - if (idx < previous%idx) then - new_node%parent => previous - previous%left => new_node +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 - new_node%parent => previous - previous%right => new_node + uncle => grand_parent%left 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 + 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) -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 (this%root%idx == grand_parent%idx) this%root => current - 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 + return + end if + end do - this%root%is_red = .false. + 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 + 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' + 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 + 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 + 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' + 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 + if (.not. associated(node%left)) return - l => node%left - lr => l%right - node%left => lr + l => node%left + lr => l%right + node%left => lr - if (associated(lr)) lr%parent => node + 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 + 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%parent => node%parent + node%parent => l - l%right => node + 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 + 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' + 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 + if (.not. associated(node%right)) return - r => node%right - rl => r%left - node%right => rl + r => node%right + rl => r%left + node%right => rl - if (associated(rl)) rl%parent => node + 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 + 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%parent => node%parent + node%parent => r - r%left => node + 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 + 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 + 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 + 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) - nnz = mat%irp(rows + 1) - call psb_realloc(nnz, mat%val, info) - call psb_realloc(nnz, mat%ja, info) + 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) + !$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 + 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 + !$omp end parallel do #endif -end subroutine psb_d_rb_idx_tree_merge \ No newline at end of file +end subroutine psb_d_rb_idx_tree_merge 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 From 0d8a5d3dc2964d7f8e7490fde8021f15d8ae0a8c Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 29 Aug 2023 19:27:29 +0200 Subject: [PATCH 51/63] New SPSPMM implementation --- base/modules/Makefile | 11 +- base/modules/auxil/psb_c_rb_idx_tree_mod.f90 | 128 +++++ base/modules/auxil/psb_rb_idx_tree_mod.f90 | 9 +- base/modules/auxil/psb_s_rb_idx_tree_mod.f90 | 128 +++++ base/modules/auxil/psb_z_rb_idx_tree_mod.f90 | 128 +++++ base/modules/serial/psb_d_csr_mat_mod.f90 | 5 +- base/modules/serial/psb_d_mat_mod.F90 | 5 +- base/serial/impl/Makefile | 12 +- base/serial/impl/psb_c_csr_impl.F90 | 542 ++++++++++++++++++- base/serial/impl/psb_c_rb_idx_tree_impl.F90 | 329 +++++++++++ base/serial/impl/psb_d_csr_impl.F90 | 400 +++++++++----- base/serial/impl/psb_s_csr_impl.F90 | 542 ++++++++++++++++++- base/serial/impl/psb_s_rb_idx_tree_impl.F90 | 329 +++++++++++ base/serial/impl/psb_z_csr_impl.F90 | 542 ++++++++++++++++++- base/serial/impl/psb_z_rb_idx_tree_impl.F90 | 329 +++++++++++ 15 files changed, 3271 insertions(+), 168 deletions(-) create mode 100644 base/modules/auxil/psb_c_rb_idx_tree_mod.f90 create mode 100644 base/modules/auxil/psb_s_rb_idx_tree_mod.f90 create mode 100644 base/modules/auxil/psb_z_rb_idx_tree_mod.f90 create mode 100644 base/serial/impl/psb_c_rb_idx_tree_impl.F90 create mode 100644 base/serial/impl/psb_s_rb_idx_tree_impl.F90 create mode 100644 base/serial/impl/psb_z_rb_idx_tree_impl.F90 diff --git a/base/modules/Makefile b/base/modules/Makefile index 8fa63f920..f1cb5e534 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -60,7 +60,11 @@ 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_d_rb_idx_tree_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 \ + 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 \ @@ -277,8 +281,11 @@ 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_rb_idx_tree_mod.o: auxil/psb_d_rb_idx_tree_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 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_rb_idx_tree_mod.f90 b/base/modules/auxil/psb_rb_idx_tree_mod.f90 index 9d151389d..074255eaa 100644 --- a/base/modules/auxil/psb_rb_idx_tree_mod.f90 +++ b/base/modules/auxil/psb_rb_idx_tree_mod.f90 @@ -43,7 +43,10 @@ ! Contributed by Dimitri Walther ! module psb_rb_idx_tree_mod - use psb_const_mod - - use psb_d_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_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_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/serial/psb_d_csr_mat_mod.f90 b/base/modules/serial/psb_d_csr_mat_mod.f90 index 21036d5f1..d0aa622bb 100644 --- a/base/modules/serial/psb_d_csr_mat_mod.f90 +++ b/base/modules/serial/psb_d_csr_mat_mod.f90 @@ -45,6 +45,7 @@ module psb_d_csr_mat_mod use psb_d_base_mat_mod + !> \namespace psb_base_mod \class psb_d_csr_sparse_mat !! \extends psb_d_base_mat_mod::psb_d_base_sparse_mat !! @@ -577,8 +578,8 @@ module psb_d_csr_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_d_csr_scals end interface - - !> \namespace psb_base_mod \class psb_ld_csr_sparse_mat + + !> \namespace psb_base_mod \class psb_ld_csr_sparse_mat !! \extends psb_ld_base_mat_mod::psb_ld_base_sparse_mat !! !! psb_ld_csr_sparse_mat type and the related methods. diff --git a/base/modules/serial/psb_d_mat_mod.F90 b/base/modules/serial/psb_d_mat_mod.F90 index 9e613b29e..8f967ce1b 100644 --- a/base/modules/serial/psb_d_mat_mod.F90 +++ b/base/modules/serial/psb_d_mat_mod.F90 @@ -79,10 +79,7 @@ module psb_d_mat_mod use psb_d_base_mat_mod - use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat, psb_ld_csr_sparse_mat, & - spspmm_impl, spspmm_serial, spspmm_omp_gustavson, & - spspmm_omp_gustavson_1d, spspmm_serial_rb_tree, & - spspmm_omp_rb_tree, spspmm_omp_two_pass + use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat, psb_ld_csr_sparse_mat use psb_d_csc_mat_mod, only : psb_d_csc_sparse_mat, psb_ld_csc_sparse_mat type :: psb_dspmat_type diff --git a/base/serial/impl/Makefile b/base/serial/impl/Makefile index ddcdaf96a..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 psb_d_rb_idx_tree_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_csr_impl.F90 b/base/serial/impl/psb_c_csr_impl.F90 index 6c3ecec6e..3709ad21b 100644 --- a/base/serial/impl/psb_c_csr_impl.F90 +++ b/base/serial/impl/psb_c_csr_impl.F90 @@ -3213,10 +3213,10 @@ 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) @@ -3246,7 +3246,7 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) #endif call a%set_host() - + end subroutine psb_c_cp_csr_from_coo @@ -3495,7 +3495,7 @@ subroutine psb_c_cp_csr_to_fmt(a,b,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 + ! 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) @@ -3600,7 +3600,7 @@ subroutine psb_c_cp_csr_from_fmt(a,b,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 + ! 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) @@ -3654,6 +3654,7 @@ subroutine psb_c_csr_clean_zeros(a, info) call a%set_host() end subroutine psb_c_csr_clean_zeros +#if 0 subroutine psb_ccsrspspmm(a,b,c,info) use psb_c_mat_mod use psb_serial_mod, psb_protect_name => psb_ccsrspspmm @@ -3776,7 +3777,538 @@ contains end subroutine csr_spspmm 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 + + 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 +#endif ! ! 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_csr_impl.F90 b/base/serial/impl/psb_d_csr_impl.F90 index 16f5e26e5..b8f692fa2 100644 --- a/base/serial/impl/psb_d_csr_impl.F90 +++ b/base/serial/impl/psb_d_csr_impl.F90 @@ -3213,10 +3213,10 @@ 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) @@ -3246,7 +3246,7 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) #endif call a%set_host() - + end subroutine psb_d_cp_csr_from_coo @@ -3495,7 +3495,7 @@ subroutine psb_d_cp_csr_to_fmt(a,b,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 + ! 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) @@ -3600,7 +3600,7 @@ subroutine psb_d_cp_csr_from_fmt(a,b,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 + ! 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) @@ -3654,6 +3654,130 @@ subroutine psb_d_csr_clean_zeros(a, info) call a%set_host() end subroutine psb_d_csr_clean_zeros +#if 0 +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 + + ! 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) + + 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 + +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 @@ -3791,7 +3915,7 @@ contains end subroutine csr_spspmm ! gustavson's algorithm using perfect hashing - ! and OpenMP parallelisation + ! and OpenMP parallelisation subroutine spmm_omp_gustavson(a,b,c,info) use omp_lib @@ -3799,12 +3923,12 @@ contains 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() @@ -3814,7 +3938,7 @@ contains ! 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) @@ -3822,66 +3946,66 @@ contains 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 + 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 + 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 - c%irp(irw + 1) = rwnz + 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) + 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 + 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) + c%irp(irw + 1) = c%irp(irw + 1) + c%irp(irw) end do !$omp barrier @@ -3891,7 +4015,7 @@ contains 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 @@ -3904,13 +4028,13 @@ contains 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 + start_idx, end_idx , blk, blk_size, rwstart,& + rwblk, rwblkrem, nblks ma = a%get_nrows() nb = b%get_ncols() @@ -3931,76 +4055,76 @@ contains 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 + 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 + 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 - do irw = rwstart, rwstart + blk_size - 1 - if (start_idx == 0) then - start_idx = irw + 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 - 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 + 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) + 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 + 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) + c%irp(irw + 1) = c%irp(irw + 1) + c%irp(irw) end do !$omp barrier @@ -4010,7 +4134,7 @@ contains 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 @@ -4034,20 +4158,20 @@ contains 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 + 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 + end subroutine spmm_serial_rb_tree -subroutine spmm_omp_rb_tree(a,b,c,info) + subroutine spmm_omp_rb_tree(a,b,c,info) use omp_lib use psb_rb_idx_tree_mod implicit none @@ -4070,11 +4194,11 @@ subroutine spmm_omp_rb_tree(a,b,c,info) !$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 + 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 @@ -4082,9 +4206,9 @@ subroutine spmm_omp_rb_tree(a,b,c,info) deallocate(row_accs) info = 0 -end subroutine spmm_omp_rb_tree + end subroutine spmm_omp_rb_tree -subroutine compute_indices(a, b, c, info) + 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 @@ -4096,10 +4220,10 @@ subroutine compute_indices(a, b, c, info) 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 + 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 @@ -4109,22 +4233,22 @@ subroutine compute_indices(a, b, c, info) 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 + 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 - c%irp(row + 1) = nnz + 1 - call psb_qsort(c%ja(c%irp(row):c%irp(row + 1)-1)) + end do + c%irp(row + 1) = nnz + 1 + call psb_qsort(c%ja(c%irp(row):c%irp(row + 1)-1)) end do @@ -4132,9 +4256,9 @@ subroutine compute_indices(a, b, c, info) call psb_realloc(nnz, c%val, info) c%val = 0 -end subroutine compute_indices + end subroutine compute_indices -subroutine direct_scalar_sparse_row_mul(out_mat, out_row_num, scalar, mat, trgt_row_num) + 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 @@ -4147,17 +4271,17 @@ subroutine direct_scalar_sparse_row_mul(out_mat, out_row_num, scalar, mat, trgt_ 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 + 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 + end subroutine direct_scalar_sparse_row_mul -subroutine spmm_omp_two_pass(a,b,c,info) + subroutine spmm_omp_two_pass(a,b,c,info) use omp_lib implicit none @@ -4171,20 +4295,20 @@ subroutine spmm_omp_two_pass(a,b,c,info) 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 + 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 spmm_omp_two_pass end subroutine psb_dcsrspspmm - +#endif ! ! diff --git a/base/serial/impl/psb_s_csr_impl.F90 b/base/serial/impl/psb_s_csr_impl.F90 index dbe7a4bea..59d73892d 100644 --- a/base/serial/impl/psb_s_csr_impl.F90 +++ b/base/serial/impl/psb_s_csr_impl.F90 @@ -3213,10 +3213,10 @@ 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) @@ -3246,7 +3246,7 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) #endif call a%set_host() - + end subroutine psb_s_cp_csr_from_coo @@ -3495,7 +3495,7 @@ subroutine psb_s_cp_csr_to_fmt(a,b,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 + ! 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) @@ -3600,7 +3600,7 @@ subroutine psb_s_cp_csr_from_fmt(a,b,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 + ! 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) @@ -3654,6 +3654,7 @@ subroutine psb_s_csr_clean_zeros(a, info) call a%set_host() end subroutine psb_s_csr_clean_zeros +#if 0 subroutine psb_scsrspspmm(a,b,c,info) use psb_s_mat_mod use psb_serial_mod, psb_protect_name => psb_scsrspspmm @@ -3776,7 +3777,538 @@ contains end subroutine csr_spspmm 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 + + 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 +#endif ! ! 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_csr_impl.F90 b/base/serial/impl/psb_z_csr_impl.F90 index 9322105e9..34cd6fbcf 100644 --- a/base/serial/impl/psb_z_csr_impl.F90 +++ b/base/serial/impl/psb_z_csr_impl.F90 @@ -3213,10 +3213,10 @@ 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) @@ -3246,7 +3246,7 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) #endif call a%set_host() - + end subroutine psb_z_cp_csr_from_coo @@ -3495,7 +3495,7 @@ subroutine psb_z_cp_csr_to_fmt(a,b,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 + ! 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) @@ -3600,7 +3600,7 @@ subroutine psb_z_cp_csr_from_fmt(a,b,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 + ! 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) @@ -3654,6 +3654,7 @@ subroutine psb_z_csr_clean_zeros(a, info) call a%set_host() end subroutine psb_z_csr_clean_zeros +#if 0 subroutine psb_zcsrspspmm(a,b,c,info) use psb_z_mat_mod use psb_serial_mod, psb_protect_name => psb_zcsrspspmm @@ -3776,7 +3777,538 @@ contains end subroutine csr_spspmm 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 + + 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 +#endif ! ! 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 From 41be1357c3af03b6dadb98b1b9647b9fa1f67caf Mon Sep 17 00:00:00 2001 From: sfilippone Date: Wed, 30 Aug 2023 13:45:51 +0200 Subject: [PATCH 52/63] Set defaults for SPSPMM depending on OpenMP compilation. --- base/modules/serial/psb_base_mat_mod.F90 | 5 +- base/serial/impl/psb_c_csr_impl.F90 | 250 ++++++++++++----------- base/serial/impl/psb_d_csr_impl.F90 | 250 ++++++++++++----------- base/serial/impl/psb_s_csr_impl.F90 | 250 ++++++++++++----------- base/serial/impl/psb_z_csr_impl.F90 | 250 ++++++++++++----------- 5 files changed, 508 insertions(+), 497 deletions(-) diff --git a/base/modules/serial/psb_base_mat_mod.F90 b/base/modules/serial/psb_base_mat_mod.F90 index 07bfbd504..2380fcb26 100644 --- a/base/modules/serial/psb_base_mat_mod.F90 +++ b/base/modules/serial/psb_base_mat_mod.F90 @@ -80,8 +80,11 @@ module psb_base_mat_mod 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 diff --git a/base/serial/impl/psb_c_csr_impl.F90 b/base/serial/impl/psb_c_csr_impl.F90 index 3709ad21b..2028300dc 100644 --- a/base/serial/impl/psb_c_csr_impl.F90 +++ b/base/serial/impl/psb_c_csr_impl.F90 @@ -3654,130 +3654,7 @@ subroutine psb_c_csr_clean_zeros(a, info) call a%set_host() end subroutine psb_c_csr_clean_zeros -#if 0 -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 - - ! 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) - - 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 - -end subroutine psb_ccsrspspmm -#else +#if defined(OPENMP) subroutine psb_ccsrspspmm(a,b,c,info) use psb_c_mat_mod use psb_serial_mod, psb_protect_name => psb_ccsrspspmm @@ -4307,6 +4184,131 @@ contains !$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 + + 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 + + ! 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) + + 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 + end subroutine psb_ccsrspspmm #endif diff --git a/base/serial/impl/psb_d_csr_impl.F90 b/base/serial/impl/psb_d_csr_impl.F90 index b8f692fa2..10f99bc91 100644 --- a/base/serial/impl/psb_d_csr_impl.F90 +++ b/base/serial/impl/psb_d_csr_impl.F90 @@ -3654,130 +3654,7 @@ subroutine psb_d_csr_clean_zeros(a, info) call a%set_host() end subroutine psb_d_csr_clean_zeros -#if 0 -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 - - ! 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) - - 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 - -end subroutine psb_dcsrspspmm -#else +#if defined(OPENMP) subroutine psb_dcsrspspmm(a,b,c,info) use psb_d_mat_mod use psb_serial_mod, psb_protect_name => psb_dcsrspspmm @@ -4307,6 +4184,131 @@ contains !$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 + + 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 + + ! 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) + + 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 + end subroutine psb_dcsrspspmm #endif diff --git a/base/serial/impl/psb_s_csr_impl.F90 b/base/serial/impl/psb_s_csr_impl.F90 index 59d73892d..f3d5c669c 100644 --- a/base/serial/impl/psb_s_csr_impl.F90 +++ b/base/serial/impl/psb_s_csr_impl.F90 @@ -3654,130 +3654,7 @@ subroutine psb_s_csr_clean_zeros(a, info) call a%set_host() end subroutine psb_s_csr_clean_zeros -#if 0 -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 - - ! 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) - - 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 - -end subroutine psb_scsrspspmm -#else +#if defined(OPENMP) subroutine psb_scsrspspmm(a,b,c,info) use psb_s_mat_mod use psb_serial_mod, psb_protect_name => psb_scsrspspmm @@ -4307,6 +4184,131 @@ contains !$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 + + 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 + + ! 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) + + 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 + end subroutine psb_scsrspspmm #endif diff --git a/base/serial/impl/psb_z_csr_impl.F90 b/base/serial/impl/psb_z_csr_impl.F90 index 34cd6fbcf..5cf1c72d4 100644 --- a/base/serial/impl/psb_z_csr_impl.F90 +++ b/base/serial/impl/psb_z_csr_impl.F90 @@ -3654,130 +3654,7 @@ subroutine psb_z_csr_clean_zeros(a, info) call a%set_host() end subroutine psb_z_csr_clean_zeros -#if 0 -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 - - ! 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) - - 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 - -end subroutine psb_zcsrspspmm -#else +#if defined(OPENMP) subroutine psb_zcsrspspmm(a,b,c,info) use psb_z_mat_mod use psb_serial_mod, psb_protect_name => psb_zcsrspspmm @@ -4307,6 +4184,131 @@ contains !$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 + + 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 + + ! 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) + + 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 + end subroutine psb_zcsrspspmm #endif From 3e29e603d2297d9110b74fc15b3d3e730be9d846 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 5 Sep 2023 16:59:03 +0200 Subject: [PATCH 53/63] Fix necessary flags for GCC --- configure | 60 +++++++++++++++++++++++++++------------------------- configure.ac | 12 ++++++----- 2 files changed, 38 insertions(+), 34 deletions(-) diff --git a/configure b/configure index 97b3eb794..752fe192f 100755 --- a/configure +++ b/configure @@ -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 diff --git a/configure.ac b/configure.ac index d9923a6ec..d8a02a50b 100755 --- a/configure.ac +++ b/configure.ac @@ -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 . From efa29bc3ad9e2ee74d3cbfe78dffef63377c6ac4 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 5 Sep 2023 17:00:49 +0200 Subject: [PATCH 54/63] Fix configure for GCC when using --with-fcopt --- configure | 60 +++++++++++++++++++++++++++------------------------- configure.ac | 12 ++++++----- 2 files changed, 38 insertions(+), 34 deletions(-) diff --git a/configure b/configure index 97b3eb794..752fe192f 100755 --- a/configure +++ b/configure @@ -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 diff --git a/configure.ac b/configure.ac index d9923a6ec..d8a02a50b 100755 --- a/configure.ac +++ b/configure.ac @@ -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 . From def0635c5304b3bbbdf205f3f788531b12ce8947 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Thu, 7 Sep 2023 09:25:37 +0200 Subject: [PATCH 55/63] More OMP directives in cd_inloc --- base/tools/psb_cd_inloc.f90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) 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 From e31dd52c41e04c82fcbdb8d8a9cb900f62fff2f3 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Thu, 7 Sep 2023 09:48:18 +0200 Subject: [PATCH 56/63] Fixed CRITICAL in hash_mod --- base/modules/desc/psb_hash_mod.F90 | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/base/modules/desc/psb_hash_mod.F90 b/base/modules/desc/psb_hash_mod.F90 index 9e45e1f07..eb5556a2a 100644 --- a/base/modules/desc/psb_hash_mod.F90 +++ b/base/modules/desc/psb_hash_mod.F90 @@ -458,7 +458,7 @@ 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 @@ -483,6 +483,7 @@ contains info = HashDuplicate return end if + redo = .false. !$OMP CRITICAL if (hash%table(hk,1) == HashFreeEntry) then if (hash%nk == hash%hsize -1) then @@ -497,8 +498,9 @@ contains info = HashOutOfMemory !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 @@ -509,6 +511,7 @@ contains 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 From d3fcd566d92605de57ece25977544b32f046e59f Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 23 Oct 2023 14:16:30 +0200 Subject: [PATCH 57/63] Define a SHIFT argument to compute ILU( A+shft I) --- prec/impl/psb_c_ilu0_fact.f90 | 27 ++++++++++++++++++--------- prec/impl/psb_c_iluk_fact.f90 | 21 ++++++++++++++------- prec/impl/psb_c_ilut_fact.f90 | 17 +++++++++++------ prec/impl/psb_d_ilu0_fact.f90 | 27 ++++++++++++++++++--------- prec/impl/psb_d_iluk_fact.f90 | 21 ++++++++++++++------- prec/impl/psb_d_ilut_fact.f90 | 17 +++++++++++------ prec/impl/psb_s_ilu0_fact.f90 | 27 ++++++++++++++++++--------- prec/impl/psb_s_iluk_fact.f90 | 21 ++++++++++++++------- prec/impl/psb_s_ilut_fact.f90 | 17 +++++++++++------ prec/impl/psb_z_ilu0_fact.f90 | 27 ++++++++++++++++++--------- prec/impl/psb_z_iluk_fact.f90 | 21 ++++++++++++++------- prec/impl/psb_z_ilut_fact.f90 | 17 +++++++++++------ prec/psb_c_ilu_fact_mod.f90 | 9 ++++++--- prec/psb_d_ilu_fact_mod.f90 | 9 ++++++--- prec/psb_s_ilu_fact_mod.f90 | 9 ++++++--- prec/psb_z_ilu_fact_mod.f90 | 9 ++++++--- 16 files changed, 196 insertions(+), 100 deletions(-) diff --git a/prec/impl/psb_c_ilu0_fact.f90 b/prec/impl/psb_c_ilu0_fact.f90 index 1a3e10463..9e039b19f 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..ddda6d201 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,6 +141,7 @@ 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 @@ -184,7 +185,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 +299,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 +312,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 +402,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 +518,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 +532,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 +558,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 +592,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 +676,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..997b3b84c 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,6 +139,7 @@ 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_ @@ -206,7 +207,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 +317,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 +332,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 +403,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 +542,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 +553,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 +600,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 +652,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..29968e0c2 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..8f1e6c7b5 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,6 +141,7 @@ 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 @@ -184,7 +185,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 +299,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 +312,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 +402,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 +518,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 +532,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 +558,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 +592,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 +676,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..c6079b55b 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,6 +139,7 @@ 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_ @@ -206,7 +207,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 +317,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 +332,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 +403,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 +542,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 +553,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 +600,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 +652,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..faa21fdaf 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..17ef4eefc 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,6 +141,7 @@ 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 @@ -184,7 +185,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 +299,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 +312,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 +402,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 +518,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 +532,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 +558,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 +592,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 +676,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..76b514a3e 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,6 +139,7 @@ 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_ @@ -206,7 +207,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 +317,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 +332,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 +403,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 +542,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 +553,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 +600,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 +652,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..c6c0fc55c 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..7675226a7 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,6 +141,7 @@ 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 @@ -184,7 +185,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 +299,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 +312,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 +402,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 +518,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 +532,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 +558,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 +592,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 +676,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..2f0047251 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,6 +139,7 @@ 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_ @@ -206,7 +207,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 +317,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 +332,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 +403,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 +542,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 +553,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 +600,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 +652,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 From 250a6300bab7dc75cdf7722c998db4ca4c91173f Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 23 Oct 2023 15:14:48 +0200 Subject: [PATCH 58/63] Fix SHFT implementation --- prec/impl/psb_c_iluk_fact.f90 | 6 ++++++ prec/impl/psb_c_ilut_fact.f90 | 6 ++++++ prec/impl/psb_d_iluk_fact.f90 | 6 ++++++ prec/impl/psb_d_ilut_fact.f90 | 6 ++++++ prec/impl/psb_s_iluk_fact.f90 | 6 ++++++ prec/impl/psb_s_ilut_fact.f90 | 6 ++++++ prec/impl/psb_z_iluk_fact.f90 | 6 ++++++ prec/impl/psb_z_ilut_fact.f90 | 6 ++++++ 8 files changed, 48 insertions(+) diff --git a/prec/impl/psb_c_iluk_fact.f90 b/prec/impl/psb_c_iluk_fact.f90 index ddda6d201..4e6d7a5c8 100644 --- a/prec/impl/psb_c_iluk_fact.f90 +++ b/prec/impl/psb_c_iluk_fact.f90 @@ -145,6 +145,7 @@ subroutine psb_ciluk_fact(fill_in,ialg,a,l,u,d,info,blck,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 @@ -168,6 +169,11 @@ subroutine psb_ciluk_fact(fill_in,ialg,a,l,u,d,info,blck,shft) 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.& diff --git a/prec/impl/psb_c_ilut_fact.f90 b/prec/impl/psb_c_ilut_fact.f90 index 997b3b84c..6aecb53b2 100644 --- a/prec/impl/psb_c_ilut_fact.f90 +++ b/prec/impl/psb_c_ilut_fact.f90 @@ -143,6 +143,7 @@ subroutine psb_cilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale,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 @@ -178,6 +179,11 @@ subroutine psb_cilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale,shft) 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_) diff --git a/prec/impl/psb_d_iluk_fact.f90 b/prec/impl/psb_d_iluk_fact.f90 index 8f1e6c7b5..94c34fec9 100644 --- a/prec/impl/psb_d_iluk_fact.f90 +++ b/prec/impl/psb_d_iluk_fact.f90 @@ -145,6 +145,7 @@ subroutine psb_diluk_fact(fill_in,ialg,a,l,u,d,info,blck,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 @@ -168,6 +169,11 @@ subroutine psb_diluk_fact(fill_in,ialg,a,l,u,d,info,blck,shft) 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.& diff --git a/prec/impl/psb_d_ilut_fact.f90 b/prec/impl/psb_d_ilut_fact.f90 index c6079b55b..c4f05df66 100644 --- a/prec/impl/psb_d_ilut_fact.f90 +++ b/prec/impl/psb_d_ilut_fact.f90 @@ -143,6 +143,7 @@ subroutine psb_dilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale,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 @@ -178,6 +179,11 @@ subroutine psb_dilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale,shft) 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_) diff --git a/prec/impl/psb_s_iluk_fact.f90 b/prec/impl/psb_s_iluk_fact.f90 index 17ef4eefc..99d488806 100644 --- a/prec/impl/psb_s_iluk_fact.f90 +++ b/prec/impl/psb_s_iluk_fact.f90 @@ -145,6 +145,7 @@ subroutine psb_siluk_fact(fill_in,ialg,a,l,u,d,info,blck,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 @@ -168,6 +169,11 @@ subroutine psb_siluk_fact(fill_in,ialg,a,l,u,d,info,blck,shft) 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.& diff --git a/prec/impl/psb_s_ilut_fact.f90 b/prec/impl/psb_s_ilut_fact.f90 index 76b514a3e..d63c5fb87 100644 --- a/prec/impl/psb_s_ilut_fact.f90 +++ b/prec/impl/psb_s_ilut_fact.f90 @@ -143,6 +143,7 @@ subroutine psb_silut_fact(fill_in,thres,a,l,u,d,info,blck,iscale,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 @@ -178,6 +179,11 @@ subroutine psb_silut_fact(fill_in,thres,a,l,u,d,info,blck,iscale,shft) 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_) diff --git a/prec/impl/psb_z_iluk_fact.f90 b/prec/impl/psb_z_iluk_fact.f90 index 7675226a7..dbd9430cd 100644 --- a/prec/impl/psb_z_iluk_fact.f90 +++ b/prec/impl/psb_z_iluk_fact.f90 @@ -145,6 +145,7 @@ subroutine psb_ziluk_fact(fill_in,ialg,a,l,u,d,info,blck,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 @@ -168,6 +169,11 @@ subroutine psb_ziluk_fact(fill_in,ialg,a,l,u,d,info,blck,shft) 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.& diff --git a/prec/impl/psb_z_ilut_fact.f90 b/prec/impl/psb_z_ilut_fact.f90 index 2f0047251..5e44f14ab 100644 --- a/prec/impl/psb_z_ilut_fact.f90 +++ b/prec/impl/psb_z_ilut_fact.f90 @@ -143,6 +143,7 @@ subroutine psb_zilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale,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 @@ -178,6 +179,11 @@ subroutine psb_zilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale,shft) 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_) From 25e9183e5055d5050f7521e78e7b321331493f6c Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 23 Oct 2023 15:31:13 +0200 Subject: [PATCH 59/63] Fix SHFT implementation, step 2 --- prec/impl/psb_c_ilu0_fact.f90 | 4 ++-- prec/impl/psb_c_iluk_fact.f90 | 2 +- prec/impl/psb_c_ilut_fact.f90 | 2 +- prec/impl/psb_d_ilu0_fact.f90 | 4 ++-- prec/impl/psb_d_iluk_fact.f90 | 2 +- prec/impl/psb_d_ilut_fact.f90 | 2 +- prec/impl/psb_s_ilu0_fact.f90 | 4 ++-- prec/impl/psb_s_iluk_fact.f90 | 2 +- prec/impl/psb_s_ilut_fact.f90 | 2 +- prec/impl/psb_z_ilu0_fact.f90 | 4 ++-- prec/impl/psb_z_iluk_fact.f90 | 2 +- prec/impl/psb_z_ilut_fact.f90 | 2 +- 12 files changed, 16 insertions(+), 16 deletions(-) diff --git a/prec/impl/psb_c_ilu0_fact.f90 b/prec/impl/psb_c_ilu0_fact.f90 index 9e039b19f..c016359fd 100644 --- a/prec/impl/psb_c_ilu0_fact.f90 +++ b/prec/impl/psb_c_ilu0_fact.f90 @@ -390,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,shft) + & 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,shft) + & d(i),l2,uja,uval,ktrw,trw,upd,shft_) endif lirp(i+1) = l1 + 1 diff --git a/prec/impl/psb_c_iluk_fact.f90 b/prec/impl/psb_c_iluk_fact.f90 index 4e6d7a5c8..6c6d8a5f3 100644 --- a/prec/impl/psb_c_iluk_fact.f90 +++ b/prec/impl/psb_c_iluk_fact.f90 @@ -191,7 +191,7 @@ subroutine psb_ciluk_fact(fill_in,ialg,a,l,u,d,info,blck,shft) ! 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,shft) + & 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' diff --git a/prec/impl/psb_c_ilut_fact.f90 b/prec/impl/psb_c_ilut_fact.f90 index 6aecb53b2..8421ee1c3 100644 --- a/prec/impl/psb_c_ilut_fact.f90 +++ b/prec/impl/psb_c_ilut_fact.f90 @@ -213,7 +213,7 @@ subroutine psb_cilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale,shft) ! 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,shft) + & 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' diff --git a/prec/impl/psb_d_ilu0_fact.f90 b/prec/impl/psb_d_ilu0_fact.f90 index 29968e0c2..dde22249e 100644 --- a/prec/impl/psb_d_ilu0_fact.f90 +++ b/prec/impl/psb_d_ilu0_fact.f90 @@ -390,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,shft) + & 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,shft) + & d(i),l2,uja,uval,ktrw,trw,upd,shft_) endif lirp(i+1) = l1 + 1 diff --git a/prec/impl/psb_d_iluk_fact.f90 b/prec/impl/psb_d_iluk_fact.f90 index 94c34fec9..dc837ba91 100644 --- a/prec/impl/psb_d_iluk_fact.f90 +++ b/prec/impl/psb_d_iluk_fact.f90 @@ -191,7 +191,7 @@ subroutine psb_diluk_fact(fill_in,ialg,a,l,u,d,info,blck,shft) ! 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,shft) + & 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' diff --git a/prec/impl/psb_d_ilut_fact.f90 b/prec/impl/psb_d_ilut_fact.f90 index c4f05df66..cd185e806 100644 --- a/prec/impl/psb_d_ilut_fact.f90 +++ b/prec/impl/psb_d_ilut_fact.f90 @@ -213,7 +213,7 @@ subroutine psb_dilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale,shft) ! 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,shft) + & 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' diff --git a/prec/impl/psb_s_ilu0_fact.f90 b/prec/impl/psb_s_ilu0_fact.f90 index faa21fdaf..d9ce1298e 100644 --- a/prec/impl/psb_s_ilu0_fact.f90 +++ b/prec/impl/psb_s_ilu0_fact.f90 @@ -390,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,shft) + & 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,shft) + & d(i),l2,uja,uval,ktrw,trw,upd,shft_) endif lirp(i+1) = l1 + 1 diff --git a/prec/impl/psb_s_iluk_fact.f90 b/prec/impl/psb_s_iluk_fact.f90 index 99d488806..67fb8ada2 100644 --- a/prec/impl/psb_s_iluk_fact.f90 +++ b/prec/impl/psb_s_iluk_fact.f90 @@ -191,7 +191,7 @@ subroutine psb_siluk_fact(fill_in,ialg,a,l,u,d,info,blck,shft) ! 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,shft) + & 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' diff --git a/prec/impl/psb_s_ilut_fact.f90 b/prec/impl/psb_s_ilut_fact.f90 index d63c5fb87..3d1111033 100644 --- a/prec/impl/psb_s_ilut_fact.f90 +++ b/prec/impl/psb_s_ilut_fact.f90 @@ -213,7 +213,7 @@ subroutine psb_silut_fact(fill_in,thres,a,l,u,d,info,blck,iscale,shft) ! 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,shft) + & 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' diff --git a/prec/impl/psb_z_ilu0_fact.f90 b/prec/impl/psb_z_ilu0_fact.f90 index c6c0fc55c..997a5e054 100644 --- a/prec/impl/psb_z_ilu0_fact.f90 +++ b/prec/impl/psb_z_ilu0_fact.f90 @@ -390,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,shft) + & 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,shft) + & d(i),l2,uja,uval,ktrw,trw,upd,shft_) endif lirp(i+1) = l1 + 1 diff --git a/prec/impl/psb_z_iluk_fact.f90 b/prec/impl/psb_z_iluk_fact.f90 index dbd9430cd..a5540880b 100644 --- a/prec/impl/psb_z_iluk_fact.f90 +++ b/prec/impl/psb_z_iluk_fact.f90 @@ -191,7 +191,7 @@ subroutine psb_ziluk_fact(fill_in,ialg,a,l,u,d,info,blck,shft) ! 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,shft) + & 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' diff --git a/prec/impl/psb_z_ilut_fact.f90 b/prec/impl/psb_z_ilut_fact.f90 index 5e44f14ab..0c2785157 100644 --- a/prec/impl/psb_z_ilut_fact.f90 +++ b/prec/impl/psb_z_ilut_fact.f90 @@ -213,7 +213,7 @@ subroutine psb_zilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale,shft) ! 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,shft) + & 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' From d82b0902899a8d436c005d8c11bdde9fd7efc55f Mon Sep 17 00:00:00 2001 From: sfilippone Date: Wed, 25 Oct 2023 12:47:31 +0200 Subject: [PATCH 60/63] Fix makefile for psi_acx & friends --- base/modules/Makefile | 1 + 1 file changed, 1 insertion(+) diff --git a/base/modules/Makefile b/base/modules/Makefile index f1cb5e534..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 \ From 5caee551e5c81a042b66a6e9ff5059e8ba9587d3 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 3 Nov 2023 14:28:04 +0100 Subject: [PATCH 61/63] Fixed IN_PLACE option for collectives. --- base/comm/psb_cgather.f90 | 43 +- base/comm/psb_cgather_a.f90 | 37 +- base/comm/psb_dgather.f90 | 43 +- base/comm/psb_dgather_a.f90 | 37 +- base/comm/psb_egather_a.f90 | 37 +- base/comm/psb_i2gather_a.f90 | 37 +- base/comm/psb_igather.f90 | 43 +- base/comm/psb_lgather.f90 | 43 +- base/comm/psb_mgather_a.f90 | 37 +- base/comm/psb_sgather.f90 | 43 +- base/comm/psb_sgather_a.f90 | 37 +- base/comm/psb_zgather.f90 | 43 +- base/comm/psb_zgather_a.f90 | 37 +- base/modules/penv/psi_c_collective_mod.F90 | 469 ++++++++++++-- base/modules/penv/psi_d_collective_mod.F90 | 651 ++++++++++++++++---- base/modules/penv/psi_e_collective_mod.F90 | 607 +++++++++++++++--- base/modules/penv/psi_i2_collective_mod.F90 | 607 +++++++++++++++--- base/modules/penv/psi_m_collective_mod.F90 | 607 +++++++++++++++--- base/modules/penv/psi_s_collective_mod.F90 | 651 ++++++++++++++++---- base/modules/penv/psi_z_collective_mod.F90 | 469 ++++++++++++-- 20 files changed, 3720 insertions(+), 858 deletions(-) diff --git a/base/comm/psb_cgather.f90 b/base/comm/psb_cgather.f90 index 7893d7c3f..fc7ba7fb8 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,36 @@ 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) + if ((me == root).or.(root == -1)) then + allocate(szs(np)) + end if + 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_cgather_a.f90 b/base/comm/psb_cgather_a.f90 index ac2e66e4a..9212b3282 100644 --- a/base/comm/psb_cgather_a.f90 +++ b/base/comm/psb_cgather_a.f90 @@ -60,7 +60,7 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot) type(psb_ctxt_type) :: ctxt integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& - & maxk, k, jlx, ilx, i, j + & maxk, k, jlx, ilx, i, j, loc_rows integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx character(len=20) :: name, ch_err @@ -232,11 +232,11 @@ subroutine psb_cgatherv(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, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx - + integer(psb_mpk_), allocatable :: szs(:) character(len=20) :: name, ch_err name='psb_cgatherv' @@ -307,23 +307,32 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot) goto 9999 end if - globx(:)=czero - - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx) = locx(i) - end do - ! 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 + locx(idx) = czero end if end do - - call psb_sum(ctxt,globx(1:m),root=root) + loc_rows = desc_a%get_local_rows() + if ((me == root).or.(root == -1)) then + allocate(szs(np)) + end if + 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,locx(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..a12be1e45 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,36 @@ 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) + if ((me == root).or.(root == -1)) then + allocate(szs(np)) + end if + 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_a.f90 b/base/comm/psb_dgather_a.f90 index 1e03ccfd1..eec28bdca 100644 --- a/base/comm/psb_dgather_a.f90 +++ b/base/comm/psb_dgather_a.f90 @@ -60,7 +60,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) type(psb_ctxt_type) :: ctxt integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& - & maxk, k, jlx, ilx, i, j + & maxk, k, jlx, ilx, i, j, loc_rows integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx character(len=20) :: name, ch_err @@ -232,11 +232,11 @@ subroutine psb_dgatherv(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, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx - + integer(psb_mpk_), allocatable :: szs(:) character(len=20) :: name, ch_err name='psb_dgatherv' @@ -307,23 +307,32 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) goto 9999 end if - globx(:)=dzero - - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx) = locx(i) - end do - ! 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 + locx(idx) = dzero end if end do - - call psb_sum(ctxt,globx(1:m),root=root) + loc_rows = desc_a%get_local_rows() + if ((me == root).or.(root == -1)) then + allocate(szs(np)) + end if + 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,locx(1:loc_rows),globx,szs,root=root) call psb_erractionrestore(err_act) return diff --git a/base/comm/psb_egather_a.f90 b/base/comm/psb_egather_a.f90 index b777cebd7..21a41143a 100644 --- a/base/comm/psb_egather_a.f90 +++ b/base/comm/psb_egather_a.f90 @@ -60,7 +60,7 @@ subroutine psb_egatherm(globx, locx, desc_a, info, iroot) type(psb_ctxt_type) :: ctxt integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& - & maxk, k, jlx, ilx, i, j + & maxk, k, jlx, ilx, i, j, loc_rows integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx character(len=20) :: name, ch_err @@ -232,11 +232,11 @@ subroutine psb_egatherv(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, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx - + integer(psb_mpk_), allocatable :: szs(:) character(len=20) :: name, ch_err name='psb_egatherv' @@ -307,23 +307,32 @@ subroutine psb_egatherv(globx, locx, desc_a, info, iroot) goto 9999 end if - globx(:)=ezero - - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx) = locx(i) - end do - ! 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) = ezero + locx(idx) = ezero end if end do - - call psb_sum(ctxt,globx(1:m),root=root) + loc_rows = desc_a%get_local_rows() + if ((me == root).or.(root == -1)) then + allocate(szs(np)) + end if + 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,locx(1:loc_rows),globx,szs,root=root) call psb_erractionrestore(err_act) return diff --git a/base/comm/psb_i2gather_a.f90 b/base/comm/psb_i2gather_a.f90 index e0e1ed7a7..f0f2a93a7 100644 --- a/base/comm/psb_i2gather_a.f90 +++ b/base/comm/psb_i2gather_a.f90 @@ -60,7 +60,7 @@ subroutine psb_i2gatherm(globx, locx, desc_a, info, iroot) type(psb_ctxt_type) :: ctxt integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& - & maxk, k, jlx, ilx, i, j + & maxk, k, jlx, ilx, i, j, loc_rows integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx character(len=20) :: name, ch_err @@ -232,11 +232,11 @@ subroutine psb_i2gatherv(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, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx - + integer(psb_mpk_), allocatable :: szs(:) character(len=20) :: name, ch_err name='psb_i2gatherv' @@ -307,23 +307,32 @@ subroutine psb_i2gatherv(globx, locx, desc_a, info, iroot) goto 9999 end if - globx(:)=i2zero - - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx) = locx(i) - end do - ! 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) = i2zero + locx(idx) = i2zero end if end do - - call psb_sum(ctxt,globx(1:m),root=root) + loc_rows = desc_a%get_local_rows() + if ((me == root).or.(root == -1)) then + allocate(szs(np)) + end if + 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,locx(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..62a84173a 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,36 @@ 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) + if ((me == root).or.(root == -1)) then + allocate(szs(np)) + end if + 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..7b4e7ac9a 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,36 @@ 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) + if ((me == root).or.(root == -1)) then + allocate(szs(np)) + end if + 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_mgather_a.f90 b/base/comm/psb_mgather_a.f90 index df574ea29..ccf2f0c00 100644 --- a/base/comm/psb_mgather_a.f90 +++ b/base/comm/psb_mgather_a.f90 @@ -60,7 +60,7 @@ subroutine psb_mgatherm(globx, locx, desc_a, info, iroot) type(psb_ctxt_type) :: ctxt integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& - & maxk, k, jlx, ilx, i, j + & maxk, k, jlx, ilx, i, j, loc_rows integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx character(len=20) :: name, ch_err @@ -232,11 +232,11 @@ subroutine psb_mgatherv(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, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx - + integer(psb_mpk_), allocatable :: szs(:) character(len=20) :: name, ch_err name='psb_mgatherv' @@ -307,23 +307,32 @@ subroutine psb_mgatherv(globx, locx, desc_a, info, iroot) goto 9999 end if - globx(:)=mzero - - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx) = locx(i) - end do - ! 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) = mzero + locx(idx) = mzero end if end do - - call psb_sum(ctxt,globx(1:m),root=root) + loc_rows = desc_a%get_local_rows() + if ((me == root).or.(root == -1)) then + allocate(szs(np)) + end if + 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,locx(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..30d25440b 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,36 @@ 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) + if ((me == root).or.(root == -1)) then + allocate(szs(np)) + end if + 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_a.f90 b/base/comm/psb_sgather_a.f90 index 28d5f5dca..27e21e785 100644 --- a/base/comm/psb_sgather_a.f90 +++ b/base/comm/psb_sgather_a.f90 @@ -60,7 +60,7 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) type(psb_ctxt_type) :: ctxt integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& - & maxk, k, jlx, ilx, i, j + & maxk, k, jlx, ilx, i, j, loc_rows integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx character(len=20) :: name, ch_err @@ -232,11 +232,11 @@ subroutine psb_sgatherv(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, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx - + integer(psb_mpk_), allocatable :: szs(:) character(len=20) :: name, ch_err name='psb_sgatherv' @@ -307,23 +307,32 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) goto 9999 end if - globx(:)=szero - - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx) = locx(i) - end do - ! 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 + locx(idx) = szero end if end do - - call psb_sum(ctxt,globx(1:m),root=root) + loc_rows = desc_a%get_local_rows() + if ((me == root).or.(root == -1)) then + allocate(szs(np)) + end if + 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,locx(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..d60f15c66 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,36 @@ 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) + if ((me == root).or.(root == -1)) then + allocate(szs(np)) + end if + 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_a.f90 b/base/comm/psb_zgather_a.f90 index fa5f288b5..98ed87724 100644 --- a/base/comm/psb_zgather_a.f90 +++ b/base/comm/psb_zgather_a.f90 @@ -60,7 +60,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) type(psb_ctxt_type) :: ctxt integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& - & maxk, k, jlx, ilx, i, j + & maxk, k, jlx, ilx, i, j, loc_rows integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx character(len=20) :: name, ch_err @@ -232,11 +232,11 @@ subroutine psb_zgatherv(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, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx - + integer(psb_mpk_), allocatable :: szs(:) character(len=20) :: name, ch_err name='psb_zgatherv' @@ -307,23 +307,32 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) goto 9999 end if - globx(:)=zzero - - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx) = locx(i) - end do - ! 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 + locx(idx) = zzero end if end do - - call psb_sum(ctxt,globx(1:m),root=root) + loc_rows = desc_a%get_local_rows() + if ((me == root).or.(root == -1)) then + allocate(szs(np)) + end if + 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,locx(1:loc_rows),globx,szs,root=root) call psb_erractionrestore(err_act) return 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 From baf18cebd728f50b71b738affd23694934676584 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 3 Nov 2023 14:39:01 +0100 Subject: [PATCH 62/63] Further fix for gather. --- base/comm/psb_cgather_a.f90 | 37 ++++++++++++++---------------------- base/comm/psb_dgather_a.f90 | 37 ++++++++++++++---------------------- base/comm/psb_egather_a.f90 | 37 ++++++++++++++---------------------- base/comm/psb_i2gather_a.f90 | 37 ++++++++++++++---------------------- base/comm/psb_mgather_a.f90 | 37 ++++++++++++++---------------------- base/comm/psb_sgather_a.f90 | 37 ++++++++++++++---------------------- base/comm/psb_zgather_a.f90 | 37 ++++++++++++++---------------------- 7 files changed, 98 insertions(+), 161 deletions(-) diff --git a/base/comm/psb_cgather_a.f90 b/base/comm/psb_cgather_a.f90 index 9212b3282..ac2e66e4a 100644 --- a/base/comm/psb_cgather_a.f90 +++ b/base/comm/psb_cgather_a.f90 @@ -60,7 +60,7 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot) type(psb_ctxt_type) :: ctxt integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& - & maxk, k, jlx, ilx, i, j, loc_rows + & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx character(len=20) :: name, ch_err @@ -232,11 +232,11 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot) ! locals type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx - integer(psb_mpk_), allocatable :: szs(:) + character(len=20) :: name, ch_err name='psb_cgatherv' @@ -307,32 +307,23 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot) goto 9999 end if + globx(:)=czero + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx) = locx(i) + end do + ! 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) - locx(idx) = czero + call psb_loc_to_glob(idx,desc_a,info) + globx(idx) = czero end if end do - loc_rows = desc_a%get_local_rows() - if ((me == root).or.(root == -1)) then - allocate(szs(np)) - end if - 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,locx(1:loc_rows),globx,szs,root=root) + + call psb_sum(ctxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return diff --git a/base/comm/psb_dgather_a.f90 b/base/comm/psb_dgather_a.f90 index eec28bdca..1e03ccfd1 100644 --- a/base/comm/psb_dgather_a.f90 +++ b/base/comm/psb_dgather_a.f90 @@ -60,7 +60,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) type(psb_ctxt_type) :: ctxt integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& - & maxk, k, jlx, ilx, i, j, loc_rows + & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx character(len=20) :: name, ch_err @@ -232,11 +232,11 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) ! locals type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx - integer(psb_mpk_), allocatable :: szs(:) + character(len=20) :: name, ch_err name='psb_dgatherv' @@ -307,32 +307,23 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) goto 9999 end if + globx(:)=dzero + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx) = locx(i) + end do + ! 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) - locx(idx) = dzero + call psb_loc_to_glob(idx,desc_a,info) + globx(idx) = dzero end if end do - loc_rows = desc_a%get_local_rows() - if ((me == root).or.(root == -1)) then - allocate(szs(np)) - end if - 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,locx(1:loc_rows),globx,szs,root=root) + + call psb_sum(ctxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return diff --git a/base/comm/psb_egather_a.f90 b/base/comm/psb_egather_a.f90 index 21a41143a..b777cebd7 100644 --- a/base/comm/psb_egather_a.f90 +++ b/base/comm/psb_egather_a.f90 @@ -60,7 +60,7 @@ subroutine psb_egatherm(globx, locx, desc_a, info, iroot) type(psb_ctxt_type) :: ctxt integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& - & maxk, k, jlx, ilx, i, j, loc_rows + & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx character(len=20) :: name, ch_err @@ -232,11 +232,11 @@ subroutine psb_egatherv(globx, locx, desc_a, info, iroot) ! locals type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx - integer(psb_mpk_), allocatable :: szs(:) + character(len=20) :: name, ch_err name='psb_egatherv' @@ -307,32 +307,23 @@ subroutine psb_egatherv(globx, locx, desc_a, info, iroot) goto 9999 end if + globx(:)=ezero + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx) = locx(i) + end do + ! 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) - locx(idx) = ezero + call psb_loc_to_glob(idx,desc_a,info) + globx(idx) = ezero end if end do - loc_rows = desc_a%get_local_rows() - if ((me == root).or.(root == -1)) then - allocate(szs(np)) - end if - 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,locx(1:loc_rows),globx,szs,root=root) + + call psb_sum(ctxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return diff --git a/base/comm/psb_i2gather_a.f90 b/base/comm/psb_i2gather_a.f90 index f0f2a93a7..e0e1ed7a7 100644 --- a/base/comm/psb_i2gather_a.f90 +++ b/base/comm/psb_i2gather_a.f90 @@ -60,7 +60,7 @@ subroutine psb_i2gatherm(globx, locx, desc_a, info, iroot) type(psb_ctxt_type) :: ctxt integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& - & maxk, k, jlx, ilx, i, j, loc_rows + & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx character(len=20) :: name, ch_err @@ -232,11 +232,11 @@ subroutine psb_i2gatherv(globx, locx, desc_a, info, iroot) ! locals type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx - integer(psb_mpk_), allocatable :: szs(:) + character(len=20) :: name, ch_err name='psb_i2gatherv' @@ -307,32 +307,23 @@ subroutine psb_i2gatherv(globx, locx, desc_a, info, iroot) goto 9999 end if + globx(:)=i2zero + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx) = locx(i) + end do + ! 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) - locx(idx) = i2zero + call psb_loc_to_glob(idx,desc_a,info) + globx(idx) = i2zero end if end do - loc_rows = desc_a%get_local_rows() - if ((me == root).or.(root == -1)) then - allocate(szs(np)) - end if - 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,locx(1:loc_rows),globx,szs,root=root) + + call psb_sum(ctxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return diff --git a/base/comm/psb_mgather_a.f90 b/base/comm/psb_mgather_a.f90 index ccf2f0c00..df574ea29 100644 --- a/base/comm/psb_mgather_a.f90 +++ b/base/comm/psb_mgather_a.f90 @@ -60,7 +60,7 @@ subroutine psb_mgatherm(globx, locx, desc_a, info, iroot) type(psb_ctxt_type) :: ctxt integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& - & maxk, k, jlx, ilx, i, j, loc_rows + & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx character(len=20) :: name, ch_err @@ -232,11 +232,11 @@ subroutine psb_mgatherv(globx, locx, desc_a, info, iroot) ! locals type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx - integer(psb_mpk_), allocatable :: szs(:) + character(len=20) :: name, ch_err name='psb_mgatherv' @@ -307,32 +307,23 @@ subroutine psb_mgatherv(globx, locx, desc_a, info, iroot) goto 9999 end if + globx(:)=mzero + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx) = locx(i) + end do + ! 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) - locx(idx) = mzero + call psb_loc_to_glob(idx,desc_a,info) + globx(idx) = mzero end if end do - loc_rows = desc_a%get_local_rows() - if ((me == root).or.(root == -1)) then - allocate(szs(np)) - end if - 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,locx(1:loc_rows),globx,szs,root=root) + + call psb_sum(ctxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return diff --git a/base/comm/psb_sgather_a.f90 b/base/comm/psb_sgather_a.f90 index 27e21e785..28d5f5dca 100644 --- a/base/comm/psb_sgather_a.f90 +++ b/base/comm/psb_sgather_a.f90 @@ -60,7 +60,7 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) type(psb_ctxt_type) :: ctxt integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& - & maxk, k, jlx, ilx, i, j, loc_rows + & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx character(len=20) :: name, ch_err @@ -232,11 +232,11 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) ! locals type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx - integer(psb_mpk_), allocatable :: szs(:) + character(len=20) :: name, ch_err name='psb_sgatherv' @@ -307,32 +307,23 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) goto 9999 end if + globx(:)=szero + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx) = locx(i) + end do + ! 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) - locx(idx) = szero + call psb_loc_to_glob(idx,desc_a,info) + globx(idx) = szero end if end do - loc_rows = desc_a%get_local_rows() - if ((me == root).or.(root == -1)) then - allocate(szs(np)) - end if - 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,locx(1:loc_rows),globx,szs,root=root) + + call psb_sum(ctxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return diff --git a/base/comm/psb_zgather_a.f90 b/base/comm/psb_zgather_a.f90 index 98ed87724..fa5f288b5 100644 --- a/base/comm/psb_zgather_a.f90 +++ b/base/comm/psb_zgather_a.f90 @@ -60,7 +60,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) type(psb_ctxt_type) :: ctxt integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& - & maxk, k, jlx, ilx, i, j, loc_rows + & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx character(len=20) :: name, ch_err @@ -232,11 +232,11 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) ! locals type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank, loc_rows + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx - integer(psb_mpk_), allocatable :: szs(:) + character(len=20) :: name, ch_err name='psb_zgatherv' @@ -307,32 +307,23 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) goto 9999 end if + globx(:)=zzero + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx) = locx(i) + end do + ! 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) - locx(idx) = zzero + call psb_loc_to_glob(idx,desc_a,info) + globx(idx) = zzero end if end do - loc_rows = desc_a%get_local_rows() - if ((me == root).or.(root == -1)) then - allocate(szs(np)) - end if - 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,locx(1:loc_rows),globx,szs,root=root) + + call psb_sum(ctxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return From d718ef1e6dcb9ef39bab4c2418da799b2120ea97 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 7 Nov 2023 10:56:23 +0100 Subject: [PATCH 63/63] Always allocate szs in psb_gather --- base/comm/psb_cgather.f90 | 4 +--- base/comm/psb_dgather.f90 | 4 +--- base/comm/psb_igather.f90 | 4 +--- base/comm/psb_lgather.f90 | 4 +--- base/comm/psb_sgather.f90 | 4 +--- base/comm/psb_zgather.f90 | 4 +--- 6 files changed, 6 insertions(+), 18 deletions(-) diff --git a/base/comm/psb_cgather.f90 b/base/comm/psb_cgather.f90 index fc7ba7fb8..bc5302f56 100644 --- a/base/comm/psb_cgather.f90 +++ b/base/comm/psb_cgather.f90 @@ -136,9 +136,7 @@ subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot) end if end do - if ((me == root).or.(root == -1)) then - allocate(szs(np)) - end if + 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 diff --git a/base/comm/psb_dgather.f90 b/base/comm/psb_dgather.f90 index a12be1e45..ed0591e81 100644 --- a/base/comm/psb_dgather.f90 +++ b/base/comm/psb_dgather.f90 @@ -136,9 +136,7 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot) end if end do - if ((me == root).or.(root == -1)) then - allocate(szs(np)) - end if + 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 diff --git a/base/comm/psb_igather.f90 b/base/comm/psb_igather.f90 index 62a84173a..acfdf52aa 100644 --- a/base/comm/psb_igather.f90 +++ b/base/comm/psb_igather.f90 @@ -136,9 +136,7 @@ subroutine psb_igather_vect(globx, locx, desc_a, info, iroot) end if end do - if ((me == root).or.(root == -1)) then - allocate(szs(np)) - end if + 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 diff --git a/base/comm/psb_lgather.f90 b/base/comm/psb_lgather.f90 index 7b4e7ac9a..17359bce8 100644 --- a/base/comm/psb_lgather.f90 +++ b/base/comm/psb_lgather.f90 @@ -136,9 +136,7 @@ subroutine psb_lgather_vect(globx, locx, desc_a, info, iroot) end if end do - if ((me == root).or.(root == -1)) then - allocate(szs(np)) - end if + 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 diff --git a/base/comm/psb_sgather.f90 b/base/comm/psb_sgather.f90 index 30d25440b..59cecc175 100644 --- a/base/comm/psb_sgather.f90 +++ b/base/comm/psb_sgather.f90 @@ -136,9 +136,7 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot) end if end do - if ((me == root).or.(root == -1)) then - allocate(szs(np)) - end if + 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 diff --git a/base/comm/psb_zgather.f90 b/base/comm/psb_zgather.f90 index d60f15c66..5cf445a9b 100644 --- a/base/comm/psb_zgather.f90 +++ b/base/comm/psb_zgather.f90 @@ -136,9 +136,7 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot) end if end do - if ((me == root).or.(root == -1)) then - allocate(szs(np)) - end if + 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