From af5b65606c886f482cf360d4818452931f7b60c7 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 12 Jan 2007 09:15:20 +0000 Subject: [PATCH] Second step of major reorg: tested compilation. --- Changelog | 9 + Make.inc | 26 +- Make.inc.gcc42 | 32 +- Make.inc.ifc9 | 36 +- Make.inc.rs6k | 26 +- Makefile | 17 +- base/Makefile | 27 + base/comm/Makefile | 5 +- base/internals/Makefile | 5 +- base/internals/psi_crea_index.f90 | 28 +- base/internals/psi_gthsct.f90 | 2 +- base/modules/Makefile | 19 +- .../{psb_sparse_mod.f90 => psb_base_mod.f90} | 13 +- base/modules/psb_const_mod.f90 | 6 +- base/modules/psb_desc_type.f90 | 86 - base/modules/psb_error_mod.f90 | 2 - base/modules/psb_serial_mod.f90 | 683 ++++--- base/modules/psb_tools_mod.f90 | 24 +- base/modules/psi_mod.f90 | 26 +- base/psblas/Makefile | 6 +- base/serial/Makefile | 14 +- base/serial/aux/Makefile | 7 +- base/serial/coo/Makefile | 7 +- base/serial/csr/Makefile | 7 +- base/serial/dp/Makefile | 6 +- base/serial/f77/Makefile | 6 +- base/serial/jad/Makefile | 6 +- base/serial/psb_dcsdp.f90 | 10 +- base/serial/psb_dcsprt.f90 | 2 +- base/serial/psb_dnumbmm.f90 | 16 +- base/serial/psb_dspgetrow.f90 | 23 +- base/serial/psb_dspgtdiag.f90 | 18 +- base/serial/psb_dsymbmm.f90 | 15 +- base/serial/psb_zcsdp.f90 | 10 +- base/serial/psb_znumbmm.f90 | 16 +- base/serial/psb_zspgetrow.f90 | 23 +- base/serial/psb_zspgtdiag.f90 | 18 +- base/serial/psb_zsymbmm.f90 | 15 +- base/tools/Makefile | 7 +- base/tools/psb_cdall.f90 | 285 +-- base/tools/psb_cdalv.f90 | 3 +- base/tools/psb_cdasb.f90 | 10 - base/tools/psb_cddec.f90 | 142 +- base/tools/psb_cdren.f90 | 19 +- base/tools/psb_dcdovr.f90 | 856 ++++----- base/tools/psb_dcsrp.f90 | 35 +- base/tools/psb_dgelp.f90 | 17 + base/tools/psb_dins.f90 | 10 + base/tools/psb_dspcnv.f90 | 96 +- base/tools/psb_dsphalo.f90 | 1 - base/tools/psb_dspins.f90 | 22 +- base/tools/psb_get_overlap.f90 | 34 +- base/tools/psb_glob_to_loc.f90 | 221 ++- base/tools/psb_iins.f90 | 10 + base/tools/psb_loc_to_glob.f90 | 8 +- base/tools/psb_zcdovr.f90 | 872 ++++----- base/tools/psb_zcsrp.f90 | 28 +- base/tools/psb_zgelp.f90 | 18 +- base/tools/psb_zins.f90 | 10 + base/tools/psb_zspcnv.f90 | 176 +- base/tools/psb_zsphalo.f90 | 1 - base/tools/psb_zspins.f90 | 21 + krylov/Makefile | 24 +- krylov/psb_dbicg.f90 | 9 +- krylov/psb_dcg.f90 | 9 +- krylov/psb_dcgs.f90 | 9 +- krylov/psb_dcgstab.f90 | 9 +- krylov/psb_dcgstabl.f90 | 9 +- krylov/psb_dgmresr.f90 | 9 +- .../psb_krylov_mod.f90 | 78 +- krylov/psb_zcgs.f90 | 9 +- krylov/psb_zcgstab.f90 | 12 +- mld2p4/LICENSE.MD2P4 | 33 + mld2p4/Makefile | 37 +- mld2p4/psb_dasmatbld.f90 | 9 +- mld2p4/psb_dbaseprc_aply.f90 | 21 +- mld2p4/psb_dbaseprc_bld.f90 | 62 +- mld2p4/psb_dbjac_aply.f90 | 13 +- mld2p4/psb_dbldaggrmat.f90 | 37 +- mld2p4/psb_ddiagsc_bld.f90 | 11 +- mld2p4/psb_dgenaggrmap.f90 | 7 +- mld2p4/psb_dilu_bld.f90 | 60 +- mld2p4/psb_dilu_fct.f90 | 6 +- mld2p4/psb_dmlprc_aply.f90 | 23 +- mld2p4/psb_dmlprc_bld.f90 | 45 +- mld2p4/psb_dprc_aply.f90 | 65 +- mld2p4/psb_dprecbld.f90 | 29 +- mld2p4/psb_dprecfree.f90 | 9 +- mld2p4/psb_dprecset.f90 | 4 +- mld2p4/psb_dslu_bld.f90 | 31 +- mld2p4/psb_dsp_renum.f90 | 10 +- mld2p4/psb_dumf_bld.f90 | 28 +- {base/modules => mld2p4}/psb_prec_mod.f90 | 149 +- {base/modules => mld2p4}/psb_prec_type.f90 | 33 +- mld2p4/psb_umf_impl.c | 3 +- mld2p4/psb_zasmatbld.f90 | 9 +- mld2p4/psb_zbaseprc_aply.f90 | 23 +- mld2p4/psb_zbaseprc_bld.f90 | 57 +- mld2p4/psb_zbjac_aply.f90 | 7 +- mld2p4/psb_zbldaggrmat.f90 | 39 +- mld2p4/psb_zdiagsc_bld.f90 | 10 +- mld2p4/psb_zgenaggrmap.f90 | 7 +- mld2p4/psb_zilu_bld.f90 | 59 +- mld2p4/psb_zilu_fct.f90 | 7 +- mld2p4/psb_zmlprc_aply.f90 | 23 +- mld2p4/psb_zmlprc_bld.f90 | 46 +- mld2p4/psb_zprc_aply.f90 | 70 +- mld2p4/psb_zprecbld.f90 | 12 +- mld2p4/psb_zprecfree.f90 | 7 +- mld2p4/psb_zprecset.f90 | 4 +- mld2p4/psb_zslu_bld.f90 | 28 +- mld2p4/psb_zsp_renum.f90 | 17 +- mld2p4/psb_zumf_bld.f90 | 28 +- mld2p4/psb_zumf_impl.c | 6 +- util/Makefile | 33 + util/psb_blockpart_mod.f90 | 73 + util/psb_graphpart_mod.f90 | 222 +++ util/psb_hbio_mod.f90 | 638 +++++++ util/psb_mat_dist_mod.f90 | 1584 +++++++++++++++++ util/psb_mmio_mod.f90 | 379 ++++ util/psb_read_mat_mod.f90 | 253 +++ .../psb_all_mod.f90 => util/psb_util_mod.f90 | 27 +- 122 files changed, 6119 insertions(+), 2650 deletions(-) create mode 100644 base/Makefile rename base/modules/{psb_sparse_mod.f90 => psb_base_mod.f90} (94%) rename base/modules/psb_methd_mod.f90 => krylov/psb_krylov_mod.f90 (88%) create mode 100644 mld2p4/LICENSE.MD2P4 rename {base/modules => mld2p4}/psb_prec_mod.f90 (87%) rename {base/modules => mld2p4}/psb_prec_type.f90 (98%) create mode 100644 util/Makefile create mode 100644 util/psb_blockpart_mod.f90 create mode 100644 util/psb_graphpart_mod.f90 create mode 100644 util/psb_hbio_mod.f90 create mode 100644 util/psb_mat_dist_mod.f90 create mode 100644 util/psb_mmio_mod.f90 create mode 100644 util/psb_read_mat_mod.f90 rename base/modules/psb_all_mod.f90 => util/psb_util_mod.f90 (84%) diff --git a/Changelog b/Changelog index e1fe3954..db182a03 100644 --- a/Changelog +++ b/Changelog @@ -1,6 +1,15 @@ Changelog. A lot less detailed than usual, at least for past history. + +2007/01/11: Migrated repository to SVN. + +2007/01/11: MLD2P4 has been moved to the new org. Now tackling the + test dirs. + +2007/01/09: First try at reorganizing directories. Subdir MLD2P4 still + to be fixed. Documentation still to be updated. + 2006/12/11: Documented options in glob_to_loc. 2006/12/06: Fixed raw aggregation. diff --git a/Make.inc b/Make.inc index 37d8d136..87269cd9 100644 --- a/Make.inc +++ b/Make.inc @@ -40,6 +40,12 @@ SLUDEF=-DHave_SLU_ -I$(SLUDIR) UMFDIR=$(HOME)/LIB/Umfpack_gcc41 UMF=-lumfpack -lamd -L$(UMFDIR) UMFDEF=-DHave_UMF_ -I$(UMFDIR) +# +# We are using the public domain tool METIS from U. Minnesota. To get it +# check URL http://www.cs.umn.edu:~karypis +# +METIS_LIB = -L$(HOME)/NUMERICAL/metis-4.0 -lmetis +LDLIBS=$(BLACS) $(SLU) $(UMF) $(BLAS) $(METIS_LIB) # Add -DLargeFptr for 64-bit addresses CDEFINES=-DAdd_ $(SLUDEF) $(UMFDEF) @@ -53,21 +59,11 @@ RANLIB=ranlib ####################### Section 5 ####################### # Do not edit this # ########################################################## -LIBDIR = lib -LIBNAME = libpsblas.a - -TYPEMODS = psb_spmat_type$(.mod) psb_descriptor_type$(.mod) psb_prec_type$(.mod) psb_realloc_mod$(.mod) -CONSTMODS = psb_const_mod$(.mod) -BLASMODS = $(TYPEMODS) psb_psblas_mod$(.mod) psb_comm_mod$(.mod) -METHDMODS = psb_methd_mod$(.mod) -TOOLSMODS = $(CONSTMODS) psi_mod$(.mod) psb_tools_mod$(.mod) psb_serial_mod$(.mod) -PRECMODS = psb_prec_mod$(.mod) -ERRORMODS = psb_error_mod$(.mod) -F90MODS= $(BLASMODS) $(PRECMODS) $(METHDMODS) $(TOOLSMODS) $(ERRORMODS) string$(.mod) - -MODS=$(LIBDIR)/psb_const_mod$(.mod) $(LIBDIR)/psb_spmat_type$(.mod) $(LIBDIR)/psb_realloc_mod$(.mod) \ - $(LIBDIR)/psb_descriptor_type$(.mod) $(LIBDIR)/psb_prec_type$(.mod) $(LIBDIR)/parts.fh \ - $(LIBDIR)/psb_serial_mod$(.mod) $(LIBDIR)/psb_comm_mod$(.mod) $(LIBDIR)/psb_error_mod$(.mod) +LIBDIR=lib +BASELIBNAME=libpsb_base.a +PRECLIBNAME=libpsb_prec.a +METHDLIBNAME=libpsb_krylov.a +UTILLIBNAME=libpsb_util.a # Under Linux/gmake there is a rule interpreting .mod as Modula source! $(.mod).o: diff --git a/Make.inc.gcc42 b/Make.inc.gcc42 index a5441ee5..87269cd9 100644 --- a/Make.inc.gcc42 +++ b/Make.inc.gcc42 @@ -10,9 +10,9 @@ F90=/usr/local/gcc42/bin/gfortran FC=/usr/local/gcc42/bin/gfortran F77=$(FC) CC=/usr/local/gcc42/bin/gcc -F90COPT= -O3 -march=pentium4 -msse2 -mfpmath=sse -FCOPT=-O3 -march=pentium4 -msse2 -mfpmath=sse -CCOPT=-O3 -march=pentium4 -msse2 -mfpmath=sse +F90COPT=-O3 -ggdb +FCOPT=-O3 -ggdb +CCOPT=-O3 -ggdb ####################### Section 2 ####################### # Define your linker and linker flags here # @@ -40,6 +40,12 @@ SLUDEF=-DHave_SLU_ -I$(SLUDIR) UMFDIR=$(HOME)/LIB/Umfpack_gcc41 UMF=-lumfpack -lamd -L$(UMFDIR) UMFDEF=-DHave_UMF_ -I$(UMFDIR) +# +# We are using the public domain tool METIS from U. Minnesota. To get it +# check URL http://www.cs.umn.edu:~karypis +# +METIS_LIB = -L$(HOME)/NUMERICAL/metis-4.0 -lmetis +LDLIBS=$(BLACS) $(SLU) $(UMF) $(BLAS) $(METIS_LIB) # Add -DLargeFptr for 64-bit addresses CDEFINES=-DAdd_ $(SLUDEF) $(UMFDEF) @@ -53,21 +59,11 @@ RANLIB=ranlib ####################### Section 5 ####################### # Do not edit this # ########################################################## -LIBDIR = lib -LIBNAME = libpsblas.a - -TYPEMODS = psb_spmat_type$(.mod) psb_descriptor_type$(.mod) psb_prec_type$(.mod) psb_realloc_mod$(.mod) -CONSTMODS = psb_const_mod$(.mod) -BLASMODS = $(TYPEMODS) psb_psblas_mod$(.mod) psb_comm_mod$(.mod) -METHDMODS = psb_methd_mod$(.mod) -TOOLSMODS = $(CONSTMODS) psi_mod$(.mod) psb_tools_mod$(.mod) psb_serial_mod$(.mod) -PRECMODS = psb_prec_mod$(.mod) -ERRORMODS = psb_error_mod$(.mod) -F90MODS= $(BLASMODS) $(PRECMODS) $(METHDMODS) $(TOOLSMODS) $(ERRORMODS) string$(.mod) - -MODS=$(LIBDIR)/psb_const_mod$(.mod) $(LIBDIR)/psb_spmat_type$(.mod) $(LIBDIR)/psb_realloc_mod$(.mod) \ - $(LIBDIR)/psb_descriptor_type$(.mod) $(LIBDIR)/psb_prec_type$(.mod) $(LIBDIR)/parts.fh \ - $(LIBDIR)/psb_serial_mod$(.mod) $(LIBDIR)/psb_comm_mod$(.mod) $(LIBDIR)/psb_error_mod$(.mod) +LIBDIR=lib +BASELIBNAME=libpsb_base.a +PRECLIBNAME=libpsb_prec.a +METHDLIBNAME=libpsb_krylov.a +UTILLIBNAME=libpsb_util.a # Under Linux/gmake there is a rule interpreting .mod as Modula source! $(.mod).o: diff --git a/Make.inc.ifc9 b/Make.inc.ifc9 index bd68933f..7f319174 100644 --- a/Make.inc.ifc9 +++ b/Make.inc.ifc9 @@ -18,11 +18,11 @@ CCOPT=-O3 ####################### Section 2 ####################### # Define your linker and linker flags here # ########################################################## -F90LINK=/usr/local/mpich-ifc91/bin/mpif90 -g -CB -no_cpprt -FLINK=/usr/local/mpich-ifc91/bin/mpif77 -g -CB -no_cpprt -MPF90=/usr/local/mpich-ifc91/bin/mpif90 -g -CB -no_cpprt -MPF77=/usr/local/mpich-ifc91/bin/mpif77 -g -CB -no_cpprt -MPCC=/usr/local/mpich-ifc91/bin/mpicc -g -CB -no_cpprt +F90LINK=/usr/local/mpich-ifc91/bin/mpif90 +FLINK=/usr/local/mpich-ifc91/bin/mpif77 +MPF90=/usr/local/mpich-ifc91/bin/mpif90 +MPF77=/usr/local/mpich-ifc91/bin/mpif77 +MPCC=/usr/local/mpich-ifc91/bin/mpicc ####################### Section 3 ####################### # Specify paths to libraries # @@ -42,6 +42,12 @@ SLUDEF=-DHave_SLU_ -I$(SLUDIR) UMFDIR=$(HOME)/LIB/Umfpack_gcc41 UMF=-lumfpack -lamd -L$(UMFDIR) UMFDEF=-DHave_UMF_ -I$(UMFDIR) +# +# We are using the public domain tool METIS from U. Minnesota. To get it +# check URL http://www.cs.umn.edu:~karypis +# +METIS_LIB = -L$(HOME)/NUMERICAL/metis-4.0 -lmetis +LDLIBS=$(BLACS) $(SLU) $(UMF) $(BLAS) $(METIS_LIB) # Add -DLargeFptr for 64-bit addresses CDEFINES=-DAdd_ $(SLUDEF) $(UMFDEF) @@ -55,21 +61,11 @@ RANLIB=ranlib ####################### Section 5 ####################### # Do not edit this # ########################################################## -LIBDIR = lib -LIBNAME = libpsblas.a - -TYPEMODS = psb_spmat_type$(.mod) psb_descriptor_type$(.mod) psb_prec_type$(.mod) psb_realloc_mod$(.mod) -CONSTMODS = psb_const_mod$(.mod) -BLASMODS = $(TYPEMODS) psb_psblas_mod$(.mod) psb_comm_mod$(.mod) -METHDMODS = psb_methd_mod$(.mod) -TOOLSMODS = $(CONSTMODS) psi_mod$(.mod) psb_tools_mod$(.mod) psb_serial_mod$(.mod) -PRECMODS = psb_prec_mod$(.mod) -ERRORMODS = psb_error_mod$(.mod) -F90MODS= $(BLASMODS) $(PRECMODS) $(METHDMODS) $(TOOLSMODS) $(ERRORMODS) string$(.mod) - -MODS=$(LIBDIR)/psb_const_mod$(.mod) $(LIBDIR)/psb_spmat_type$(.mod) $(LIBDIR)/psb_realloc_mod$(.mod) \ - $(LIBDIR)/psb_descriptor_type$(.mod) $(LIBDIR)/psb_prec_type$(.mod) $(LIBDIR)/parts.fh \ - $(LIBDIR)/psb_serial_mod$(.mod) $(LIBDIR)/psb_comm_mod$(.mod) $(LIBDIR)/psb_error_mod$(.mod) +LIBDIR=lib +BASELIBNAME=libpsb_base.a +PRECLIBNAME=libpsb_prec.a +METHDLIBNAME=libpsb_krylov.a +UTILLIBNAME=libpsb_util.a # Under Linux/gmake there is a rule interpreting .mod as Modula source! $(.mod).o: diff --git a/Make.inc.rs6k b/Make.inc.rs6k index 32b67bd4..b7b8d832 100644 --- a/Make.inc.rs6k +++ b/Make.inc.rs6k @@ -40,6 +40,12 @@ BLACS=-lmpiblacs #UMFDIR=$(HOME)/LIB/Umfpack #UMF=-lumfpack -lamd -L$(UMFDIR) #UMFDEF=-DHave_UMF_ -I$(UMFDIR) +# +# We are using the public domain tool METIS from U. Minnesota. To get it +# check URL http://www.cs.umn.edu:~karypis +# +METIS_LIB = -L$(HOME)/NUMERICAL/metis-4.0 -lmetis +LDLIBS=$(BLACS) $(SLU) $(UMF) $(BLAS) $(METIS_LIB) # Add -DLargeFptr for 64-bit addresses CDEFINES=-DNoChange $(SLUDEF) $(UMFDEF) -DLargeFptr @@ -53,21 +59,11 @@ RANLIB=ranlib ####################### Section 5 ####################### # Do not edit this # ########################################################## -LIBDIR = lib -LIBNAME = libpsblas.a - -TYPEMODS = psb_spmat_type$(.mod) psb_descriptor_type$(.mod) psb_prec_type$(.mod) psb_realloc_mod$(.mod) -CONSTMODS = psb_const_mod$(.mod) -BLASMODS = $(TYPEMODS) psb_psblas_mod$(.mod) psb_comm_mod$(.mod) -METHDMODS = psb_methd_mod$(.mod) -TOOLSMODS = $(CONSTMODS) psi_mod$(.mod) psb_tools_mod$(.mod) psb_serial_mod$(.mod) -PRECMODS = psb_prec_mod$(.mod) -ERRORMODS = psb_error_mod$(.mod) -F90MODS= $(BLASMODS) $(PRECMODS) $(METHDMODS) $(TOOLSMODS) $(ERRORMODS) string$(.mod) - -MODS=$(LIBDIR)/psb_const_mod$(.mod) $(LIBDIR)/psb_spmat_type$(.mod) $(LIBDIR)/psb_realloc_mod$(.mod) \ - $(LIBDIR)/psb_descriptor_type$(.mod) $(LIBDIR)/psb_prec_type$(.mod) $(LIBDIR)/parts.fh \ - $(LIBDIR)/psb_serial_mod$(.mod) $(LIBDIR)/psb_comm_mod$(.mod) $(LIBDIR)/psb_error_mod$(.mod) +LIBDIR=lib +BASELIBNAME=libpsb_base.a +PRECLIBNAME=libpsb_prec.a +METHDLIBNAME=libpsb_krylov.a +UTILLIBNAME=libpsb_util.a # Under Linux/gmake there is a rule interpreting .mod as Modula source! $(.mod).o: diff --git a/Makefile b/Makefile index 7f35ee2f..ca2ea2f5 100644 --- a/Makefile +++ b/Makefile @@ -1,18 +1,29 @@ include Make.inc +#PREC=mld2p4 +PREC=baseprec library: ( [ -d lib ] || mkdir lib) - (cd src; make lib) + (cd base; make lib) + (cd $(PREC); make lib ) + (cd krylov; make lib) + (cd util; make lib ) @echo "=====================================" @echo "Compilation Successful." @echo "You can now link to ./lib/libpsblas.a" clean: - (cd src; make clean) + (cd base; make clean) + (cd $(PREC); make clean ) + (cd krylov; make clean) + (cd util; make clean) cleanlib: (cd lib; /bin/rm -f *.a *$(.mod) *$(.fh)) veryclean: cleanlib - (cd src; make veryclean) + (cd base; make veryclean) + (cd $(PREC); make veryclean ) + (cd krylov; make veryclean) + (cd util; make veryclean) .PHONY: lib diff --git a/base/Makefile b/base/Makefile new file mode 100644 index 00000000..6c36db68 --- /dev/null +++ b/base/Makefile @@ -0,0 +1,27 @@ +include ../Make.inc + +HERE=. +LIBDIR=../lib +LIBNAME=$(BASELIBNAME) +LIBMOD=psb_base_mod$(.mod) +lib: + (cd modules; make lib LIBNAME=$(BASELIBNAME)) + (cd comm; make lib LIBNAME=$(BASELIBNAME)) + (cd internals; make lib LIBNAME=$(BASELIBNAME)) + (cd tools; make lib LIBNAME=$(BASELIBNAME)) + (cd serial; make lib LIBNAME=$(BASELIBNAME)) + (cd psblas; make lib LIBNAME=$(BASELIBNAME)) + /bin/cp $(HERE)/$(LIBNAME) $(LIBDIR) + /bin/cp $(LIBMOD) $(LIBDIR) + +clean: + (cd modules; make clean) + (cd comm; make clean) + (cd internals; make clean) + (cd tools; make clean) + (cd serial; make clean) + (cd psblas; make clean) + +veryclean: clean + /bin/rm -f $(HERE)/$(LIBNAME) $(LIBMOD) + \ No newline at end of file diff --git a/base/comm/Makefile b/base/comm/Makefile index ebf456aa..5b6b5786 100644 --- a/base/comm/Makefile +++ b/base/comm/Makefile @@ -4,8 +4,9 @@ OBJS = psb_dgather.o psb_dhalo.o psb_dovrl.o \ psb_ihalo.o psb_zgather.o psb_zhalo.o psb_zovrl.o MPFOBJS = psb_dscatter.o psb_zscatter.o -INCDIRS = -I ../../lib -I . -LIBDIR = ../../lib +LIBDIR = .. +MODDIR = ../modules +INCDIRS = -I $(LIBDIR) -I $(MODDIR) -I . lib: mpfobjs $(OBJS) $(AR) $(LIBDIR)/$(LIBNAME) $(MPFOBJS) $(OBJS) diff --git a/base/internals/Makefile b/base/internals/Makefile index ecab9a09..b6d1b06b 100644 --- a/base/internals/Makefile +++ b/base/internals/Makefile @@ -13,8 +13,9 @@ MPFOBJS = psi_dswapdata.o psi_dswaptran.o psi_iswapdata.o \ psi_iswaptran.o psi_desc_index.o \ psi_zswapdata.o psi_zswaptran.o MPFOBJS2 = psi_extrct_dl.o -INCDIRS = -I ../../lib -I . -LIBDIR = ../../lib +LIBDIR = .. +MODDIR = ../modules +INCDIRS = -I $(LIBDIR) -I $(MODDIR) -I . lib: mpfobjs $(FOBJS) $(FOBJS2) $(COBJS) $(MPFOBJS2) $(AR) $(LIBDIR)/$(LIBNAME) $(MPFOBJS) $(MPFOBJS2) $(FOBJS) $(FOBJS2) \ diff --git a/base/internals/psi_crea_index.f90 b/base/internals/psi_crea_index.f90 index 98e4462d..388492d0 100644 --- a/base/internals/psi_crea_index.f90 +++ b/base/internals/psi_crea_index.f90 @@ -34,7 +34,6 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info use psb_descriptor_type use psb_error_mod use psb_penv_mod - use psi_mod, only: psi_sort_dl, psi_desc_index, psi_dl_check implicit none type(psb_desc_type), intent(in) :: desc_a @@ -51,6 +50,33 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info logical,parameter :: debug=.false. character(len=20) :: name + + interface + subroutine psi_sort_dl(dep_list,l_dep_list,np,info) + integer :: np,dep_list(:,:), l_dep_list(:), info + end subroutine psi_sort_dl + end interface + + interface + subroutine psi_dl_check(dep_list,dl_lda,np,length_dl) + integer :: np,dl_lda,length_dl(0:np) + integer :: dep_list(dl_lda,0:np) + end subroutine psi_dl_check + end interface + + interface + subroutine psi_desc_index(desc,index_in,dep_list,& + & length_dl,nsnd,nrcv,desc_index,& + & isglob_in,info) + use psb_descriptor_type + type(psb_desc_type) :: desc + integer :: index_in(:),dep_list(:) + integer, allocatable :: desc_index(:) + integer :: length_dl,nsnd,nrcv,info + logical :: isglob_in + end subroutine psi_desc_index + end interface + info = 0 name='psi_crea_index' call psb_erractionsave(err_act) diff --git a/base/internals/psi_gthsct.f90 b/base/internals/psi_gthsct.f90 index 00d78171..d52cce9a 100644 --- a/base/internals/psi_gthsct.f90 +++ b/base/internals/psi_gthsct.f90 @@ -122,7 +122,7 @@ contains implicit none - integer :: n, idx(:) + integer :: n, k, idx(:) real(kind(1.d0)) :: beta, x(:), y(:) ! Locals diff --git a/base/modules/Makefile b/base/modules/Makefile index 023a6e76..991a7af6 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -3,18 +3,19 @@ include ../../Make.inc MODULES = psb_realloc_mod.o psb_string_mod.o psb_spmat_type.o \ psb_desc_type.o psb_spsb_mod.o \ psb_serial_mod.o psb_tools_mod.o \ - psb_prec_type.o psb_error_mod.o psb_prec_mod.o \ - psb_methd_mod.o psb_const_mod.o \ + psb_error_mod.o \ + psb_const_mod.o \ psb_comm_mod.o psb_psblas_mod.o psi_mod.o \ psb_check_mod.o blacs_env.o psb_gps_mod.o +# psb_methd_mod.o psb_prec_type.o psb_prec_mod.o -MPFOBJS = psb_penv_mod.o +LIBMOD=psb_base_mod$(.mod) +MPFOBJS=psb_penv_mod.o +OBJS = error.o psb_base_mod.o +LIBDIR = .. +INCDIRS = -I . -OBJS = error.o psb_sparse_mod.o psb_all_mod.o - -INCDIRS = -I ../../lib -LIBDIR = ../../lib psb_realloc_mod.o : psb_error_mod.o psb_spmat_type.o : psb_realloc_mod.o psb_const_mod.o psb_string_mod.o @@ -26,13 +27,13 @@ psb_check_mod.o: psb_desc_type.o psb_methd_mod.o: psb_serial_mod.o psb_desc_type.o psb_prec_type.o psb_tools_mod.o: psb_spmat_type.o psb_desc_type.o psi_mod.o psb_gps_mod.o psb_gps_mod.o: psb_realloc_mod.o -psb_sparse_mod.o: $(MODULES) $(MPFOBJS) +psb_base_mod.o: $(MODULES) $(MPFOBJS) lib: mpfobjs $(MODULES) $(OBJS) $(AR) $(LIBDIR)/$(LIBNAME) $(MODULES) $(OBJS) $(MPFOBJS) $(RANLIB) $(LIBDIR)/$(LIBNAME) - /bin/cp *$(.mod) ./parts.fh ../../lib + /bin/cp $(LIBMOD) ./parts.fh $(LIBDIR) mpfobjs: diff --git a/base/modules/psb_sparse_mod.f90 b/base/modules/psb_base_mod.f90 similarity index 94% rename from base/modules/psb_sparse_mod.f90 rename to base/modules/psb_base_mod.f90 index 8d8db5f6..77130c3f 100644 --- a/base/modules/psb_sparse_mod.f90 +++ b/base/modules/psb_base_mod.f90 @@ -28,18 +28,15 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -module psb_sparse_mod +module psb_base_mod + use psb_string_mod + use psb_error_mod use psb_penv_mod use psb_descriptor_type - use psb_prec_type use psb_serial_mod - use psb_tools_mod use psb_psblas_mod - use psb_prec_mod - use psb_methd_mod - use psb_error_mod - use psb_string_mod -end module psb_sparse_mod + use psb_tools_mod +end module psb_base_mod diff --git a/base/modules/psb_const_mod.f90 b/base/modules/psb_const_mod.f90 index 9126604c..7ede5c7f 100644 --- a/base/modules/psb_const_mod.f90 +++ b/base/modules/psb_const_mod.f90 @@ -59,15 +59,13 @@ module psb_const_mod integer, parameter :: psb_dec_type_=1, psb_m_=2,psb_n_=3 integer, parameter :: psb_n_row_=4, psb_n_col_=5,psb_ctxt_=6 integer, parameter :: psb_loc_to_glob_=7 - integer, parameter :: psb_ovl_state_=8 - integer, parameter :: psb_mpi_c_=9 integer, parameter :: psb_thal_xch_=11 integer, parameter :: psb_thal_snd_=12 integer, parameter :: psb_thal_rcv_=13 integer, parameter :: psb_tovr_xch_=14 integer, parameter :: psb_tovr_snd_=15 integer, parameter :: psb_tovr_rcv_=16 - integer, parameter :: psb_mdata_size_=20 + integer, parameter :: psb_mpi_c_=9,psb_mdata_size_=20 integer, parameter :: psb_desc_asb_=3099 integer, parameter :: psb_desc_bld_=psb_desc_asb_+1 integer, parameter :: psb_desc_repl_=3199 @@ -75,8 +73,6 @@ module psb_const_mod integer, parameter :: psb_desc_upd_asb_=psb_desc_upd_+1 integer, parameter :: psb_desc_large_asb_=psb_desc_upd_asb_+1 integer, parameter :: psb_desc_large_bld_=psb_desc_large_asb_+1 - integer, parameter :: psb_cd_ovl_bld_=psb_desc_large_bld_+1 - integer, parameter :: psb_cd_ovl_asb_=psb_cd_ovl_bld_+1 integer, parameter :: nbits=14 integer, parameter :: hashsize=2**nbits, hashmask=hashsize-1 integer, parameter :: psb_default_large_threshold=4*1024*1024 ! to be reviewed diff --git a/base/modules/psb_desc_type.f90 b/base/modules/psb_desc_type.f90 index 6253c8da..8d8e0ba0 100644 --- a/base/modules/psb_desc_type.f90 +++ b/base/modules/psb_desc_type.f90 @@ -136,28 +136,6 @@ contains end function psb_is_asb_desc - logical function psb_is_ovl_bld(desc) - type(psb_desc_type), intent(in) :: desc - - psb_is_ovl_bld = (desc%matrix_data(psb_ovl_state_)==psb_cd_ovl_bld_) - - end function psb_is_ovl_bld - - logical function psb_is_ovl_asb(desc) - type(psb_desc_type), intent(in) :: desc - - psb_is_ovl_asb = (desc%matrix_data(psb_ovl_state_)==psb_cd_ovl_asb_) - - end function psb_is_ovl_asb - - logical function psb_is_ovl_ok(desc) - type(psb_desc_type), intent(in) :: desc - - psb_is_ovl_ok = (desc%matrix_data(psb_ovl_state_)==psb_cd_ovl_asb_).or.& - & (desc%matrix_data(psb_ovl_state_)==psb_cd_ovl_bld_) - - end function psb_is_ovl_ok - logical function psb_is_ok_dec(dectype) integer :: dectype @@ -249,69 +227,5 @@ contains end function psb_is_large_dec - subroutine psb_cd_set_bld(desc,info) - ! - ! Change state of a descriptor into BUILD. - ! If the descriptor is LARGE, check the AVL search tree - ! and initialize it if necessary. - ! - use psb_const_mod - use psb_error_mod - use psb_penv_mod - - implicit none - type(psb_desc_type), intent(inout) :: desc - integer :: info - !locals - integer :: np,me,ictxt, isz, err_act,idx,gidx,lidx - logical, parameter :: debug=.false.,debugprt=.false. - character(len=20) :: name, char_err - if (debug) write(0,*) me,'Entered CDCPY' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - name = 'psb_cd_set_bld' - - ictxt = psb_cd_get_context(desc) - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (debug) write(0,*) me,'Entered CDCPY' - - if (psb_is_large_desc(desc)) then - if (.not.allocated(desc%ptree)) then - allocate(desc%ptree(2),stat=info) - if (info /= 0) then - info=4000 - goto 9999 - endif - call InitPairSearchTree(desc%ptree,info) - do idx=1, psb_cd_get_local_cols(desc) - gidx = desc%loc_to_glob(idx) - call SearchInsKeyVal(desc%ptree,gidx,idx,lidx,info) - if (lidx /= idx) then - write(0,*) 'Warning from cdset: mismatch in PTREE ',idx,lidx - endif - enddo - end if - desc%matrix_data(psb_dec_type_) = psb_desc_large_bld_ - - else - desc%matrix_data(psb_dec_type_) = psb_desc_bld_ - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == act_ret) then - return - else - call psb_error(ictxt) - end if - return - end subroutine psb_cd_set_bld end module psb_descriptor_type diff --git a/base/modules/psb_error_mod.f90 b/base/modules/psb_error_mod.f90 index c04c64d4..e8c54926 100644 --- a/base/modules/psb_error_mod.f90 +++ b/base/modules/psb_error_mod.f90 @@ -351,8 +351,6 @@ contains write (0,'("indices in input array are not within problem dimension ",2(i0,2x))')i_e_d(1:2) case(150) write (0,'("indices in input array are not belonging to the calling process ",i0)')i_e_d(1) - case(151) - write (0,'("indices in input array are not belonging to the calling process ")') case(290) write (0,'("To call this routine you must first call psb_geall on the same matrix")') case(295) diff --git a/base/modules/psb_serial_mod.f90 b/base/modules/psb_serial_mod.f90 index 0f674536..6218e35d 100644 --- a/base/modules/psb_serial_mod.f90 +++ b/base/modules/psb_serial_mod.f90 @@ -33,433 +33,394 @@ module psb_serial_mod use psb_string_mod interface psb_csdp - subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl) - use psb_spmat_type - type(psb_dspmat_type), intent(in) :: a - type(psb_dspmat_type), intent(inout) :: b - integer, intent(out) :: info - integer, intent(in), optional :: ifc,upd,dupl - character, intent(in), optional :: check,trans,unitd - end subroutine psb_dcsdp - subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl) - use psb_spmat_type - type(psb_zspmat_type), intent(in) :: a - type(psb_zspmat_type), intent(inout) :: b - integer, intent(out) :: info - integer, intent(in), optional :: ifc,upd,dupl - character, intent(in), optional :: check,trans,unitd - end subroutine psb_zcsdp + subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl) + use psb_spmat_type + type(psb_dspmat_type), intent(in) :: a + type(psb_dspmat_type), intent(inout) :: b + integer, intent(out) :: info + integer, intent(in), optional :: ifc,upd,dupl + character, intent(in), optional :: check,trans,unitd + end subroutine psb_dcsdp + subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl) + use psb_spmat_type + type(psb_zspmat_type), intent(in) :: a + type(psb_zspmat_type), intent(inout) :: b + integer, intent(out) :: info + integer, intent(in), optional :: ifc,upd,dupl + character, intent(in), optional :: check,trans,unitd + end subroutine psb_zcsdp end interface interface psb_csrws - subroutine psb_dcsrws(rw,a,info,trans) - use psb_spmat_type - type(psb_dspmat_type) :: a - real(kind(1.d0)), allocatable :: rw(:) - integer :: info - character, optional :: trans - end subroutine psb_dcsrws - subroutine psb_zcsrws(rw,a,info,trans) - use psb_spmat_type - type(psb_zspmat_type) :: a - complex(kind(1.d0)), allocatable :: rw(:) - integer :: info - character, optional :: trans - end subroutine psb_zcsrws + subroutine psb_dcsrws(rw,a,info,trans) + use psb_spmat_type + type(psb_dspmat_type) :: a + real(kind(1.d0)), allocatable :: rw(:) + integer :: info + character, optional :: trans + end subroutine psb_dcsrws + subroutine psb_zcsrws(rw,a,info,trans) + use psb_spmat_type + type(psb_zspmat_type) :: a + complex(kind(1.d0)), allocatable :: rw(:) + integer :: info + character, optional :: trans + end subroutine psb_zcsrws end interface interface psb_cssm - subroutine psb_dcssm(alpha,t,b,beta,c,info,trans,unitd,d) - use psb_spmat_type - type(psb_dspmat_type) :: t - real(kind(1.d0)) :: alpha, beta, b(:,:), c(:,:) - integer :: info - character, optional :: trans, unitd - real(kind(1.d0)), optional, target :: d(:) - end subroutine psb_dcssm - subroutine psb_dcssv(alpha,t,b,beta,c,info,trans,unitd,d) - use psb_spmat_type - type(psb_dspmat_type) :: t - real(kind(1.d0)) :: alpha, beta, b(:), c(:) - integer :: info - character, optional :: trans, unitd - real(kind(1.d0)), optional, target :: d(:) - end subroutine psb_dcssv - subroutine psb_zcssm(alpha,t,b,beta,c,info,trans,unitd,d) - use psb_spmat_type - type(psb_zspmat_type) :: t - complex(kind(1.d0)) :: alpha, beta, b(:,:), c(:,:) - integer :: info - character, optional :: trans, unitd - complex(kind(1.d0)), optional, target :: d(:) - end subroutine psb_zcssm - subroutine psb_zcssv(alpha,t,b,beta,c,info,trans,unitd,d) - use psb_spmat_type - type(psb_zspmat_type) :: t - complex(kind(1.d0)) :: alpha, beta, b(:), c(:) - integer :: info - character, optional :: trans, unitd - complex(kind(1.d0)), optional, target :: d(:) - end subroutine psb_zcssv + subroutine psb_dcssm(alpha,t,b,beta,c,info,trans,unitd,d) + use psb_spmat_type + type(psb_dspmat_type) :: t + real(kind(1.d0)) :: alpha, beta, b(:,:), c(:,:) + integer :: info + character, optional :: trans, unitd + real(kind(1.d0)), optional, target :: d(:) + end subroutine psb_dcssm + subroutine psb_dcssv(alpha,t,b,beta,c,info,trans,unitd,d) + use psb_spmat_type + type(psb_dspmat_type) :: t + real(kind(1.d0)) :: alpha, beta, b(:), c(:) + integer :: info + character, optional :: trans, unitd + real(kind(1.d0)), optional, target :: d(:) + end subroutine psb_dcssv + subroutine psb_zcssm(alpha,t,b,beta,c,info,trans,unitd,d) + use psb_spmat_type + type(psb_zspmat_type) :: t + complex(kind(1.d0)) :: alpha, beta, b(:,:), c(:,:) + integer :: info + character, optional :: trans, unitd + complex(kind(1.d0)), optional, target :: d(:) + end subroutine psb_zcssm + subroutine psb_zcssv(alpha,t,b,beta,c,info,trans,unitd,d) + use psb_spmat_type + type(psb_zspmat_type) :: t + complex(kind(1.d0)) :: alpha, beta, b(:), c(:) + integer :: info + character, optional :: trans, unitd + complex(kind(1.d0)), optional, target :: d(:) + end subroutine psb_zcssv end interface interface psb_csmm - subroutine psb_dcsmv(alpha,a,b,beta,c,info,trans) - use psb_spmat_type - type(psb_dspmat_type) :: a - real(kind(1.d0)) :: alpha, beta, b(:), c(:) - integer :: info - character, optional :: trans - end subroutine psb_dcsmv - subroutine psb_dcsmm(alpha,a,b,beta,c,info,trans) - use psb_spmat_type - type(psb_dspmat_type) :: a - real(kind(1.d0)) :: alpha, beta, b(:,:), c(:,:) - integer :: info - character, optional :: trans - end subroutine psb_dcsmm - subroutine psb_zcsmv(alpha,a,b,beta,c,info,trans) - use psb_spmat_type - type(psb_zspmat_type) :: a - complex(kind(1.d0)) :: alpha, beta, b(:), c(:) - integer :: info - character, optional :: trans - end subroutine psb_zcsmv - subroutine psb_zcsmm(alpha,a,b,beta,c,info,trans) - use psb_spmat_type - type(psb_zspmat_type) :: a - complex(kind(1.d0)) :: alpha, beta, b(:,:), c(:,:) - integer :: info - character, optional :: trans - end subroutine psb_zcsmm + subroutine psb_dcsmv(alpha,a,b,beta,c,info,trans) + use psb_spmat_type + type(psb_dspmat_type) :: a + real(kind(1.d0)) :: alpha, beta, b(:), c(:) + integer :: info + character, optional :: trans + end subroutine psb_dcsmv + subroutine psb_dcsmm(alpha,a,b,beta,c,info,trans) + use psb_spmat_type + type(psb_dspmat_type) :: a + real(kind(1.d0)) :: alpha, beta, b(:,:), c(:,:) + integer :: info + character, optional :: trans + end subroutine psb_dcsmm + subroutine psb_zcsmv(alpha,a,b,beta,c,info,trans) + use psb_spmat_type + type(psb_zspmat_type) :: a + complex(kind(1.d0)) :: alpha, beta, b(:), c(:) + integer :: info + character, optional :: trans + end subroutine psb_zcsmv + subroutine psb_zcsmm(alpha,a,b,beta,c,info,trans) + use psb_spmat_type + type(psb_zspmat_type) :: a + complex(kind(1.d0)) :: alpha, beta, b(:,:), c(:,:) + integer :: info + character, optional :: trans + end subroutine psb_zcsmm end interface interface psb_fixcoo - subroutine psb_dfixcoo(a,info,idir) - use psb_spmat_type - type(psb_dspmat_type), intent(inout) :: a - integer, intent(out) :: info - integer, intent(in), optional :: idir - end subroutine psb_dfixcoo - subroutine psb_zfixcoo(a,info,idir) - use psb_spmat_type - type(psb_zspmat_type), intent(inout) :: a - integer, intent(out) :: info - integer, intent(in), optional :: idir - end subroutine psb_zfixcoo + subroutine psb_dfixcoo(a,info,idir) + use psb_spmat_type + type(psb_dspmat_type), intent(inout) :: a + integer, intent(out) :: info + integer, intent(in), optional :: idir + end subroutine psb_dfixcoo + subroutine psb_zfixcoo(a,info,idir) + use psb_spmat_type + type(psb_zspmat_type), intent(inout) :: a + integer, intent(out) :: info + integer, intent(in), optional :: idir + end subroutine psb_zfixcoo end interface interface psb_ipcoo2csr - subroutine psb_dipcoo2csr(a,info,rwshr) - use psb_spmat_type - type(psb_dspmat_type), intent(inout) :: a - integer, intent(out) :: info - logical, optional :: rwshr - end subroutine psb_dipcoo2csr - subroutine psb_zipcoo2csr(a,info,rwshr) - use psb_spmat_type - type(psb_zspmat_type), intent(inout) :: a - integer, intent(out) :: info - logical, optional :: rwshr - end subroutine psb_zipcoo2csr + subroutine psb_dipcoo2csr(a,info,rwshr) + use psb_spmat_type + type(psb_dspmat_type), intent(inout) :: a + integer, intent(out) :: info + logical, optional :: rwshr + end subroutine psb_dipcoo2csr + subroutine psb_zipcoo2csr(a,info,rwshr) + use psb_spmat_type + type(psb_zspmat_type), intent(inout) :: a + integer, intent(out) :: info + logical, optional :: rwshr + end subroutine psb_zipcoo2csr end interface interface psb_ipcoo2csc - subroutine psb_dipcoo2csc(a,info,clshr) - use psb_spmat_type - type(psb_dspmat_type), intent(inout) :: a - integer, intent(out) :: info - logical, optional :: clshr - end subroutine psb_dipcoo2csc - subroutine psb_zipcoo2csc(a,info,clshr) - use psb_spmat_type - type(psb_zspmat_type), intent(inout) :: a - integer, intent(out) :: info - logical, optional :: clshr - end subroutine psb_zipcoo2csc + subroutine psb_dipcoo2csc(a,info,clshr) + use psb_spmat_type + type(psb_dspmat_type), intent(inout) :: a + integer, intent(out) :: info + logical, optional :: clshr + end subroutine psb_dipcoo2csc + subroutine psb_zipcoo2csc(a,info,clshr) + use psb_spmat_type + type(psb_zspmat_type), intent(inout) :: a + integer, intent(out) :: info + logical, optional :: clshr + end subroutine psb_zipcoo2csc end interface interface psb_ipcsr2coo - subroutine psb_dipcsr2coo(a,info) - use psb_spmat_type - type(psb_dspmat_type), intent(inout) :: a - integer, intent(out) :: info - end subroutine psb_dipcsr2coo - subroutine psb_zipcsr2coo(a,info) - use psb_spmat_type - type(psb_zspmat_type), intent(inout) :: a - integer, intent(out) :: info - end subroutine psb_zipcsr2coo + subroutine psb_dipcsr2coo(a,info) + use psb_spmat_type + type(psb_dspmat_type), intent(inout) :: a + integer, intent(out) :: info + end subroutine psb_dipcsr2coo + subroutine psb_zipcsr2coo(a,info) + use psb_spmat_type + type(psb_zspmat_type), intent(inout) :: a + integer, intent(out) :: info + end subroutine psb_zipcsr2coo end interface interface psb_csprt - subroutine psb_dcsprt(iout,a,iv,irs,ics,head,ivr,ivc) - use psb_spmat_type - integer, intent(in) :: iout - type(psb_dspmat_type), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: irs,ics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:),ivc(:) - end subroutine psb_dcsprt - subroutine psb_zcsprt(iout,a,iv,irs,ics,head,ivr,ivc) - use psb_spmat_type - integer, intent(in) :: iout - type(psb_zspmat_type), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: irs,ics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:),ivc(:) - end subroutine psb_zcsprt + subroutine psb_dcsprt(iout,a,iv,irs,ics,head,ivr,ivc) + use psb_spmat_type + integer, intent(in) :: iout + type(psb_dspmat_type), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: irs,ics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:),ivc(:) + end subroutine psb_dcsprt + subroutine psb_zcsprt(iout,a,iv,irs,ics,head,ivr,ivc) + use psb_spmat_type + integer, intent(in) :: iout + type(psb_zspmat_type), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: irs,ics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:),ivc(:) + end subroutine psb_zcsprt end interface interface psb_neigh - subroutine psb_dneigh(a,idx,neigh,n,info,lev) - use psb_spmat_type - type(psb_dspmat_type), intent(in) :: a - integer, intent(in) :: idx - integer, intent(out) :: n - integer, allocatable :: neigh(:) - integer, intent(out) :: info - integer, optional, intent(in) :: lev - end subroutine psb_dneigh - subroutine psb_zneigh(a,idx,neigh,n,info,lev) - use psb_spmat_type - type(psb_zspmat_type), intent(in) :: a - integer, intent(in) :: idx - integer, intent(out) :: n - integer, allocatable :: neigh(:) - integer, intent(out) :: info - integer, optional, intent(in) :: lev - end subroutine psb_zneigh + subroutine psb_dneigh(a,idx,neigh,n,info,lev) + use psb_spmat_type + type(psb_dspmat_type), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + end subroutine psb_dneigh + subroutine psb_zneigh(a,idx,neigh,n,info,lev) + use psb_spmat_type + type(psb_zspmat_type), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + end subroutine psb_zneigh end interface interface psb_coins - subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) - use psb_spmat_type - integer, intent(in) :: nz, imin,imax,jmin,jmax - integer, intent(in) :: ia(:),ja(:) - real(kind(1.d0)), intent(in) :: val(:) - type(psb_dspmat_type), intent(inout) :: a - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - logical, optional, intent(in) :: rebuild - end subroutine psb_dcoins - subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) - use psb_spmat_type - integer, intent(in) :: nz, imin,imax,jmin,jmax - integer, intent(in) :: ia(:),ja(:) - complex(kind(1.d0)), intent(in) :: val(:) - type(psb_zspmat_type), intent(inout) :: a - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - logical, optional, intent(in) :: rebuild - end subroutine psb_zcoins + subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) + use psb_spmat_type + integer, intent(in) :: nz, imin,imax,jmin,jmax + integer, intent(in) :: ia(:),ja(:) + real(kind(1.d0)), intent(in) :: val(:) + type(psb_dspmat_type), intent(inout) :: a + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + logical, optional, intent(in) :: rebuild + end subroutine psb_dcoins + subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) + use psb_spmat_type + integer, intent(in) :: nz, imin,imax,jmin,jmax + integer, intent(in) :: ia(:),ja(:) + complex(kind(1.d0)), intent(in) :: val(:) + type(psb_zspmat_type), intent(inout) :: a + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + logical, optional, intent(in) :: rebuild + end subroutine psb_zcoins end interface interface psb_symbmm - subroutine psb_dsymbmm(a,b,c,info) - use psb_spmat_type - type(psb_dspmat_type) :: a,b,c - integer :: info - end subroutine psb_dsymbmm - subroutine psb_zsymbmm(a,b,c,info) - use psb_spmat_type - type(psb_zspmat_type) :: a,b,c - integer :: info - end subroutine psb_zsymbmm + subroutine psb_dsymbmm(a,b,c,info) + use psb_spmat_type + type(psb_dspmat_type) :: a,b,c + integer :: info + end subroutine psb_dsymbmm + subroutine psb_zsymbmm(a,b,c,info) + use psb_spmat_type + type(psb_zspmat_type) :: a,b,c + integer :: info + end subroutine psb_zsymbmm end interface interface psb_numbmm - subroutine psb_dnumbmm(a,b,c) - use psb_spmat_type - type(psb_dspmat_type) :: a,b,c - end subroutine psb_dnumbmm - subroutine psb_znumbmm(a,b,c) - use psb_spmat_type - type(psb_zspmat_type) :: a,b,c - end subroutine psb_znumbmm + subroutine psb_dnumbmm(a,b,c) + use psb_spmat_type + type(psb_dspmat_type) :: a,b,c + end subroutine psb_dnumbmm + subroutine psb_znumbmm(a,b,c) + use psb_spmat_type + type(psb_zspmat_type) :: a,b,c + end subroutine psb_znumbmm end interface interface psb_transp - subroutine psb_dtransp(a,b,c,fmt) - use psb_spmat_type - type(psb_dspmat_type) :: a,b - integer, optional :: c - character(len=*), optional :: fmt - end subroutine psb_dtransp - subroutine psb_ztransp(a,b,c,fmt) - use psb_spmat_type - type(psb_zspmat_type) :: a,b - integer, optional :: c - character(len=*), optional :: fmt - end subroutine psb_ztransp + subroutine psb_dtransp(a,b,c,fmt) + use psb_spmat_type + type(psb_dspmat_type) :: a,b + integer, optional :: c + character(len=*), optional :: fmt + end subroutine psb_dtransp + subroutine psb_ztransp(a,b,c,fmt) + use psb_spmat_type + type(psb_zspmat_type) :: a,b + integer, optional :: c + character(len=*), optional :: fmt + end subroutine psb_ztransp end interface interface psb_transc - subroutine psb_ztransc(a,b,c,fmt) - use psb_spmat_type - type(psb_zspmat_type) :: a,b - integer, optional :: c - character(len=*), optional :: fmt - end subroutine psb_ztransc + subroutine psb_ztransc(a,b,c,fmt) + use psb_spmat_type + type(psb_zspmat_type) :: a,b + integer, optional :: c + character(len=*), optional :: fmt + end subroutine psb_ztransc end interface interface psb_rwextd - subroutine psb_drwextd(nr,a,info,b) - use psb_spmat_type - integer, intent(in) :: nr - type(psb_dspmat_type), intent(inout) :: a - integer, intent(out) :: info - type(psb_dspmat_type), intent(in), optional :: b - end subroutine psb_drwextd - subroutine psb_zrwextd(nr,a,info,b) - use psb_spmat_type - integer, intent(in) :: nr - type(psb_zspmat_type), intent(inout) :: a - integer, intent(out) :: info - type(psb_zspmat_type), intent(in), optional :: b - end subroutine psb_zrwextd + subroutine psb_drwextd(nr,a,info,b) + use psb_spmat_type + integer, intent(in) :: nr + type(psb_dspmat_type), intent(inout) :: a + integer, intent(out) :: info + type(psb_dspmat_type), intent(in), optional :: b + end subroutine psb_drwextd + subroutine psb_zrwextd(nr,a,info,b) + use psb_spmat_type + integer, intent(in) :: nr + type(psb_zspmat_type), intent(inout) :: a + integer, intent(out) :: info + type(psb_zspmat_type), intent(in), optional :: b + end subroutine psb_zrwextd end interface interface psb_csnmi - real(kind(1.d0)) function psb_dcsnmi(a,info,trans) - use psb_spmat_type - type(psb_dspmat_type), intent(in) :: a - integer, intent(out) :: info - character, optional :: trans - end function psb_dcsnmi - real(kind(1.d0)) function psb_zcsnmi(a,info,trans) - use psb_spmat_type - type(psb_zspmat_type), intent(in) :: a - integer, intent(out) :: info - character, optional :: trans - end function psb_zcsnmi + real(kind(1.d0)) function psb_dcsnmi(a,info,trans) + use psb_spmat_type + type(psb_dspmat_type), intent(in) :: a + integer, intent(out) :: info + character, optional :: trans + end function psb_dcsnmi + real(kind(1.d0)) function psb_zcsnmi(a,info,trans) + use psb_spmat_type + type(psb_zspmat_type), intent(in) :: a + integer, intent(out) :: info + character, optional :: trans + end function psb_zcsnmi end interface interface psb_sp_getdiag - subroutine psb_dspgtdiag(a,d,info) - use psb_spmat_type - type(psb_dspmat_type), intent(in) :: a - real(kind(1.d0)), intent(inout) :: d(:) - integer, intent(out) :: info - end subroutine psb_dspgtdiag - subroutine psb_zspgtdiag(a,d,info) - use psb_spmat_type - type(psb_zspmat_type), intent(in) :: a - complex(kind(1.d0)), intent(inout) :: d(:) - integer, intent(out) :: info - end subroutine psb_zspgtdiag + subroutine psb_dspgtdiag(a,d,info) + use psb_spmat_type + type(psb_dspmat_type), intent(in) :: a + real(kind(1.d0)), intent(inout) :: d(:) + integer, intent(out) :: info + end subroutine psb_dspgtdiag + subroutine psb_zspgtdiag(a,d,info) + use psb_spmat_type + type(psb_zspmat_type), intent(in) :: a + complex(kind(1.d0)), intent(inout) :: d(:) + integer, intent(out) :: info + end subroutine psb_zspgtdiag end interface interface psb_sp_scal - subroutine psb_dspscal(a,d,info) - use psb_spmat_type - type(psb_dspmat_type), intent(inout) :: a - real(kind(1.d0)), intent(in) :: d(:) - integer, intent(out) :: info - end subroutine psb_dspscal - subroutine psb_zspscal(a,d,info) - use psb_spmat_type - type(psb_zspmat_type), intent(inout) :: a - complex(kind(1.d0)), intent(in) :: d(:) - integer, intent(out) :: info - end subroutine psb_zspscal + subroutine psb_dspscal(a,d,info) + use psb_spmat_type + type(psb_dspmat_type), intent(inout) :: a + real(kind(1.d0)), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_dspscal + subroutine psb_zspscal(a,d,info) + use psb_spmat_type + type(psb_zspmat_type), intent(inout) :: a + complex(kind(1.d0)), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_zspscal end interface interface psb_sp_getblk - subroutine psb_dspgtblk(irw,a,b,info,append,iren,lrw) - use psb_spmat_type - type(psb_dspmat_type), intent(in) :: a - integer, intent(in) :: irw - type(psb_dspmat_type), intent(inout) :: b - logical, intent(in), optional :: append - integer, intent(in), target, optional :: iren(:) - integer, intent(in), optional :: lrw - integer, intent(out) :: info - end subroutine psb_dspgtblk - subroutine psb_zspgtblk(irw,a,b,info,append,iren,lrw) - use psb_spmat_type - type(psb_zspmat_type), intent(in) :: a - integer, intent(in) :: irw - type(psb_zspmat_type), intent(inout) :: b - logical, intent(in), optional :: append - integer, intent(in), target, optional :: iren(:) - integer, intent(in), optional :: lrw - integer, intent(out) :: info - end subroutine psb_zspgtblk + subroutine psb_dspgtblk(irw,a,b,info,append,iren,lrw) + use psb_spmat_type + type(psb_dspmat_type), intent(in) :: a + integer, intent(in) :: irw + type(psb_dspmat_type), intent(inout) :: b + logical, intent(in), optional :: append + integer, intent(in), target, optional :: iren(:) + integer, intent(in), optional :: lrw + integer, intent(out) :: info + end subroutine psb_dspgtblk + subroutine psb_zspgtblk(irw,a,b,info,append,iren,lrw) + use psb_spmat_type + type(psb_zspmat_type), intent(in) :: a + integer, intent(in) :: irw + type(psb_zspmat_type), intent(inout) :: b + logical, intent(in), optional :: append + integer, intent(in), target, optional :: iren(:) + integer, intent(in), optional :: lrw + integer, intent(out) :: info + end subroutine psb_zspgtblk end interface interface psb_sp_getrow - subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) - use psb_spmat_type - type(psb_dspmat_type), intent(in) :: a - integer, intent(in) :: irw - integer, intent(out) :: nz - integer, intent(inout) :: ia(:), ja(:) - real(kind(1.d0)), intent(inout) :: val(:) - integer, intent(in), target, optional :: iren(:) - integer, intent(in), optional :: lrw - integer, intent(out) :: info - end subroutine psb_dspgetrow - subroutine psb_zspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) - use psb_spmat_type - type(psb_zspmat_type), intent(in) :: a - integer, intent(in) :: irw - integer, intent(out) :: nz - integer, intent(inout) :: ia(:), ja(:) - complex(kind(1.d0)), intent(inout) :: val(:) - integer, intent(in), target, optional :: iren(:) - integer, intent(in), optional :: lrw - integer, intent(out) :: info - end subroutine psb_zspgetrow + subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) + use psb_spmat_type + type(psb_dspmat_type), intent(in) :: a + integer, intent(in) :: irw + integer, intent(out) :: nz + integer, intent(inout) :: ia(:), ja(:) + real(kind(1.d0)), intent(inout) :: val(:) + integer, intent(in), target, optional :: iren(:) + integer, intent(in), optional :: lrw + integer, intent(out) :: info + end subroutine psb_dspgetrow + subroutine psb_zspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) + use psb_spmat_type + type(psb_zspmat_type), intent(in) :: a + integer, intent(in) :: irw + integer, intent(out) :: nz + integer, intent(inout) :: ia(:), ja(:) + complex(kind(1.d0)), intent(inout) :: val(:) + integer, intent(in), target, optional :: iren(:) + integer, intent(in), optional :: lrw + integer, intent(out) :: info + end subroutine psb_zspgetrow end interface + - interface csrp - - subroutine dcsrp(trans,m,n,fida,descra,ia1,ia2,& - & infoa,p,work,lwork,ierror) - integer, intent(in) :: m, n, lwork - integer, intent(out) :: ierror - character, intent(in) :: trans - double precision, intent(inout) :: work(*) - integer, intent(in) :: p(*) - integer, intent(inout) :: ia1(*), ia2(*), infoa(*) - character, intent(in) :: fida*5, descra*11 - end subroutine dcsrp - subroutine zcsrp(trans,m,n,fida,descra,ia1,ia2,& - & infoa,p,work,lwork,ierror) - integer, intent(in) :: m, n, lwork - integer, intent(out) :: ierror - character, intent(in) :: trans - complex(kind(1.d0)), intent(inout) :: work(*) - integer, intent(in) :: p(*) - integer, intent(inout) :: ia1(*), ia2(*), infoa(*) - character, intent(in) :: fida*5, descra*11 - end subroutine zcsrp - - end interface - - - interface isaperm - - logical function isaperm(n,ip) - integer, intent(in) :: n - integer, intent(inout) :: ip(*) - end function isaperm - end interface - - interface psb_cest - subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, iup, info) - integer, intent(in) :: m,n,nnz,iup - integer, intent(out) :: lia1, lia2, lar, info - character(len=5) :: afmt - end subroutine psb_cest - end interface + end module psb_serial_mod diff --git a/base/modules/psb_tools_mod.f90 b/base/modules/psb_tools_mod.f90 index 746ef198..59f21523 100644 --- a/base/modules/psb_tools_mod.f90 +++ b/base/modules/psb_tools_mod.f90 @@ -557,22 +557,20 @@ Module psb_tools_mod interface psb_glob_to_loc - subroutine psb_glob_to_loc2(x,y,desc_a,info,iact,owned) + subroutine psb_glob_to_loc2(x,y,desc_a,info,iact) use psb_descriptor_type - type(psb_desc_type), intent(in) :: desc_a - integer,intent(in) :: x(:) - integer,intent(out) :: y(:) - integer, intent(out) :: info - character, intent(in), optional :: iact - logical, intent(in), optional :: owned + type(psb_desc_type), intent(in) :: desc_a + integer,intent(in) :: x(:) + integer,intent(out) :: y(:) + integer, intent(out) :: info + character, intent(in), optional :: iact end subroutine psb_glob_to_loc2 - subroutine psb_glob_to_loc(x,desc_a,info,iact,owned) + subroutine psb_glob_to_loc(x,desc_a,info,iact) use psb_descriptor_type - type(psb_desc_type), intent(in) :: desc_a - integer,intent(inout) :: x(:) - integer, intent(out) :: info - character, intent(in), optional :: iact - logical, intent(in), optional :: owned + type(psb_desc_type), intent(in) :: desc_a + integer,intent(inout) :: x(:) + integer, intent(out) :: info + character, intent(in), optional :: iact end subroutine psb_glob_to_loc end interface diff --git a/base/modules/psi_mod.f90 b/base/modules/psi_mod.f90 index beaa7d89..fd500f0a 100644 --- a/base/modules/psi_mod.f90 +++ b/base/modules/psi_mod.f90 @@ -77,15 +77,15 @@ module psi_mod end interface interface - subroutine psi_desc_index(desc,index_in,dep_list,& - & length_dl,nsnd,nrcv,desc_index,isglob_in,info) - use psb_descriptor_type - type(psb_desc_type) :: desc - integer :: index_in(:),dep_list(:) - integer,allocatable :: desc_index(:) - integer :: length_dl,nsnd,nrcv,info - logical :: isglob_in - end subroutine psi_desc_index + subroutine psi_desc_index(desc_data,index_in,dep_list,& + & length_dl,nsnd,nrcv,loc_to_glob,glob_to_loc,desc_index,& + & isglob_in,info) + integer :: desc_data(:),index_in(:),dep_list(:) + integer :: loc_to_glob(:),glob_to_loc(:) + integer,allocatable, intent(inout) :: desc_index(:) + integer :: length_dl,nsnd,nrcv,info + logical :: isglob_in + end subroutine psi_desc_index end interface interface @@ -94,13 +94,6 @@ module psi_mod end subroutine psi_sort_dl end interface - interface - subroutine psi_dl_check(dep_list,dl_lda,np,length_dl) - integer :: np,dl_lda,length_dl(0:np) - integer :: dep_list(dl_lda,0:np) - end subroutine psi_dl_check - end interface - interface psi_swapdata subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) use psb_descriptor_type @@ -430,7 +423,6 @@ contains call psb_errpush(4010,name,a_err='psi_crea_ovr_elem') goto 9999 end if - cdesc%matrix_data(psb_ovl_state_)=psb_cd_ovl_asb_ ! finally bnd_elem call psi_crea_bnd_elem(idx_out,cdesc,info) diff --git a/base/psblas/Makefile b/base/psblas/Makefile index 46665476..6ac36cb4 100644 --- a/base/psblas/Makefile +++ b/base/psblas/Makefile @@ -6,10 +6,10 @@ OBJS= psb_ddot.o psb_damax.o psb_dasum.o psb_daxpby.o\ pdtreecomb.o \ psb_zamax.o psb_zasum.o psb_zaxpby.o psb_zdot.o \ psb_znrm2.o psb_znrmi.o psb_zspmm.o psb_zspsm.o -LIBDIR=../../lib -HERE=. -INCDIRS=-I. -I.. -I$(LIBDIR) +LIBDIR = .. +MODDIR = ../modules +INCDIRS = -I $(LIBDIR) -I $(MODDIR) -I . lib: $(OBJS) diff --git a/base/serial/Makefile b/base/serial/Makefile index 05e935b7..a20f14d4 100644 --- a/base/serial/Makefile +++ b/base/serial/Makefile @@ -14,8 +14,9 @@ FOBJS = psb_cest.o psb_dcoins.o psb_dcsdp.o psb_dcsmm.o psb_dcsmv.o \ psb_zrwextd.o psb_zsymbmm.o psb_znumbmm.o psb_zspscal.o\ psb_getifield.o psb_setifield.o psb_update_mod.o -INCDIRS = -I ../../lib -I . -LIBDIR = ../../lib +LIBDIR = .. +MODDIR = ../modules +INCDIRS = -I $(LIBDIR) -I $(MODDIR) -I . lib: auxd cood csrd jadd f77d dpd lib1 $(AR) $(LIBDIR)/$(LIBNAME) $(FOBJS) @@ -53,11 +54,4 @@ clean: (cd dp; make clean) (cd f77; make clean) -veryclean: - /bin/rm -f $(FOBJS) *$(.mod) - (cd aux; make veryclean) - (cd coo; make veryclean) - (cd csr; make veryclean) - (cd jad; make veryclean) - (cd dp; make veryclean) - (cd f77; make veryclean) +veryclean: clean diff --git a/base/serial/aux/Makefile b/base/serial/aux/Makefile index 48fb997f..859a1f52 100644 --- a/base/serial/aux/Makefile +++ b/base/serial/aux/Makefile @@ -12,9 +12,10 @@ OBJS=$(FOBJS) # # Where the library should go, and how it is called. # Note that we are regenerating most of libsparker.a on the fly. -LIBDIR=../../../lib -#LIBNAME=libsparker.a -INCDIRS=-I. -I$(LIBDIR) +SPARKERDIR=.. +LIBDIR = ../.. +MODDIR = ../../modules +INCDIRS = -I $(LIBDIR) -I $(MODDIR) -I . -I$(SPARKERDIR) # # No change should be needed below diff --git a/base/serial/coo/Makefile b/base/serial/coo/Makefile index fe25ca68..4f5f31f9 100644 --- a/base/serial/coo/Makefile +++ b/base/serial/coo/Makefile @@ -12,11 +12,12 @@ OBJS=$(FOBJS) # # Where the library should go, and how it is called. # Note that we are regenerating most of libsparker.a on the fly. -LIBDIR=../../../lib #LIBNAME=libsparker.a -LIBFILE=$(LIBDIR)/$(LIBNAME) SPARKERDIR=.. -INCDIRS=-I. -I$(SPARKERDIR) -I$(LIBDIR) +LIBDIR = ../.. +MODDIR = ../../modules +INCDIRS = -I $(LIBDIR) -I $(MODDIR) -I . -I$(SPARKERDIR) +LIBFILE=$(LIBDIR)/$(LIBNAME) # # No change should be needed below diff --git a/base/serial/csr/Makefile b/base/serial/csr/Makefile index f13c0ac7..371a3d9e 100644 --- a/base/serial/csr/Makefile +++ b/base/serial/csr/Makefile @@ -13,10 +13,11 @@ OBJS=$(FOBJS) # # Where the library should go, and how it is called. # Note that we are regenerating most of libsparker.a on the fly. -LIBDIR=../../../lib -#LIBNAME=libsparker.a +SPARKERDIR=.. +LIBDIR = ../.. +MODDIR = ../../modules +INCDIRS = -I $(LIBDIR) -I $(MODDIR) -I . -I$(SPARKERDIR) LIBFILE=$(LIBDIR)/$(LIBNAME) -INCDIRS=-I. -I$(LIBDIR) # # No change should be needed below diff --git a/base/serial/dp/Makefile b/base/serial/dp/Makefile index 8df03bad..952f406e 100644 --- a/base/serial/dp/Makefile +++ b/base/serial/dp/Makefile @@ -19,10 +19,12 @@ OBJS=$(FOBJS) # # Where the library should go, and how it is called. # Note that we are regenerating most of libsparker.a on the fly. -LIBDIR=../../../lib +SPARKERDIR=.. +LIBDIR = ../.. +MODDIR = ../../modules +INCDIRS = -I $(LIBDIR) -I $(MODDIR) -I . -I$(SPARKERDIR) #LIBNAME=libsparker.a LIBFILE=$(LIBDIR)/$(LIBNAME) -INCDIRS=-I. -I$(LIBDIR) # # No change should be needed below diff --git a/base/serial/f77/Makefile b/base/serial/f77/Makefile index 2374337e..b9ab2145 100644 --- a/base/serial/f77/Makefile +++ b/base/serial/f77/Makefile @@ -14,10 +14,12 @@ OBJS=$(FOBJS) # # Where the library should go, and how it is called. # Note that we are regenerating most of libsparker.a on the fly. -LIBDIR=../../../lib +SPARKERDIR=.. +LIBDIR = ../.. +MODDIR = ../../modules +INCDIRS = -I $(LIBDIR) -I $(MODDIR) -I . -I$(SPARKERDIR) #LIBNAME=libsparker.a LIBFILE=$(LIBDIR)/$(LIBNAME) -INCDIRS=-I. -I$(LIBDIR) # # No change should be needed below diff --git a/base/serial/jad/Makefile b/base/serial/jad/Makefile index 70ef988a..19bc0ea7 100644 --- a/base/serial/jad/Makefile +++ b/base/serial/jad/Makefile @@ -11,10 +11,12 @@ OBJS=$(FOBJS) # # Where the library should go, and how it is called. # Note that we are regenerating most of libsparker.a on the fly. -LIBDIR=../../../lib +SPARKERDIR=.. +LIBDIR = ../.. +MODDIR = ../../modules +INCDIRS = -I $(LIBDIR) -I $(MODDIR) -I . -I$(SPARKERDIR) #LIBNAME=libsparker.a LIBFILE=$(LIBDIR)/$(LIBNAME) -INCDIRS=-I. -I$(LIBDIR) # # No change should be needed below diff --git a/base/serial/psb_dcsdp.f90 b/base/serial/psb_dcsdp.f90 index 306b96fd..89d1cf76 100644 --- a/base/serial/psb_dcsdp.f90 +++ b/base/serial/psb_dcsdp.f90 @@ -48,8 +48,6 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl) use psb_error_mod use psb_spmat_type use psb_string_mod - - use psb_serial_mod, only : psb_cest implicit none !....Parameters... @@ -72,6 +70,14 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl) logical, parameter :: debug=.false. character(len=20) :: name, ch_err + interface psb_cest + subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, iup, info) + integer, intent(in) :: m,n,nnz,iup + integer, intent(out) :: lia1, lia2, lar, info + character, intent(inout) :: afmt*5 + end subroutine psb_cest + end interface + name='psb_csdp' info = 0 call psb_erractionsave(err_act) diff --git a/base/serial/psb_dcsprt.f90 b/base/serial/psb_dcsprt.f90 index 7fa74c38..10dc1598 100644 --- a/base/serial/psb_dcsprt.f90 +++ b/base/serial/psb_dcsprt.f90 @@ -57,7 +57,7 @@ subroutine psb_dcsprt(iout,a,iv,eirs,eics,head,ivr,ivc) character(len=*), optional :: head integer, intent(in), optional :: ivr(:), ivc(:) - character(len=*), parameter :: frmtr='(2(i16,1x),e16.8,2(i16,1x))' + character(len=*), parameter :: frmtr='(2(i6,1x),e16.8,2(i6,1x))' integer :: irs,ics,i,j if (present(eirs)) then diff --git a/base/serial/psb_dnumbmm.f90 b/base/serial/psb_dnumbmm.f90 index 47aea663..ea04d807 100644 --- a/base/serial/psb_dnumbmm.f90 +++ b/base/serial/psb_dnumbmm.f90 @@ -40,15 +40,27 @@ ! subroutine psb_dnumbmm(a,b,c) - use psb_realloc_mod use psb_spmat_type - use psb_serial_mod, only : psb_sp_getrow implicit none type(psb_dspmat_type) :: a,b,c real(kind(1.d0)), allocatable :: temp(:) integer :: info + interface psb_sp_getrow + subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) + use psb_spmat_type + type(psb_dspmat_type), intent(in) :: a + integer, intent(in) :: irw + integer, intent(out) :: nz + integer, intent(inout) :: ia(:), ja(:) + real(kind(1.d0)), intent(inout) :: val(:) + integer, intent(in), target, optional :: iren(:) + integer, intent(in), optional :: lrw + integer, intent(out) :: info + end subroutine psb_dspgetrow + end interface + allocate(temp(max(a%m,a%k,b%m,b%k)),stat=info) if (info /= 0) then diff --git a/base/serial/psb_dspgetrow.f90 b/base/serial/psb_dspgetrow.f90 index b1c73039..ad692bec 100644 --- a/base/serial/psb_dspgetrow.f90 +++ b/base/serial/psb_dspgetrow.f90 @@ -42,8 +42,6 @@ subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) use psb_spmat_type use psb_string_mod - use psb_serial_mod, only: psb_sp_getblk - implicit none type(psb_dspmat_type), intent(in) :: a integer, intent(in) :: irw integer, intent(out) :: nz @@ -52,6 +50,23 @@ subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) integer, intent(in), target, optional :: iren(:) integer, intent(in), optional :: lrw integer, intent(out) :: info + interface psb_spgtblk + subroutine psb_dspgtblk(irw,a,b,info,append,iren,lrw) + ! Output is always in COO format into B, irrespective of + ! the input format + use psb_spmat_type + use psb_const_mod + implicit none + + type(psb_dspmat_type), intent(in) :: a + integer, intent(in) :: irw + type(psb_dspmat_type), intent(inout) :: b + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), target, optional :: iren(:) + integer, intent(in), optional :: lrw + end subroutine psb_dspgtblk + end interface integer :: lrw_, ierr(5), err_act type(psb_dspmat_type) :: b @@ -78,9 +93,9 @@ subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) call psb_sp_all(lrw_-irw+1,lrw_-irw+1,b,info) if (present(iren)) then - call psb_sp_getblk(irw,a,b,info,iren=iren,lrw=lrw_) + call psb_spgtblk(irw,a,b,info,iren=iren,lrw=lrw_) else - call psb_sp_getblk(irw,a,b,info,lrw=lrw_) + call psb_spgtblk(irw,a,b,info,lrw=lrw_) end if if (info /= 0) then info=136 diff --git a/base/serial/psb_dspgtdiag.f90 b/base/serial/psb_dspgtdiag.f90 index 78c06f31..3e0e354d 100644 --- a/base/serial/psb_dspgtdiag.f90 +++ b/base/serial/psb_dspgtdiag.f90 @@ -45,13 +45,25 @@ subroutine psb_dspgtdiag(a,d,info) use psb_spmat_type use psb_error_mod use psb_const_mod - use psb_serial_mod, only : psb_sp_getblk implicit none type(psb_dspmat_type), intent(in) :: a real(kind(1.d0)), intent(inout) :: d(:) integer, intent(out) :: info + interface psb_spgtblk + subroutine psb_dspgtblk(irw,a,b,info,append,iren,lrw) + use psb_spmat_type + type(psb_dspmat_type), intent(in) :: a + integer, intent(in) :: irw + type(psb_dspmat_type), intent(inout) :: b + logical, intent(in), optional :: append + integer, intent(in), target, optional :: iren(:) + integer, intent(in), optional :: lrw + integer, intent(out) :: info + end subroutine psb_dspgtblk + end interface + type(psb_dspmat_type) :: tmpa integer :: i,j,k,nr, nz, err_act, ii, rng, irb, nrb character(len=20) :: name, ch_err @@ -90,10 +102,10 @@ subroutine psb_dspgtdiag(a,d,info) write(0,*)'in spgtdiag' do i=1, rng, nrb irb=min(i+nrb-1,rng) - call psb_sp_getblk(i,a,tmpa,info,lrw=irb) + call psb_spgtblk(i,a,tmpa,info,lrw=irb) if(info.ne.0) then info=4010 - ch_err='psb_sp_getblk' + ch_err='psb_spgtblk' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if diff --git a/base/serial/psb_dsymbmm.f90 b/base/serial/psb_dsymbmm.f90 index 5d9628cd..81e93c06 100644 --- a/base/serial/psb_dsymbmm.f90 +++ b/base/serial/psb_dsymbmm.f90 @@ -41,7 +41,6 @@ subroutine psb_dsymbmm(a,b,c,info) use psb_spmat_type use psb_string_mod - use psb_serial_mod, only : psb_sp_getrow implicit none type(psb_dspmat_type) :: a,b,c @@ -56,6 +55,19 @@ subroutine psb_dsymbmm(a,b,c,info) integer, allocatable :: ic(:),jc(:) end subroutine symbmm end interface + interface psb_sp_getrow + subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) + use psb_spmat_type + type(psb_dspmat_type), intent(in) :: a + integer, intent(in) :: irw + integer, intent(out) :: nz + integer, intent(inout) :: ia(:), ja(:) + real(kind(1.d0)), intent(inout) :: val(:) + integer, intent(in), target, optional :: iren(:) + integer, intent(in), optional :: lrw + integer, intent(out) :: info + end subroutine psb_dspgetrow + end interface character(len=20) :: name, ch_err integer :: err_act @@ -88,7 +100,6 @@ subroutine psb_dsymbmm(a,b,c,info) endif nze = max(a%m+1,2*a%m) call psb_sp_reall(c,nze,info) - ! ! Note: we need to test whether there is a performance impact ! in not using the original Douglas & Bank code. diff --git a/base/serial/psb_zcsdp.f90 b/base/serial/psb_zcsdp.f90 index 6db5f772..b558945b 100644 --- a/base/serial/psb_zcsdp.f90 +++ b/base/serial/psb_zcsdp.f90 @@ -48,8 +48,6 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl) use psb_error_mod use psb_spmat_type use psb_string_mod - - use psb_serial_mod, only : psb_cest implicit none !....Parameters... @@ -72,6 +70,14 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl) logical, parameter :: debug=.false. character(len=20) :: name, ch_err + interface psb_cest + subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, iup, info) + integer, intent(in) :: m,n,nnz,iup + integer, intent(out) :: lia1, lia2, lar, info + character, intent(inout) :: afmt*5 + end subroutine psb_cest + end interface + name='psb_csdp' info = 0 call psb_erractionsave(err_act) diff --git a/base/serial/psb_znumbmm.f90 b/base/serial/psb_znumbmm.f90 index d6756025..53f4f031 100644 --- a/base/serial/psb_znumbmm.f90 +++ b/base/serial/psb_znumbmm.f90 @@ -40,15 +40,27 @@ ! subroutine psb_znumbmm(a,b,c) - use psb_realloc_mod use psb_spmat_type - use psb_serial_mod, only : psb_sp_getrow implicit none type(psb_zspmat_type) :: a,b,c complex(kind(1.d0)), allocatable :: temp(:) integer :: info + interface psb_sp_getrow + subroutine psb_zspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) + use psb_spmat_type + type(psb_zspmat_type), intent(in) :: a + integer, intent(in) :: irw + integer, intent(out) :: nz + integer, intent(inout) :: ia(:), ja(:) + complex(kind(1.d0)), intent(inout) :: val(:) + integer, intent(in), target, optional :: iren(:) + integer, intent(in), optional :: lrw + integer, intent(out) :: info + end subroutine psb_zspgetrow + end interface + allocate(temp(max(a%m,a%k,b%m,b%k)),stat=info) if (info /= 0) then diff --git a/base/serial/psb_zspgetrow.f90 b/base/serial/psb_zspgetrow.f90 index f44dd7b6..18e1e2b8 100644 --- a/base/serial/psb_zspgetrow.f90 +++ b/base/serial/psb_zspgetrow.f90 @@ -42,8 +42,6 @@ subroutine psb_zspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) use psb_spmat_type use psb_string_mod - use psb_serial_mod, only: psb_sp_getblk - implicit none type(psb_zspmat_type), intent(in) :: a integer, intent(in) :: irw integer, intent(out) :: nz @@ -52,6 +50,23 @@ subroutine psb_zspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) integer, intent(in), target, optional :: iren(:) integer, intent(in), optional :: lrw integer, intent(out) :: info + interface psb_spgtblk + subroutine psb_zspgtblk(irw,a,b,info,append,iren,lrw) + ! Output is always in COO format into B, irrespective of + ! the input format + use psb_spmat_type + use psb_const_mod + implicit none + + type(psb_zspmat_type), intent(in) :: a + integer, intent(in) :: irw + type(psb_zspmat_type), intent(inout) :: b + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), target, optional :: iren(:) + integer, intent(in), optional :: lrw + end subroutine psb_zspgtblk + end interface integer :: lrw_, ierr(5), err_act type(psb_zspmat_type) :: b @@ -78,9 +93,9 @@ subroutine psb_zspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) call psb_sp_all(lrw_-irw+1,lrw_-irw+1,b,info) if (present(iren)) then - call psb_sp_getblk(irw,a,b,info,iren=iren,lrw=lrw_) + call psb_spgtblk(irw,a,b,info,iren=iren,lrw=lrw_) else - call psb_sp_getblk(irw,a,b,info,lrw=lrw_) + call psb_spgtblk(irw,a,b,info,lrw=lrw_) end if if (info /= 0) then info=136 diff --git a/base/serial/psb_zspgtdiag.f90 b/base/serial/psb_zspgtdiag.f90 index 1aca7893..faead301 100644 --- a/base/serial/psb_zspgtdiag.f90 +++ b/base/serial/psb_zspgtdiag.f90 @@ -45,13 +45,25 @@ subroutine psb_zspgtdiag(a,d,info) use psb_spmat_type use psb_error_mod use psb_const_mod - use psb_serial_mod, only : psb_sp_getblk implicit none type(psb_zspmat_type), intent(in) :: a complex(kind(1.d0)), intent(inout) :: d(:) integer, intent(out) :: info + interface psb_spgtblk + subroutine psb_zspgtblk(irw,a,b,info,append,iren,lrw) + use psb_spmat_type + type(psb_zspmat_type), intent(in) :: a + integer, intent(in) :: irw + type(psb_zspmat_type), intent(inout) :: b + logical, intent(in), optional :: append + integer, intent(in), target, optional :: iren(:) + integer, intent(in), optional :: lrw + integer, intent(out) :: info + end subroutine psb_zspgtblk + end interface + type(psb_zspmat_type) :: tmpa integer :: i,j,k,nr, nz, err_act, ii, rng, irb, nrb character(len=20) :: name, ch_err @@ -90,10 +102,10 @@ subroutine psb_zspgtdiag(a,d,info) write(0,*)'in spgtdiag' do i=1, rng, nrb irb=min(i+nrb-1,rng) - call psb_sp_getblk(i,a,tmpa,info,lrw=irb) + call psb_spgtblk(i,a,tmpa,info,lrw=irb) if(info.ne.0) then info=4010 - ch_err='psb_sp_getblk' + ch_err='psb_spgtblk' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if diff --git a/base/serial/psb_zsymbmm.f90 b/base/serial/psb_zsymbmm.f90 index 6627f30a..8c0fe2f9 100644 --- a/base/serial/psb_zsymbmm.f90 +++ b/base/serial/psb_zsymbmm.f90 @@ -41,7 +41,6 @@ subroutine psb_zsymbmm(a,b,c,info) use psb_spmat_type use psb_string_mod - use psb_serial_mod, only : psb_sp_getrow implicit none type(psb_zspmat_type) :: a,b,c @@ -57,6 +56,19 @@ subroutine psb_zsymbmm(a,b,c,info) end subroutine symbmm end interface + interface psb_sp_getrow + subroutine psb_zspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) + use psb_spmat_type + type(psb_zspmat_type), intent(in) :: a + integer, intent(in) :: irw + integer, intent(out) :: nz + integer, intent(inout) :: ia(:), ja(:) + complex(kind(1.d0)), intent(inout) :: val(:) + integer, intent(in), target, optional :: iren(:) + integer, intent(in), optional :: lrw + integer, intent(out) :: info + end subroutine psb_zspgetrow + end interface character(len=20) :: name, ch_err integer :: err_act name='psb_symbmm' @@ -101,7 +113,6 @@ subroutine psb_zsymbmm(a,b,c,info) call inner_symbmm(a,b,c,itemp,info) endif call psb_realloc(size(c%ia1),c%aspk,info) - c%pl(1) = 0 c%pr(1) = 0 c%m=a%m diff --git a/base/tools/Makefile b/base/tools/Makefile index aae48ccc..dddd1503 100644 --- a/base/tools/Makefile +++ b/base/tools/Makefile @@ -15,8 +15,9 @@ FOBJS = psb_dallc.o psb_dasb.o psb_dcsrp.o psb_cdprt.o \ MPFOBJS = psb_dsphalo.o psb_zsphalo.o psb_cdasb.o psb_dcdovr.o psb_zcdovr.o -INCDIRS = -I ../../lib -I . -LIBDIR = ../../lib +LIBDIR = .. +MODDIR = ../modules +INCDIRS = -I $(LIBDIR) -I $(MODDIR) -I . lib: mpfobjs $(FOBJS) $(AR) $(LIBDIR)/$(LIBNAME) $(MPFOBJS) $(FOBJS) @@ -26,8 +27,6 @@ lib: mpfobjs $(FOBJS) mpfobjs: (make $(MPFOBJS) F90="$(MPF90)" FC="$(MPF90)" FCOPT="$(F90COPT)") -psb_glob_to_loc.o: psb_glob_to_loc.f90 - $(F90) $(F90COPT) $(INCDIRS) -c $< $(F90INLINE) clean: /bin/rm -f $(MPFOBJS) $(FOBJS) diff --git a/base/tools/psb_cdall.f90 b/base/tools/psb_cdall.f90 index d63055a0..deeb6d8e 100644 --- a/base/tools/psb_cdall.f90 +++ b/base/tools/psb_cdall.f90 @@ -57,7 +57,7 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info) !locals Integer :: counter,i,j,np,me,loc_row,err,loc_col,nprocs,& - & l_ov_ix,l_ov_el,idx, err_act, itmpov, k, ns, glx + & l_ov_ix,l_ov_el,idx, err_act, itmpov, k, ns integer :: int_err(5),exch(2) integer, allocatable :: prc_v(:), temp_ovrlap(:), ov_idx(:),ov_el(:) logical, parameter :: debug=.false. @@ -116,17 +116,13 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info) !count local rows number ! allocate work vector - if (m > psb_cd_get_large_threshold()) then - allocate(desc_a%matrix_data(psb_mdata_size_),& - & temp_ovrlap(m),prc_v(np),stat=info) - else - allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),& - & temp_ovrlap(m),prc_v(np),stat=info) - end if - if (info /= 0) then + allocate(prc_v(np),desc_a%glob_to_loc(m),& + &desc_a%matrix_data(psb_mdata_size_),temp_ovrlap(m),stat=info) + if (info /= no_err) then info=2025 + err=info int_err(1)=m - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(err,name,int_err) goto 9999 endif @@ -135,189 +131,76 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info) counter = 0 itmpov = 0 temp_ovrlap(:) = -1 - if ( m >psb_cd_get_large_threshold()) then - desc_a%matrix_data(psb_dec_type_) = psb_desc_large_bld_ - loc_col = (m+np-1)/np - allocate(desc_a%loc_to_glob(loc_col), desc_a%lprm(1),& - & desc_a%ptree(2),stat=info) - if (info == 0) call InitPairSearchTree(desc_a%ptree,info) - if (info /= 0) then - info=2025 - int_err(1)=loc_col - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - ! set LOC_TO_GLOB array to all "-1" values - desc_a%lprm(1) = 0 - desc_a%loc_to_glob(:) = -1 - k = 0 - do i=1,m - if (info == 0) then - call parts(i,m,np,prc_v,nprocs) - if (nprocs > np) then - info=570 - int_err(1)=3 - int_err(2)=np - int_err(3)=nprocs - int_err(4)=i - err=info - call psb_errpush(err,name,int_err) - goto 9999 - else if (nprocs <= 0) then - info=575 - int_err(1)=3 - int_err(2)=nprocs - int_err(3)=i - err=info - call psb_errpush(err,name,int_err) - goto 9999 - else - do j=1,nprocs - if ((prc_v(j) > np-1).or.(prc_v(j) < 0)) then - info=580 - int_err(1)=3 - int_err(2)=prc_v(j) - int_err(3)=i - err=info - call psb_errpush(err,name,int_err) - goto 9999 - end if - end do - endif - j=1 - do - if (j > nprocs) exit - if (prc_v(j) == me) exit - j=j+1 - enddo - - if (j <= nprocs) then - if (prc_v(j) == me) then - ! this point belongs to me - k = k + 1 - call psb_check_size((k+1),desc_a%loc_to_glob,info,pad=-1) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='psb_check_size') - goto 9999 - end if - desc_a%loc_to_glob(k) = i - call SearchInsKeyVal(desc_a%ptree,i,k,glx,info) - if (nprocs > 1) then - call psb_check_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-1) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='psb_check_size') - goto 9999 - end if - itmpov = itmpov + 1 - temp_ovrlap(itmpov) = i - itmpov = itmpov + 1 - temp_ovrlap(itmpov) = nprocs - temp_ovrlap(itmpov+1:itmpov+nprocs) = prc_v(1:nprocs) - itmpov = itmpov + nprocs - endif + do i=1,m + if (info == 0) then + call parts(i,m,np,prc_v,nprocs) + if (nprocs > np) then + info=570 + int_err(1)=3 + int_err(2)=np + int_err(3)=nprocs + int_err(4)=i + err=info + call psb_errpush(err,name,int_err) + goto 9999 + else if (nprocs <= 0) then + info=575 + int_err(1)=3 + int_err(2)=nprocs + int_err(3)=i + err=info + call psb_errpush(err,name,int_err) + goto 9999 + else + do j=1,nprocs + if ((prc_v(j) > np-1).or.(prc_v(j) < 0)) then + info=580 + int_err(1)=3 + int_err(2)=prc_v(j) + int_err(3)=i + err=info + call psb_errpush(err,name,int_err) + goto 9999 end if - end if - end if - enddo - if (info /= 0) then - info=4000 - call psb_errpush(info,name) - goto 9999 - endif - loc_row = k - - else - - desc_a%matrix_data(psb_dec_type_) = psb_desc_bld_ - do i=1,m - if (info == 0) then - call parts(i,m,np,prc_v,nprocs) - if (nprocs > np) then - info=570 - int_err(1)=3 - int_err(2)=np - int_err(3)=nprocs - int_err(4)=i - err=info - call psb_errpush(err,name,int_err) - goto 9999 - else if (nprocs <= 0) then - info=575 - int_err(1)=3 - int_err(2)=nprocs - int_err(3)=i - err=info - call psb_errpush(err,name,int_err) - goto 9999 - else - do j=1,nprocs - if ((prc_v(j) > np-1).or.(prc_v(j) < 0)) then - info=580 - int_err(1)=3 - int_err(2)=prc_v(j) - int_err(3)=i - err=info - call psb_errpush(err,name,int_err) - goto 9999 - end if - end do - endif - desc_a%glob_to_loc(i) = -(np+prc_v(1)+1) - j=1 - do - if (j > nprocs) exit - if (prc_v(j) == me) exit - j=j+1 - enddo - if (j <= nprocs) then - if (prc_v(j) == me) then - ! this point belongs to me - counter=counter+1 - desc_a%glob_to_loc(i) = counter - if (nprocs > 1) then - call psb_check_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-1) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='psb_check_size') + end do + endif + desc_a%glob_to_loc(i) = -(np+prc_v(1)+1) + j=1 + do + if (j > nprocs) exit + if (prc_v(j) == me) exit + j=j+1 + enddo + if (j <= nprocs) then + if (prc_v(j) == me) then + ! this point belongs to me + counter=counter+1 + desc_a%glob_to_loc(i) = counter + if (nprocs > 1) then + if ((itmpov+2+nprocs) > size(temp_ovrlap)) then + ns = max(itmpov+2+nprocs,int(1.25*size(temp_ovrlap))) + call psb_realloc(ns,temp_ovrlap,info,pad=-1) + if (info /= 0) then + info=2025 + int_err(1)=m + err=info + call psb_errpush(err,name,int_err) goto 9999 - end if - itmpov = itmpov + 1 - temp_ovrlap(itmpov) = i - itmpov = itmpov + 1 - temp_ovrlap(itmpov) = nprocs - temp_ovrlap(itmpov+1:itmpov+nprocs) = prc_v(1:nprocs) - itmpov = itmpov + nprocs + endif endif - end if + itmpov = itmpov + 1 + temp_ovrlap(itmpov) = i + itmpov = itmpov + 1 + temp_ovrlap(itmpov) = nprocs + temp_ovrlap(itmpov+1:itmpov+nprocs) = prc_v(1:nprocs) + itmpov = itmpov + nprocs + endif end if - endif - enddo - ! estimate local cols number - loc_row=counter - loc_col=min(2*loc_row,m) - - allocate(desc_a%loc_to_glob(loc_col),& - &desc_a%lprm(1),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - - ! set LOC_TO_GLOB array to all "-1" values - desc_a%lprm(1) = 0 - desc_a%loc_to_glob(:) = -1 - do i=1,m - k = desc_a%glob_to_loc(i) - if (k > 0) then - desc_a%loc_to_glob(k) = i - endif - enddo - - end if + end if + endif + enddo + loc_row=counter ! check on parts function if (debug) write(*,*) 'PSB_CDALL: End main loop:' ,loc_row,itmpov,info @@ -377,20 +260,36 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info) call psb_transfer(ov_idx,desc_a%ovrlap_index,info) if (info == 0) call psb_transfer(ov_el,desc_a%ovrlap_elem,info) - if (info == 0) deallocate(prc_v,temp_ovrlap,stat=info) + deallocate(prc_v,temp_ovrlap,stat=info) if (info /= no_err) then info=4000 err=info call psb_errpush(err,name) Goto 9999 endif - ! At this point overlap_elem is OK. - desc_a%matrix_data(psb_ovl_state_) = psb_cd_ovl_asb_ + ! estimate local cols number + loc_col=min(2*loc_row,m) + + allocate(desc_a%loc_to_glob(loc_col),& + &desc_a%lprm(1),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + ! set LOC_TO_GLOB array to all "-1" values + desc_a%lprm(1) = 0 + desc_a%loc_to_glob(:) = -1 + do i=1,m + k = desc_a%glob_to_loc(i) + if (k > 0) then + desc_a%loc_to_glob(k) = i + endif + enddo ! set fields in desc_a%MATRIX_DATA.... desc_a%matrix_data(psb_n_row_) = loc_row desc_a%matrix_data(psb_n_col_) = loc_row - call psb_cd_set_bld(desc_a,info) call psb_realloc(1,desc_a%halo_index, info) if (info /= no_err) then @@ -402,8 +301,10 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info) desc_a%halo_index(:) = -1 + desc_a%matrix_data(psb_m_) = m desc_a%matrix_data(psb_n_) = n + desc_a%matrix_data(psb_dec_type_) = psb_desc_bld_ desc_a%matrix_data(psb_ctxt_) = ictxt call psb_get_mpicomm(ictxt,desc_a%matrix_data(psb_mpi_c_)) diff --git a/base/tools/psb_cdalv.f90 b/base/tools/psb_cdalv.f90 index 5c611f0e..67a4e338 100644 --- a/base/tools/psb_cdalv.f90 +++ b/base/tools/psb_cdalv.f90 @@ -325,13 +325,12 @@ subroutine psb_cdalv(m, v, ictxt, desc_a, info, flag) call psb_transfer(ov_idx,desc_a%ovrlap_index,info) if (info == 0) call psb_transfer(ov_el,desc_a%ovrlap_elem,info) - if (info == 0) deallocate(temp_ovrlap,stat=info) + deallocate(temp_ovrlap,stat=info) if (info /= 0) then info=4000 call psb_errpush(info,name) goto 9999 endif - desc_a%matrix_data(psb_ovl_state_) = psb_cd_ovl_asb_ ! set fields in desc_a%MATRIX_DATA.... desc_a%matrix_data(psb_n_row_) = loc_row diff --git a/base/tools/psb_cdasb.f90 b/base/tools/psb_cdasb.f90 index 6b973511..762e3c42 100644 --- a/base/tools/psb_cdasb.f90 +++ b/base/tools/psb_cdasb.f90 @@ -130,16 +130,6 @@ subroutine psb_cdasb(desc_a,info) end if if (psb_is_large_dec(dectype) ) then - if (allocated(desc_a%ptree)) then - call FreePairSearchTree(desc_a%ptree) - deallocate(desc_a%ptree,stat=info) - if (info /= 0) then - info=2059 - call psb_errpush(info,name) - goto 9999 - end if - end if - desc_a%matrix_data(psb_dec_type_) = psb_desc_large_asb_ !!$ write(0,*) 'Done large dec asmbly',desc_a%matrix_data(psb_dec_type_),& !!$ & psb_desc_large_asb_,psb_is_asb_dec(desc_a%matrix_data(psb_dec_type_)) diff --git a/base/tools/psb_cddec.f90 b/base/tools/psb_cddec.f90 index b884094f..ddfcd950 100644 --- a/base/tools/psb_cddec.f90 +++ b/base/tools/psb_cddec.f90 @@ -117,7 +117,7 @@ subroutine psb_cddec(nloc, ictxt, desc_a, info) !locals Integer :: i,j,np,me,err,n,itmpov, k,& - & l_ov_ix,l_ov_el,idx, err_act,m, ip,glx + & l_ov_ix,l_ov_el,idx, err_act,m, ip Integer :: INT_ERR(5), thalo(1), tovr(1) integer, allocatable :: nlv(:) logical, parameter :: debug=.false. @@ -164,107 +164,57 @@ subroutine psb_cddec(nloc, ictxt, desc_a, info) !count local rows number - if ( m >psb_cd_get_large_threshold()) then - allocate(desc_a%loc_to_glob(nloc), desc_a%lprm(1),& - & desc_a%ptree(2),desc_a%matrix_data(psb_mdata_size_),stat=info) - if (info == 0) call InitPairSearchTree(desc_a%ptree,info) - if (info /= 0) then - info=2025 - int_err(1)=nloc - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - ! set LOC_TO_GLOB array to all "-1" values - desc_a%lprm(1) = 0 - desc_a%loc_to_glob(:) = -1 - desc_a%matrix_data(psb_n_row_) = nloc - desc_a%matrix_data(psb_n_col_) = nloc - desc_a%matrix_data(psb_m_) = m - desc_a%matrix_data(psb_n_) = m - desc_a%matrix_data(psb_dec_type_) = psb_desc_large_bld_ - desc_a%matrix_data(psb_ctxt_) = ictxt - call psb_get_mpicomm(ictxt,desc_a%matrix_data(psb_mpi_c_)) - - do ip=0, np-1 - if (ip==me) then - do i=1, nlv(ip) - call SearchInsKeyVal(desc_a%ptree,j,i,glx,info) - desc_a%loc_to_glob(i) = j - j = j + 1 - enddo - else - do i=1, nlv(ip) - j = j + 1 - enddo - endif - enddo - - tovr = -1 - thalo = -1 - - desc_a%lprm(:) = 0 - - call psi_cnv_dsc(thalo,tovr,desc_a,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psi_bld_cdesc') - goto 9999 - end if - + ! allocate work vector +!!$ allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),& +!!$ & desc_a%loc_to_glob(nloc),desc_a%lprm(1),& +!!$ & desc_a%ovrlap_index(1),desc_a%ovrlap_elem(1),& +!!$ & desc_a%halo_index(1),desc_a%bnd_elem(1),stat=info) + allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),& + & desc_a%loc_to_glob(m),desc_a%lprm(1),stat=info) + if (info /= 0) then + info=2025 + int_err(1)=m + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif - desc_a%matrix_data(psb_dec_type_) = psb_desc_large_asb_ - else - allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),& - & desc_a%loc_to_glob(m),desc_a%lprm(1),stat=info) - if (info /= 0) then - info=2025 - int_err(1)=m - call psb_errpush(info,name,i_err=int_err) - goto 9999 + desc_a%matrix_data(psb_n_row_) = nloc + desc_a%matrix_data(psb_n_col_) = nloc + desc_a%matrix_data(psb_m_) = m + desc_a%matrix_data(psb_n_) = m + desc_a%matrix_data(psb_dec_type_) = psb_desc_bld_ + desc_a%matrix_data(psb_ctxt_) = ictxt + call psb_get_mpicomm(ictxt,desc_a%matrix_data(psb_mpi_c_)) + + j = 1 + do ip=0, np-1 + if (ip==me) then + do i=1, nlv(ip) + desc_a%glob_to_loc(j) = i + desc_a%loc_to_glob(i) = j + j = j + 1 + enddo + else + do i=1, nlv(ip) + desc_a%glob_to_loc(j) = -(np+ip+1) + j = j + 1 + enddo endif + enddo + tovr = -1 + thalo = -1 + + desc_a%lprm(:) = 0 - desc_a%matrix_data(psb_n_row_) = nloc - desc_a%matrix_data(psb_n_col_) = nloc - desc_a%matrix_data(psb_m_) = m - desc_a%matrix_data(psb_n_) = m - desc_a%matrix_data(psb_dec_type_) = psb_desc_bld_ - desc_a%matrix_data(psb_ctxt_) = ictxt - call psb_get_mpicomm(ictxt,desc_a%matrix_data(psb_mpi_c_)) - - j = 1 - do ip=0, np-1 - if (ip==me) then - do i=1, nlv(ip) - desc_a%glob_to_loc(j) = i - desc_a%loc_to_glob(i) = j - j = j + 1 - enddo - else - do i=1, nlv(ip) - desc_a%glob_to_loc(j) = -(np+ip+1) - j = j + 1 - enddo - endif - enddo - - tovr = -1 - thalo = -1 - - desc_a%lprm(:) = 0 - - desc_a%matrix_data(psb_ovl_state_) = psb_cd_ovl_bld_ - - call psi_cnv_dsc(thalo,tovr,desc_a,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psi_bld_cdesc') - goto 9999 - end if - - desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_ + call psi_cnv_dsc(thalo,tovr,desc_a,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psi_bld_cdesc') + goto 9999 + end if - endif + desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_ call psb_erractionrestore(err_act) return diff --git a/base/tools/psb_cdren.f90 b/base/tools/psb_cdren.f90 index 54709872..cfb0f7a7 100644 --- a/base/tools/psb_cdren.f90 +++ b/base/tools/psb_cdren.f90 @@ -45,9 +45,15 @@ subroutine psb_cdren(trans,iperm,desc_a,info) use psb_error_mod use psb_penv_mod use psb_string_mod - use psb_serial_mod implicit none + interface isaperm + logical function isaperm(n,ip) + integer, intent(in) :: n + integer, intent(inout) :: ip(*) + end function isaperm + end interface + !...parameters.... type(psb_desc_type), intent(inout) :: desc_a integer, intent(inout) :: iperm(:) @@ -57,6 +63,8 @@ subroutine psb_cdren(trans,iperm,desc_a,info) integer :: i,j,np,me, n_col, kh, nh integer :: dectype integer :: ictxt,n_row, int_err(5), err_act + real(kind(1.d0)) :: time(10), mpi_wtime, real_err(6) + external mpi_wtime logical, parameter :: debug=.false. character(len=20) :: name @@ -65,6 +73,8 @@ subroutine psb_cdren(trans,iperm,desc_a,info) call psb_erractionsave(err_act) name = 'psb_dcren' + time(1) = mpi_wtime() + ictxt = psb_cd_get_context(desc_a) dectype = psb_cd_get_dectype(desc_a) n_row = psb_cd_get_local_rows(desc_a) @@ -197,6 +207,13 @@ subroutine psb_cdren(trans,iperm,desc_a,info) endif + time(4) = mpi_wtime() + time(4) = time(4) - time(3) + if (debug) then + call psb_amx(ictxt, time(4)) + + write (*, *) ' comm structs assembly: ', time(4)*1.d-3 + end if call psb_erractionrestore(err_act) return diff --git a/base/tools/psb_dcdovr.f90 b/base/tools/psb_dcdovr.f90 index a7fb01e3..aa0d3aab 100644 --- a/base/tools/psb_dcdovr.f90 +++ b/base/tools/psb_dcdovr.f90 @@ -48,8 +48,6 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) use psb_serial_mod use psb_descriptor_type - Use psb_prec_type - Use psb_prec_mod use psb_error_mod use psb_penv_mod use psb_tools_mod @@ -157,165 +155,87 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) l_tmp_ovr_idx = novr*(3*Max(2*index_dim,1)+1) l_tmp_halo = novr*(3*Size(desc_a%halo_index)) - call psb_cd_set_bld(desc_ov,info) - desc_ov%matrix_data(psb_ovl_state_)=psb_cd_ovl_bld_ - + if (psb_is_large_desc(desc_a)) then + desc_ov%matrix_data(psb_dec_type_) = psb_desc_large_bld_ + else + desc_ov%matrix_data(psb_dec_type_) = psb_desc_bld_ + end if If(debug) then Write(0,*)'Start cdovrbld',me,lworks,lworkr call psb_barrier(ictxt) endif + if (.false.) then + ! + ! The real work goes on in here.... + ! + Call psb_cdovrbld(novr,desc_ov,desc_a,a,& + & l_tmp_halo,l_tmp_ovr_idx,lworks,lworkr,info) + + if (info /= 0) then + info=4010 + ch_err='psb_cdovrbld' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + If(debug) then + Write(0,*)'Done cdovrbld',me,lworks,lworkr + call psb_barrier(ictxt) + endif - Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - - Allocate(works(lworks),workr(lworkr),t_halo_in(l_tmp_halo),& - & t_halo_out(l_tmp_halo), temp(lworkr),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - - - call psb_sp_all(blk,max(lworks,lworkr),info) - if (info /= 0) then - info=4010 - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - blk%fida='COO' - - Allocate(tmp_ovr_idx(l_tmp_ovr_idx),tmp_halo(l_tmp_halo),& - & halo(size(desc_a%halo_index)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - halo(:) = desc_a%halo_index(:) - desc_ov%ovrlap_elem(:) = -1 - tmp_ovr_idx(:) = -1 - tmp_halo(:) = -1 - counter_e = 1 - tot_recv = 0 - counter_h = 1 - counter_o = 1 - - ! Init overlap with desc_a%ovrlap (if any) - counter = 1 - Do While (desc_a%ovrlap_index(counter) /= -1) - proc = desc_a%ovrlap_index(counter+psb_proc_id_) - n_elem_recv = desc_a%ovrlap_index(counter+psb_n_elem_recv_) - n_elem_send = desc_a%ovrlap_index(counter+n_elem_recv+psb_n_elem_send_) - - Do j=0,n_elem_recv-1 - - idx = desc_a%ovrlap_index(counter+psb_elem_recv_+j) - If(idx > Size(desc_ov%loc_to_glob)) then - info=-3 - call psb_errpush(info,name) - goto 9999 - endif - - gidx = desc_ov%loc_to_glob(idx) - - call psb_check_size((counter_o+3),tmp_ovr_idx,info,pad=-1) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='psb_check_size') - goto 9999 - end if + else - tmp_ovr_idx(counter_o)=proc - tmp_ovr_idx(counter_o+1)=1 - tmp_ovr_idx(counter_o+2)=gidx - tmp_ovr_idx(counter_o+3)=-1 - counter_o=counter_o+3 - end Do - counter=counter+n_elem_recv+n_elem_send+2 - end Do + Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + Allocate(works(lworks),workr(lworkr),t_halo_in(l_tmp_halo),& + & t_halo_out(l_tmp_halo), temp(lworkr),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if - ! - ! A picture is in order to understand what goes on here. - ! I is the internal part; H is halo, R row, C column. The final - ! matrix with N levels of overlap looks like this - ! - ! I | Hc1 | 0 | 0 | - ! -------|-----|-----|-----| - ! Hr1 | Hd1 | Hc2 | 0 | - ! -------|-----|-----|-----| - ! 0 | Hr2 | Hd2 | Hc2 | - ! -------|-----|-----|-----| - ! 0 | 0 | Hr3 | Hd3 | Hc3 - ! - ! At the start we already have I and Hc1, so we know the row - ! indices that will make up Hr1, and also who owns them. As we - ! actually get those rows, we receive the column indices in Hc2; - ! these define the row indices for Hr2, and so on. When we have - ! reached the desired level HrN, we may ignore HcN. - ! - ! - Do i_ovr = 1, novr + call psb_sp_all(blk,max(lworks,lworkr),info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if - if (debug) write(0,*) me,'Running on overlap level ',i_ovr,' of ',novr + blk%fida='COO' - ! - ! At this point, halo contains a valid halo corresponding to the - ! matrix enlarged with the elements in the frontier for I_OVR-1. - ! At the start, this is just the halo for A; the rows for indices in - ! the first halo will contain column indices defining the second halo - ! level and so on. - ! - bsdindx(:) = 0 - sdsz(:) = 0 - brvindx(:) = 0 - rvsz(:) = 0 - idxr = 0 - idxs = 0 - counter = 1 - counter_t = 1 - - - Do While (halo(counter) /= -1) - tot_elem=0 - proc=halo(counter+psb_proc_id_) - n_elem_recv=halo(counter+psb_n_elem_recv_) - n_elem_send=halo(counter+n_elem_recv+psb_n_elem_send_) - If ((counter+n_elem_recv+n_elem_send) > Size(halo)) then - info = -1 - call psb_errpush(info,name) - goto 9999 - end If - tot_recv=tot_recv+n_elem_recv - if (debug) write(0,*) me,' CDOVRBLD tot_recv:',proc,n_elem_recv,tot_recv - ! - ! - ! The format of the halo vector exists in two forms: 1. Temporary - ! 2. Assembled. In this loop we are using the (assembled) halo_in and - ! copying it into (temporary) halo_out; this is because tmp_halo will - ! be enlarged with the new column indices received, and will reassemble - ! everything for the next iteration. - ! + Allocate(tmp_ovr_idx(l_tmp_ovr_idx),tmp_halo(l_tmp_halo),& + & halo(size(desc_a%halo_index)),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + halo(:) = desc_a%halo_index(:) + desc_ov%ovrlap_elem(:) = -1 + tmp_ovr_idx(:) = -1 + tmp_halo(:) = -1 + counter_e = 1 + tot_recv = 0 + counter_h = 1 + counter_o = 1 + + ! Init overlap with desc_a%ovrlap (if any) + counter = 1 + Do While (desc_a%ovrlap_index(counter) /= -1) + proc = desc_a%ovrlap_index(counter+psb_proc_id_) + n_elem_recv = desc_a%ovrlap_index(counter+psb_n_elem_recv_) + n_elem_send = desc_a%ovrlap_index(counter+n_elem_recv+psb_n_elem_send_) - ! - ! add recv elements in halo_index into ovrlap_index - ! Do j=0,n_elem_recv-1 - If((counter+psb_elem_recv_+j)>Size(halo)) then - info=-2 - call psb_errpush(info,name) - goto 9999 - end If - idx = halo(counter+psb_elem_recv_+j) + idx = desc_a%ovrlap_index(counter+psb_elem_recv_+j) If(idx > Size(desc_ov%loc_to_glob)) then info=-3 call psb_errpush(info,name) @@ -336,343 +256,443 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) tmp_ovr_idx(counter_o+2)=gidx tmp_ovr_idx(counter_o+3)=-1 counter_o=counter_o+3 + end Do + counter=counter+n_elem_recv+n_elem_send+2 + end Do - if (.not.psb_is_large_desc(desc_ov)) then - call psb_check_size((counter_h+3),tmp_halo,info,pad=-1) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='psb_check_size') - goto 9999 - end if - tmp_halo(counter_h)=proc - tmp_halo(counter_h+1)=1 - tmp_halo(counter_h+2)=idx - tmp_halo(counter_h+3)=-1 - counter_h=counter_h+3 - end if - Enddo - if (debug) write(0,*) me,'Checktmp_o_i Loop Mid1',tmp_ovr_idx(1:10) - counter = counter+n_elem_recv + ! + ! A picture is in order to understand what goes on here. + ! I is the internal part; H is halo, R row, C column. The final + ! matrix with N levels of overlap looks like this + ! + ! I | Hc1 | 0 | 0 | + ! -------|-----|-----|-----| + ! Hr1 | Hd1 | Hc2 | 0 | + ! -------|-----|-----|-----| + ! 0 | Hr2 | Hd2 | Hc2 | + ! -------|-----|-----|-----| + ! 0 | 0 | Hr3 | Hd3 | Hc3 + ! + ! At the start we already have I and Hc1, so we know the row + ! indices that will make up Hr1, and also who owns them. As we + ! actually get those rows, we receive the column indices in Hc2; + ! these define the row indices for Hr2, and so on. When we have + ! reached the desired level HrN, we may ignore HcN. + ! + ! + Do i_ovr = 1, novr + + if (debug) write(0,*) me,'Running on overlap level ',i_ovr,' of ',novr ! - ! add send elements in halo_index into ovrlap_index + ! At this point, halo contains a valid halo corresponding to the + ! matrix enlarged with the elements in the frontier for I_OVR-1. + ! At the start, this is just the halo for A; the rows for indices in + ! the first halo will contain column indices defining the second halo + ! level and so on. ! - Do j=0,n_elem_send-1 - - idx = halo(counter+psb_elem_send_+j) - gidx = desc_ov%loc_to_glob(idx) - if (idx > psb_cd_get_local_rows(Desc_a)) & - & write(0,*) me,i_ovr,'Out of local rows ',& - & idx,psb_cd_get_local_rows(Desc_a) - - call psb_check_size((counter_o+3),tmp_ovr_idx,info,pad=-1) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='psb_check_size') + bsdindx(:) = 0 + sdsz(:) = 0 + brvindx(:) = 0 + rvsz(:) = 0 + idxr = 0 + idxs = 0 + counter = 1 + counter_t = 1 + + + Do While (halo(counter) /= -1) + tot_elem=0 + proc=halo(counter+psb_proc_id_) + n_elem_recv=halo(counter+psb_n_elem_recv_) + n_elem_send=halo(counter+n_elem_recv+psb_n_elem_send_) + If ((counter+n_elem_recv+n_elem_send) > Size(halo)) then + info = -1 + call psb_errpush(info,name) goto 9999 - end if - - tmp_ovr_idx(counter_o)=proc - tmp_ovr_idx(counter_o+1)=1 - tmp_ovr_idx(counter_o+2)=gidx - tmp_ovr_idx(counter_o+3)=-1 - counter_o=counter_o+3 + end If + tot_recv=tot_recv+n_elem_recv + if (debug) write(0,*) me,' CDOVRBLD tot_recv:',proc,n_elem_recv,tot_recv + ! + ! + ! The format of the halo vector exists in two forms: 1. Temporary + ! 2. Assembled. In this loop we are using the (assembled) halo_in and + ! copying it into (temporary) halo_out; this is because tmp_halo will + ! be enlarged with the new column indices received, and will reassemble + ! everything for the next iteration. + ! ! - ! Prepare to exchange the halo rows with the other proc. + ! add recv elements in halo_index into ovrlap_index ! - If (i_ovr < (novr)) Then - n_elem = psb_sp_get_nnz_row(idx,a) + Do j=0,n_elem_recv-1 + If((counter+psb_elem_recv_+j)>Size(halo)) then + info=-2 + call psb_errpush(info,name) + goto 9999 + end If - call psb_check_size((idxs+tot_elem+n_elem),works,info) + idx = halo(counter+psb_elem_recv_+j) + If(idx > Size(desc_ov%loc_to_glob)) then + info=-3 + call psb_errpush(info,name) + goto 9999 + endif + + gidx = desc_ov%loc_to_glob(idx) + + call psb_check_size((counter_o+3),tmp_ovr_idx,info,pad=-1) if (info /= 0) then info=4010 call psb_errpush(info,name,a_err='psb_check_size') goto 9999 end if - If((n_elem) > size(blk%ia2)) Then - isz = max((3*size(blk%ia2))/2,(n_elem)) - if (debug) write(0,*) me,'Realloc blk',isz - call psb_sp_reall(blk,isz,info) + tmp_ovr_idx(counter_o)=proc + tmp_ovr_idx(counter_o+1)=1 + tmp_ovr_idx(counter_o+2)=gidx + tmp_ovr_idx(counter_o+3)=-1 + counter_o=counter_o+3 + if (.not.psb_is_large_desc(desc_ov)) then + call psb_check_size((counter_h+3),tmp_halo,info,pad=-1) if (info /= 0) then info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) + call psb_errpush(info,name,a_err='psb_check_size') goto 9999 end if - End If - call psb_sp_getblk(idx,a,blk,info) + tmp_halo(counter_h)=proc + tmp_halo(counter_h+1)=1 + tmp_halo(counter_h+2)=idx + tmp_halo(counter_h+3)=-1 + + counter_h=counter_h+3 + end if + + Enddo + if (debug) write(0,*) me,'Checktmp_o_i Loop Mid1',tmp_ovr_idx(1:10) + counter = counter+n_elem_recv + + ! + ! add send elements in halo_index into ovrlap_index + ! + Do j=0,n_elem_send-1 + + idx = halo(counter+psb_elem_send_+j) + gidx = desc_ov%loc_to_glob(idx) + if (idx > psb_cd_get_local_rows(Desc_a)) & + & write(0,*) me,i_ovr,'Out of local rows ',& + & idx,psb_cd_get_local_rows(Desc_a) + + call psb_check_size((counter_o+3),tmp_ovr_idx,info,pad=-1) if (info /= 0) then info=4010 - ch_err='psb_sp_getblk' - call psb_errpush(info,name,a_err=ch_err) + call psb_errpush(info,name,a_err='psb_check_size') goto 9999 end if -!!$ write(0,*) me,'Iteration: ',j,i_ovr - Do jj=1,n_elem - works(idxs+tot_elem+jj)=desc_ov%loc_to_glob(blk%ia2(jj)) - End Do - tot_elem=tot_elem+n_elem - End If - Enddo + tmp_ovr_idx(counter_o)=proc + tmp_ovr_idx(counter_o+1)=1 + tmp_ovr_idx(counter_o+2)=gidx + tmp_ovr_idx(counter_o+3)=-1 + counter_o=counter_o+3 + ! + ! Prepare to exchange the halo rows with the other proc. + ! + If (i_ovr < (novr)) Then + n_elem = psb_sp_get_nnz_row(idx,a) - if (i_ovr < novr) then - if (tot_elem > 1) then - call imsr(tot_elem,works(idxs+1)) - lx = works(idxs+1) - i = 1 - j = 1 - do - j = j + 1 - if (j > tot_elem) exit - if (works(idxs+j) /= lx) then - i = i + 1 - works(idxs+i) = works(idxs+j) - lx = works(idxs+i) + call psb_check_size((idxs+tot_elem+n_elem),works,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_check_size') + goto 9999 end if - end do - tot_elem = i - endif - if (debug) write(0,*) me,'Checktmp_o_i Loop Mid2',tmp_ovr_idx(1:10) - sdsz(proc+1) = tot_elem - idxs = idxs + tot_elem - end if - counter = counter+n_elem_send+3 - if (debug) write(0,*) me,'Checktmp_o_i Loop End',tmp_ovr_idx(1:10) - Enddo - if (debug) write(0,*)me,'End phase 1 CDOVRBLD', m, n_col, tot_recv - - if (i_ovr < novr) then - ! - ! Exchange data requests with everybody else: so far we have - ! accumulated RECV requests, we have an all-to-all to build - ! matchings SENDs. - ! - call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 - ch_err='mpi_alltoall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - idxs = 0 - idxr = 0 - counter = 1 - Do - proc=halo(counter) - if (proc == -1) exit - n_elem_recv = halo(counter+psb_n_elem_recv_) - counter = counter+n_elem_recv - n_elem_send = halo(counter+psb_n_elem_send_) - - bsdindx(proc+1) = idxs - idxs = idxs + sdsz(proc+1) - brvindx(proc+1) = idxr - idxr = idxr + rvsz(proc+1) + + If((n_elem) > size(blk%ia2)) Then + isz = max((3*size(blk%ia2))/2,(n_elem)) + if (debug) write(0,*) me,'Realloc blk',isz + call psb_sp_reall(blk,isz,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + End If + + call psb_sp_getblk(idx,a,blk,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_getblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if +!!$ write(0,*) me,'Iteration: ',j,i_ovr + Do jj=1,n_elem + works(idxs+tot_elem+jj)=desc_ov%loc_to_glob(blk%ia2(jj)) + End Do + tot_elem=tot_elem+n_elem + End If + + Enddo + + + if (i_ovr < novr) then + if (tot_elem > 1) then + call imsr(tot_elem,works(idxs+1)) + lx = works(idxs+1) + i = 1 + j = 1 + do + j = j + 1 + if (j > tot_elem) exit + if (works(idxs+j) /= lx) then + i = i + 1 + works(idxs+i) = works(idxs+j) + lx = works(idxs+i) + end if + end do + tot_elem = i + endif + if (debug) write(0,*) me,'Checktmp_o_i Loop Mid2',tmp_ovr_idx(1:10) + sdsz(proc+1) = tot_elem + idxs = idxs + tot_elem + end if counter = counter+n_elem_send+3 + if (debug) write(0,*) me,'Checktmp_o_i Loop End',tmp_ovr_idx(1:10) Enddo - - iszr=sum(rvsz) - if (max(iszr,1) > lworkr) then - call psb_realloc(max(iszr,1),workr,info) + if (debug) write(0,*)me,'End phase 1 CDOVRBLD', m, n_col, tot_recv + + if (i_ovr < novr) then + ! + ! Exchange data requests with everybody else: so far we have + ! accumulated RECV requests, we have an all-to-all to build + ! matchings SENDs. + ! + call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) if (info /= 0) then info=4010 - ch_err='psb_realloc' + ch_err='mpi_alltoall' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - lworkr=max(iszr,1) - end if - - call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& - & workr,rvsz,brvindx,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 - ch_err='mpi_alltoallv' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if (debug) write(0,*) 'ISZR :',iszr + idxs = 0 + idxr = 0 + counter = 1 + Do + proc=halo(counter) + if (proc == -1) exit + n_elem_recv = halo(counter+psb_n_elem_recv_) + counter = counter+n_elem_recv + n_elem_send = halo(counter+psb_n_elem_send_) + + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + counter = counter+n_elem_send+3 + Enddo + + iszr=sum(rvsz) + if (max(iszr,1) > lworkr) then + call psb_realloc(max(iszr,1),workr,info) + if (info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + lworkr=max(iszr,1) + end if - if (psb_is_large_desc(desc_a)) then - call psb_check_size(iszr,maskr,info) + call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& + & workr,rvsz,brvindx,mpi_integer,icomm,info) if (info /= 0) then info=4010 - call psb_errpush(info,name,a_err='psb_check_size') + ch_err='mpi_alltoallv' + call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - call psi_idx_cnv(iszr,workr,maskr,desc_ov,info) - iszs = count(maskr(1:iszr)<=0) - if (iszs > size(works)) call psb_realloc(iszs,works,info) - j = 0 - do i=1,iszr - if (maskr(i) < 0) then - j=j+1 - works(j) = workr(i) - end if - end do - ! - ! fnd_owner on desc_a because we want the procs who - ! owned the rows from the beginning! - ! - call psi_fnd_owner(iszs,works,temp,desc_a,info) - n_col=psb_cd_get_local_cols(desc_ov) - - do i=1,iszs - idx = works(i) - n_col = psb_cd_get_local_cols(desc_ov) - call psi_idx_ins_cnv(idx,lidx,desc_ov,info) - if (psb_cd_get_local_cols(desc_ov) > n_col ) then - ! - ! This is a new index. Assigning a local index as - ! we receive them guarantees that all indices for HALO(I) - ! will be less than those for HALO(J) whenever I size(works)) call psb_realloc(iszs,works,info) + j = 0 + do i=1,iszr + if (maskr(i) < 0) then + j=j+1 + works(j) = workr(i) end if + end do + ! + ! fnd_owner on desc_a because we want the procs who + ! owned the rows from the beginning! + ! + call psi_fnd_owner(iszs,works,temp,desc_a,info) + n_col=psb_cd_get_local_cols(desc_ov) + + do i=1,iszs + idx = works(i) + n_col = psb_cd_get_local_cols(desc_ov) + call psi_idx_ins_cnv(idx,lidx,desc_ov,info) + if (psb_cd_get_local_cols(desc_ov) > n_col ) then + ! + ! This is a new index. Assigning a local index as + ! we receive them guarantees that all indices for HALO(I) + ! will be less than those for HALO(J) whenever I 0) then + + allocate(ovrel(i),stat=info) if (info /= 0 ) then info = 4000 call psb_errpush(info,name) goto 9999 end if - + i=0 j=1 do while(desc%ovrlap_elem(j) /= -1) @@ -38,10 +39,17 @@ subroutine psb_get_ovrlap(ovrel,desc,info) enddo else - info = 1122 - call psb_errpush(info,name) - goto 9999 + + if (allocated(ovrel)) then + deallocate(ovrel,stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Deallocate') + goto 9999 + end if + end if + end if + call psb_erractionrestore(err_act) return diff --git a/base/tools/psb_glob_to_loc.f90 b/base/tools/psb_glob_to_loc.f90 index a1f0fb35..b35d5015 100644 --- a/base/tools/psb_glob_to_loc.f90 +++ b/base/tools/psb_glob_to_loc.f90 @@ -40,7 +40,7 @@ ! info - integer. Eventually returns an error code. ! iact - integer(optional). A character defining the behaviour of this subroutine when is found an index not belonging to the calling process ! -subroutine psb_glob_to_loc2(x,y,desc_a,info,iact,owned) +subroutine psb_glob_to_loc2(x,y,desc_a,info,iact) use psb_descriptor_type use psb_const_mod @@ -52,63 +52,51 @@ subroutine psb_glob_to_loc2(x,y,desc_a,info,iact,owned) !...parameters.... type(psb_desc_type), intent(in) :: desc_a - integer, intent(in) :: x(:) - integer, intent(out) :: y(:), info - character, intent(in), optional :: iact - logical, intent(in), optional :: owned + integer, intent(in) :: x(:) + integer, intent(out) :: y(:), info + character, intent(in), optional :: iact !....locals.... - integer :: n, i, tmp - character :: act - integer :: int_err(5), err_act - real(kind(1.d0)) :: real_val - integer, parameter :: zero=0 - logical :: owned_ + integer :: n, i, tmp + character :: act + integer :: int_err(5), err_act + real(kind(1.d0)) :: real_val + integer, parameter :: zero=0 character(len=20) :: name - integer :: ictxt, iam, np if(psb_get_errstatus() /= 0) return info=0 name = 'glob_to_loc' - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt,iam,np) call psb_erractionsave(err_act) if (present(iact)) then act=iact else - act='I' + act='A' endif act = toupper(act) - if (present(owned)) then - owned_ = owned - else - owned_ = .false. - end if int_err=0 real_val = 0.d0 n = size(x) - call psi_idx_cnv(n,x,y,desc_a,info,owned=owned_) + call psi_idx_cnv(n,x,y,desc_a,info) select case(act) - case('I') + case('E','I') + call psb_erractionrestore(err_act) + return case('W') - if (count(y(1:n)<0) >0) then - write(0,'("Out of bounds input in subroutine glob_to_loc")') + if ((info /= 0).or.(count(y(1:n)<0) >0)) then + write(0,'("Error ",i5," in subroutine glob_to_loc")') info end if - - case('E','A') - if (count(y(1:n)<0) >0) then - info = 151 + case('A') + if ((info /= 0).or.(count(y(1:n)<0) >0)) then + call psb_errpush(info,name) + goto 9999 end if end select - if (info /= 0) then - call psb_errpush(info,name) - goto 9999 - end if - + call psb_erractionrestore(err_act) return @@ -165,7 +153,7 @@ end subroutine psb_glob_to_loc2 ! info - integer. Eventually returns an error code. ! iact - integer(optional). A character defining the behaviour of this subroutine when is found an index not belonging to the calling process ! -subroutine psb_glob_to_loc(x,desc_a,info,iact,owned) +subroutine psb_glob_to_loc(x,desc_a,info,iact) use psb_penv_mod use psb_descriptor_type @@ -180,58 +168,51 @@ subroutine psb_glob_to_loc(x,desc_a,info,iact,owned) integer, intent(inout) :: x(:) integer, intent(out) :: info character, intent(in), optional :: iact - logical, intent(in), optional :: owned !....locals.... integer :: n, i, tmp, nk, key, idx, ih, nh, lb, ub, lm character :: act - integer :: int_err(5), err_act + integer :: int_err(5), err_act, dectype real(kind(1.d0)) :: real_val, t0, t1,t2 integer, parameter :: zero=0 - logical :: owned_ character(len=20) :: name integer :: ictxt, iam, np if(psb_get_errstatus() /= 0) return info=0 name = 'glob_to_loc' - ictxt = psb_cd_get_context(desc_a) + ictxt = desc_a%matrix_data(psb_ctxt_) call psb_info(ictxt,iam,np) call psb_erractionsave(err_act) + dectype = desc_a%matrix_data(psb_dec_type_) if (present(iact)) then act=iact else - act='I' + act='A' endif act = toupper(act) - if (present(owned)) then - owned_ = owned - else - owned_ = .false. - end if n = size(x) - call psi_idx_cnv(n,x,desc_a,info,owned=owned_) + call psi_idx_cnv(n,x,desc_a,info) select case(act) - case('I') + case('E','I') + call psb_erractionrestore(err_act) + return case('W') - if (count(x(1:n)<0) >0) then - write(0,'("Out of bounds input in subroutine glob_to_loc")') + if ((info /= 0).or.(count(x(1:n)<0) >0)) then + write(0,'("Error ",i5," in subroutine glob_to_loc")') info end if - - case('E','A') - if (count(x(1:n)<0) >0) then - info = 151 + case('A') + if ((info /= 0).or.(count(x(1:n)<0) >0)) then + write(0,*) count(x(1:n)<0) + call psb_errpush(info,name) + goto 9999 end if end select - if (info /= 0) then - call psb_errpush(info,name) - goto 9999 - end if - + call psb_erractionrestore(err_act) return @@ -245,69 +226,69 @@ subroutine psb_glob_to_loc(x,desc_a,info,iact,owned) end if return -!!$contains -!!$ -!!$ subroutine inlbsrch(ipos,key,n,v) -!!$ implicit none -!!$ integer ipos, key, n -!!$ integer v(n) -!!$ -!!$ integer lb, ub, m -!!$ -!!$ -!!$ lb = 1 -!!$ ub = n -!!$ ipos = -1 -!!$ -!!$ do -!!$ if (lb > ub) return -!!$ m = (lb+ub)/2 -!!$ if (key.eq.v(m)) then -!!$ ipos = m -!!$ return -!!$ else if (key.lt.v(m)) then -!!$ ub = m-1 -!!$ else -!!$ lb = m + 1 -!!$ end if -!!$ enddo -!!$ return -!!$ end subroutine inlbsrch -!!$ -!!$ subroutine inner_cnv(n,x,hashsize,hashmask,hashv,glb_lc) -!!$ integer :: n, hashsize,hashmask,x(:), hashv(0:),glb_lc(:,:) -!!$ integer :: i, ih, key, idx,nh,tmp,lb,ub,lm -!!$ do i=1, n -!!$ key = x(i) -!!$ ih = iand(key,hashmask) -!!$ idx = hashv(ih) -!!$ nh = hashv(ih+1) - hashv(ih) -!!$ if (nh > 0) then -!!$ tmp = -1 -!!$ lb = idx -!!$ ub = idx+nh-1 -!!$ do -!!$ if (lb>ub) exit -!!$ lm = (lb+ub)/2 -!!$ if (key==glb_lc(lm,1)) then -!!$ tmp = lm -!!$ exit -!!$ else if (key 0) then -!!$ x(i) = glb_lc(tmp,2) -!!$ else -!!$ x(i) = tmp -!!$ end if -!!$ end do -!!$ end subroutine inner_cnv +contains + + subroutine inlbsrch(ipos,key,n,v) + implicit none + integer ipos, key, n + integer v(n) + + integer lb, ub, m + + + lb = 1 + ub = n + ipos = -1 + + do + if (lb > ub) return + m = (lb+ub)/2 + if (key.eq.v(m)) then + ipos = m + return + else if (key.lt.v(m)) then + ub = m-1 + else + lb = m + 1 + end if + enddo + return + end subroutine inlbsrch + + subroutine inner_cnv(n,x,hashsize,hashmask,hashv,glb_lc) + integer :: n, hashsize,hashmask,x(:), hashv(0:),glb_lc(:,:) + integer :: i, ih, key, idx,nh,tmp,lb,ub,lm + do i=1, n + key = x(i) + ih = iand(key,hashmask) + idx = hashv(ih) + nh = hashv(ih+1) - hashv(ih) + if (nh > 0) then + tmp = -1 + lb = idx + ub = idx+nh-1 + do + if (lb>ub) exit + lm = (lb+ub)/2 + if (key==glb_lc(lm,1)) then + tmp = lm + exit + else if (key 0) then + x(i) = glb_lc(tmp,2) + else + x(i) = tmp + end if + end do + end subroutine inner_cnv end subroutine psb_glob_to_loc diff --git a/base/tools/psb_iins.f90 b/base/tools/psb_iins.f90 index ec8087c9..fb6e3a9c 100644 --- a/base/tools/psb_iins.f90 +++ b/base/tools/psb_iins.f90 @@ -73,6 +73,11 @@ subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl) call psb_erractionsave(err_act) name = 'psb_insvi' +!!$ if (.not.allocated(desc_a%glob_to_loc)) then +!!$ info=3110 +!!$ call psb_errpush(info,name) +!!$ return +!!$ end if if ((.not.allocated(desc_a%matrix_data))) then int_err(1)=3110 call psb_errpush(info,name) @@ -251,6 +256,11 @@ subroutine psb_iinsi(m,irw, val, x, desc_a, info, dupl) call psb_erractionsave(err_act) name = 'psb_iinsi' +!!$ if (.not.allocated(desc_a%glob_to_loc)) then +!!$ info=3110 +!!$ call psb_errpush(info,name) +!!$ return +!!$ end if if ((.not.allocated(desc_a%matrix_data))) then int_err(1)=3110 call psb_errpush(info,name) diff --git a/base/tools/psb_loc_to_glob.f90 b/base/tools/psb_loc_to_glob.f90 index 1c3ed0e7..5da2598d 100644 --- a/base/tools/psb_loc_to_glob.f90 +++ b/base/tools/psb_loc_to_glob.f90 @@ -100,12 +100,12 @@ subroutine psb_loc_to_glob2(x,y,desc_a,info,iact) if (info /= 0) then select case(act) - case('I') + case('E') call psb_erractionrestore(err_act) return case('W') write(0,'("Error ",i5," in subroutine glob_to_loc")') info - case('E','A') + case('A') call psb_errpush(info,name) goto 9999 end select @@ -223,12 +223,12 @@ subroutine psb_loc_to_glob(x,desc_a,info,iact) if (info /= 0) then select case(act) - case('I') + case('E') call psb_erractionrestore(err_act) return case('W') write(0,'("Error ",i5," in subroutine glob_to_loc")') info - case('A','E') + case('A') call psb_errpush(info,name) goto 9999 end select diff --git a/base/tools/psb_zcdovr.f90 b/base/tools/psb_zcdovr.f90 index 8cf423ff..16b01974 100644 --- a/base/tools/psb_zcdovr.f90 +++ b/base/tools/psb_zcdovr.f90 @@ -47,8 +47,6 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) use psb_serial_mod use psb_descriptor_type - Use psb_prec_type - Use psb_prec_mod use psb_error_mod use psb_penv_mod use psb_tools_mod @@ -102,11 +100,11 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) If(debug) Write(0,*)'IN CDOVR1',novr ,m,nnzero,n_col if (novr<0) then - info=10 - int_err(1)=1 - int_err(2)=novr - call psb_errpush(info,name,i_err=int_err) - goto 9999 + info=10 + int_err(1)=1 + int_err(2)=novr + call psb_errpush(info,name,i_err=int_err) + goto 9999 endif if (debug) write(0,*) 'Calling desccpy' @@ -139,9 +137,9 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) ! nztot = psb_sp_get_nnzeros(a) if (nztot>0) then - lovr = ((nztot+m-1)/m)*nhalo*novr - lworks = ((nztot+m-1)/m)*nhalo - lworkr = ((nztot+m-1)/m)*nhalo + lovr = ((nztot+m-1)/m)*nhalo*novr + lworks = ((nztot+m-1)/m)*nhalo + lworkr = ((nztot+m-1)/m)*nhalo else info=-1 call psb_errpush(info,name) @@ -156,164 +154,87 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) l_tmp_ovr_idx = novr*(3*Max(2*index_dim,1)+1) l_tmp_halo = novr*(3*Size(desc_a%halo_index)) - call psb_cd_set_bld(desc_ov,info) - desc_ov%matrix_data(psb_ovl_state_)=psb_cd_ovl_bld_ - + if (psb_is_large_desc(desc_a)) then + desc_ov%matrix_data(psb_dec_type_) = psb_desc_large_bld_ + else + desc_ov%matrix_data(psb_dec_type_) = psb_desc_bld_ + end if If(debug) then Write(0,*)'Start cdovrbld',me,lworks,lworkr call psb_barrier(ictxt) endif + if (.false.) then + ! + ! The real work goes on in here.... + ! + Call psb_cdovrbld(novr,desc_ov,desc_a,a,& + & l_tmp_halo,l_tmp_ovr_idx,lworks,lworkr,info) + + if (info /= 0) then + info=4010 + ch_err='psb_cdovrbld' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if - Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - - Allocate(works(lworks),workr(lworkr),t_halo_in(l_tmp_halo),& - & t_halo_out(l_tmp_halo), temp(lworkr),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - - - call psb_sp_all(blk,max(lworks,lworkr),info) - if (info /= 0) then - info=4010 - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - blk%fida='COO' + If(debug) then + Write(0,*)'Done cdovrbld',me,lworks,lworkr + call psb_barrier(ictxt) + endif - Allocate(tmp_ovr_idx(l_tmp_ovr_idx),tmp_halo(l_tmp_halo),& - & halo(size(desc_a%halo_index)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - halo(:) = desc_a%halo_index(:) - desc_ov%ovrlap_elem(:) = -1 - tmp_ovr_idx(:) = -1 - tmp_halo(:) = -1 - counter_e = 1 - tot_recv = 0 - counter_h = 1 - counter_o = 1 - - ! Init overlap with desc_a%ovrlap (if any) - counter = 1 - Do While (desc_a%ovrlap_index(counter) /= -1) - proc = desc_a%ovrlap_index(counter+psb_proc_id_) - n_elem_recv = desc_a%ovrlap_index(counter+psb_n_elem_recv_) - n_elem_send = desc_a%ovrlap_index(counter+n_elem_recv+psb_n_elem_send_) - - Do j=0,n_elem_recv-1 - - idx = desc_a%ovrlap_index(counter+psb_elem_recv_+j) - If(idx > Size(desc_ov%loc_to_glob)) then - info=-3 - call psb_errpush(info,name) - goto 9999 - endif - - gidx = desc_ov%loc_to_glob(idx) - - call psb_check_size((counter_o+3),tmp_ovr_idx,info,pad=-1) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='psb_check_size') - goto 9999 - end if + else - tmp_ovr_idx(counter_o)=proc - tmp_ovr_idx(counter_o+1)=1 - tmp_ovr_idx(counter_o+2)=gidx - tmp_ovr_idx(counter_o+3)=-1 - counter_o=counter_o+3 - end Do - counter=counter+n_elem_recv+n_elem_send+2 - end Do + Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + Allocate(works(lworks),workr(lworkr),t_halo_in(l_tmp_halo),& + & t_halo_out(l_tmp_halo), temp(lworkr),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if - ! - ! A picture is in order to understand what goes on here. - ! I is the internal part; H is halo, R row, C column. The final - ! matrix with N levels of overlap looks like this - ! - ! I | Hc1 | 0 | 0 | - ! -------|-----|-----|-----| - ! Hr1 | Hd1 | Hc2 | 0 | - ! -------|-----|-----|-----| - ! 0 | Hr2 | Hd2 | Hc2 | - ! -------|-----|-----|-----| - ! 0 | 0 | Hr3 | Hd3 | Hc3 - ! - ! At the start we already have I and Hc1, so we know the row - ! indices that will make up Hr1, and also who owns them. As we - ! actually get those rows, we receive the column indices in Hc2; - ! these define the row indices for Hr2, and so on. When we have - ! reached the desired level HrN, we may ignore HcN. - ! - ! - Do i_ovr = 1, novr + call psb_sp_all(blk,max(lworks,lworkr),info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if - if (debug) write(0,*) me,'Running on overlap level ',i_ovr,' of ',novr + blk%fida='COO' - ! - ! At this point, halo contains a valid halo corresponding to the - ! matrix enlarged with the elements in the frontier for I_OVR-1. - ! At the start, this is just the halo for A; the rows for indices in - ! the first halo will contain column indices defining the second halo - ! level and so on. - ! - bsdindx(:) = 0 - sdsz(:) = 0 - brvindx(:) = 0 - rvsz(:) = 0 - idxr = 0 - idxs = 0 - counter = 1 - counter_t = 1 - - - Do While (halo(counter) /= -1) - tot_elem=0 - proc=halo(counter+psb_proc_id_) - n_elem_recv=halo(counter+psb_n_elem_recv_) - n_elem_send=halo(counter+n_elem_recv+psb_n_elem_send_) - If ((counter+n_elem_recv+n_elem_send) > Size(halo)) then - info = -1 - call psb_errpush(info,name) - goto 9999 - end If - tot_recv=tot_recv+n_elem_recv - if (debug) write(0,*) me,' CDOVRBLD tot_recv:',proc,n_elem_recv,tot_recv - ! - ! - ! The format of the halo vector exists in two forms: 1. Temporary - ! 2. Assembled. In this loop we are using the (assembled) halo_in and - ! copying it into (temporary) halo_out; this is because tmp_halo will - ! be enlarged with the new column indices received, and will reassemble - ! everything for the next iteration. - ! + Allocate(tmp_ovr_idx(l_tmp_ovr_idx),tmp_halo(l_tmp_halo),& + & halo(size(desc_a%halo_index)),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + halo(:) = desc_a%halo_index(:) + desc_ov%ovrlap_elem(:) = -1 + tmp_ovr_idx(:) = -1 + tmp_halo(:) = -1 + counter_e = 1 + tot_recv = 0 + counter_h = 1 + counter_o = 1 + + ! Init overlap with desc_a%ovrlap (if any) + counter = 1 + Do While (desc_a%ovrlap_index(counter) /= -1) + proc = desc_a%ovrlap_index(counter+psb_proc_id_) + n_elem_recv = desc_a%ovrlap_index(counter+psb_n_elem_recv_) + n_elem_send = desc_a%ovrlap_index(counter+n_elem_recv+psb_n_elem_send_) - ! - ! add recv elements in halo_index into ovrlap_index - ! Do j=0,n_elem_recv-1 - If((counter+psb_elem_recv_+j)>Size(halo)) then - info=-2 - call psb_errpush(info,name) - goto 9999 - end If - idx = halo(counter+psb_elem_recv_+j) + idx = desc_a%ovrlap_index(counter+psb_elem_recv_+j) If(idx > Size(desc_ov%loc_to_glob)) then info=-3 call psb_errpush(info,name) @@ -334,342 +255,443 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) tmp_ovr_idx(counter_o+2)=gidx tmp_ovr_idx(counter_o+3)=-1 counter_o=counter_o+3 - if (.not.psb_is_large_desc(desc_ov)) then - call psb_check_size((counter_h+3),tmp_halo,info,pad=-1) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='psb_check_size') - goto 9999 - end if + end Do + counter=counter+n_elem_recv+n_elem_send+2 + end Do - tmp_halo(counter_h)=proc - tmp_halo(counter_h+1)=1 - tmp_halo(counter_h+2)=idx - tmp_halo(counter_h+3)=-1 - counter_h=counter_h+3 - end if - Enddo - if (debug) write(0,*) me,'Checktmp_o_i Loop Mid1',tmp_ovr_idx(1:10) - counter = counter+n_elem_recv - ! - ! add send elements in halo_index into ovrlap_index - ! - Do j=0,n_elem_send-1 + ! + ! A picture is in order to understand what goes on here. + ! I is the internal part; H is halo, R row, C column. The final + ! matrix with N levels of overlap looks like this + ! + ! I | Hc1 | 0 | 0 | + ! -------|-----|-----|-----| + ! Hr1 | Hd1 | Hc2 | 0 | + ! -------|-----|-----|-----| + ! 0 | Hr2 | Hd2 | Hc2 | + ! -------|-----|-----|-----| + ! 0 | 0 | Hr3 | Hd3 | Hc3 + ! + ! At the start we already have I and Hc1, so we know the row + ! indices that will make up Hr1, and also who owns them. As we + ! actually get those rows, we receive the column indices in Hc2; + ! these define the row indices for Hr2, and so on. When we have + ! reached the desired level HrN, we may ignore HcN. + ! + ! + Do i_ovr = 1, novr - idx = halo(counter+psb_elem_send_+j) - gidx = desc_ov%loc_to_glob(idx) - if (idx > psb_cd_get_local_rows(Desc_a)) & - & write(0,*) me,i_ovr,'Out of local rows ',& - & idx,psb_cd_get_local_rows(Desc_a) + if (debug) write(0,*) me,'Running on overlap level ',i_ovr,' of ',novr - call psb_check_size((counter_o+3),tmp_ovr_idx,info,pad=-1) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='psb_check_size') + ! + ! At this point, halo contains a valid halo corresponding to the + ! matrix enlarged with the elements in the frontier for I_OVR-1. + ! At the start, this is just the halo for A; the rows for indices in + ! the first halo will contain column indices defining the second halo + ! level and so on. + ! + bsdindx(:) = 0 + sdsz(:) = 0 + brvindx(:) = 0 + rvsz(:) = 0 + idxr = 0 + idxs = 0 + counter = 1 + counter_t = 1 + + + Do While (halo(counter) /= -1) + tot_elem=0 + proc=halo(counter+psb_proc_id_) + n_elem_recv=halo(counter+psb_n_elem_recv_) + n_elem_send=halo(counter+n_elem_recv+psb_n_elem_send_) + If ((counter+n_elem_recv+n_elem_send) > Size(halo)) then + info = -1 + call psb_errpush(info,name) goto 9999 - end if - - tmp_ovr_idx(counter_o)=proc - tmp_ovr_idx(counter_o+1)=1 - tmp_ovr_idx(counter_o+2)=gidx - tmp_ovr_idx(counter_o+3)=-1 - counter_o=counter_o+3 + end If + tot_recv=tot_recv+n_elem_recv + if (debug) write(0,*) me,' CDOVRBLD tot_recv:',proc,n_elem_recv,tot_recv + ! + ! + ! The format of the halo vector exists in two forms: 1. Temporary + ! 2. Assembled. In this loop we are using the (assembled) halo_in and + ! copying it into (temporary) halo_out; this is because tmp_halo will + ! be enlarged with the new column indices received, and will reassemble + ! everything for the next iteration. + ! ! - ! Prepare to exchange the halo rows with the other proc. + ! add recv elements in halo_index into ovrlap_index ! - If (i_ovr < (novr)) Then - n_elem = psb_sp_get_nnz_row(idx,a) + Do j=0,n_elem_recv-1 + If((counter+psb_elem_recv_+j)>Size(halo)) then + info=-2 + call psb_errpush(info,name) + goto 9999 + end If - call psb_check_size((idxs+tot_elem+n_elem),works,info) + idx = halo(counter+psb_elem_recv_+j) + If(idx > Size(desc_ov%loc_to_glob)) then + info=-3 + call psb_errpush(info,name) + goto 9999 + endif + + gidx = desc_ov%loc_to_glob(idx) + + call psb_check_size((counter_o+3),tmp_ovr_idx,info,pad=-1) if (info /= 0) then info=4010 call psb_errpush(info,name,a_err='psb_check_size') goto 9999 end if - If((n_elem) > size(blk%ia2)) Then - isz = max((3*size(blk%ia2))/2,(n_elem)) - if (debug) write(0,*) me,'Realloc blk',isz - call psb_sp_reall(blk,isz,info) + tmp_ovr_idx(counter_o)=proc + tmp_ovr_idx(counter_o+1)=1 + tmp_ovr_idx(counter_o+2)=gidx + tmp_ovr_idx(counter_o+3)=-1 + counter_o=counter_o+3 + if (.not.psb_is_large_desc(desc_ov)) then + call psb_check_size((counter_h+3),tmp_halo,info,pad=-1) if (info /= 0) then info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) + call psb_errpush(info,name,a_err='psb_check_size') goto 9999 end if - End If - call psb_sp_getblk(idx,a,blk,info) + tmp_halo(counter_h)=proc + tmp_halo(counter_h+1)=1 + tmp_halo(counter_h+2)=idx + tmp_halo(counter_h+3)=-1 + + counter_h=counter_h+3 + end if + + Enddo + if (debug) write(0,*) me,'Checktmp_o_i Loop Mid1',tmp_ovr_idx(1:10) + counter = counter+n_elem_recv + + ! + ! add send elements in halo_index into ovrlap_index + ! + Do j=0,n_elem_send-1 + + idx = halo(counter+psb_elem_send_+j) + gidx = desc_ov%loc_to_glob(idx) + if (idx > psb_cd_get_local_rows(Desc_a)) & + & write(0,*) me,i_ovr,'Out of local rows ',& + & idx,psb_cd_get_local_rows(Desc_a) + + call psb_check_size((counter_o+3),tmp_ovr_idx,info,pad=-1) if (info /= 0) then info=4010 - ch_err='psb_sp_getblk' - call psb_errpush(info,name,a_err=ch_err) + call psb_errpush(info,name,a_err='psb_check_size') goto 9999 end if -!!$ write(0,*) me,'Iteration: ',j,i_ovr - Do jj=1,n_elem - works(idxs+tot_elem+jj)=desc_ov%loc_to_glob(blk%ia2(jj)) - End Do - tot_elem=tot_elem+n_elem - End If - Enddo + tmp_ovr_idx(counter_o)=proc + tmp_ovr_idx(counter_o+1)=1 + tmp_ovr_idx(counter_o+2)=gidx + tmp_ovr_idx(counter_o+3)=-1 + counter_o=counter_o+3 + ! + ! Prepare to exchange the halo rows with the other proc. + ! + If (i_ovr < (novr)) Then + n_elem = psb_sp_get_nnz_row(idx,a) - if (i_ovr < novr) then - if (tot_elem > 1) then - call imsr(tot_elem,works(idxs+1)) - lx = works(idxs+1) - i = 1 - j = 1 - do - j = j + 1 - if (j > tot_elem) exit - if (works(idxs+j) /= lx) then - i = i + 1 - works(idxs+i) = works(idxs+j) - lx = works(idxs+i) + call psb_check_size((idxs+tot_elem+n_elem),works,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_check_size') + goto 9999 end if - end do - tot_elem = i - endif - if (debug) write(0,*) me,'Checktmp_o_i Loop Mid2',tmp_ovr_idx(1:10) - sdsz(proc+1) = tot_elem - idxs = idxs + tot_elem - end if - counter = counter+n_elem_send+3 - if (debug) write(0,*) me,'Checktmp_o_i Loop End',tmp_ovr_idx(1:10) - Enddo - if (debug) write(0,*)me,'End phase 1 CDOVRBLD', m, n_col, tot_recv - - if (i_ovr < novr) then - ! - ! Exchange data requests with everybody else: so far we have - ! accumulated RECV requests, we have an all-to-all to build - ! matchings SENDs. - ! - call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 - ch_err='mpi_alltoall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - idxs = 0 - idxr = 0 - counter = 1 - Do - proc=halo(counter) - if (proc == -1) exit - n_elem_recv = halo(counter+psb_n_elem_recv_) - counter = counter+n_elem_recv - n_elem_send = halo(counter+psb_n_elem_send_) - - bsdindx(proc+1) = idxs - idxs = idxs + sdsz(proc+1) - brvindx(proc+1) = idxr - idxr = idxr + rvsz(proc+1) + + If((n_elem) > size(blk%ia2)) Then + isz = max((3*size(blk%ia2))/2,(n_elem)) + if (debug) write(0,*) me,'Realloc blk',isz + call psb_sp_reall(blk,isz,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + End If + + call psb_sp_getblk(idx,a,blk,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_getblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if +!!$ write(0,*) me,'Iteration: ',j,i_ovr + Do jj=1,n_elem + works(idxs+tot_elem+jj)=desc_ov%loc_to_glob(blk%ia2(jj)) + End Do + tot_elem=tot_elem+n_elem + End If + + Enddo + + + if (i_ovr < novr) then + if (tot_elem > 1) then + call imsr(tot_elem,works(idxs+1)) + lx = works(idxs+1) + i = 1 + j = 1 + do + j = j + 1 + if (j > tot_elem) exit + if (works(idxs+j) /= lx) then + i = i + 1 + works(idxs+i) = works(idxs+j) + lx = works(idxs+i) + end if + end do + tot_elem = i + endif + if (debug) write(0,*) me,'Checktmp_o_i Loop Mid2',tmp_ovr_idx(1:10) + sdsz(proc+1) = tot_elem + idxs = idxs + tot_elem + end if counter = counter+n_elem_send+3 + if (debug) write(0,*) me,'Checktmp_o_i Loop End',tmp_ovr_idx(1:10) Enddo - - iszr=sum(rvsz) - if (max(iszr,1) > lworkr) then - call psb_realloc(max(iszr,1),workr,info) + if (debug) write(0,*)me,'End phase 1 CDOVRBLD', m, n_col, tot_recv + + if (i_ovr < novr) then + ! + ! Exchange data requests with everybody else: so far we have + ! accumulated RECV requests, we have an all-to-all to build + ! matchings SENDs. + ! + call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) if (info /= 0) then info=4010 - ch_err='psb_realloc' + ch_err='mpi_alltoall' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - lworkr=max(iszr,1) - end if - - call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& - & workr,rvsz,brvindx,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 - ch_err='mpi_alltoallv' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if (debug) write(0,*) 'ISZR :',iszr + idxs = 0 + idxr = 0 + counter = 1 + Do + proc=halo(counter) + if (proc == -1) exit + n_elem_recv = halo(counter+psb_n_elem_recv_) + counter = counter+n_elem_recv + n_elem_send = halo(counter+psb_n_elem_send_) + + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + counter = counter+n_elem_send+3 + Enddo + + iszr=sum(rvsz) + if (max(iszr,1) > lworkr) then + call psb_realloc(max(iszr,1),workr,info) + if (info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + lworkr=max(iszr,1) + end if - if (psb_is_large_desc(desc_a)) then - call psb_check_size(iszr,maskr,info) + call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& + & workr,rvsz,brvindx,mpi_integer,icomm,info) if (info /= 0) then info=4010 - call psb_errpush(info,name,a_err='psb_check_size') + ch_err='mpi_alltoallv' + call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - call psi_idx_cnv(iszr,workr,maskr,desc_ov,info) - iszs = count(maskr(1:iszr)<=0) - if (iszs > size(works)) call psb_realloc(iszs,works,info) - j = 0 - do i=1,iszr - if (maskr(i) < 0) then - j=j+1 - works(j) = workr(i) - end if - end do - ! - ! fnd_owner on desc_a because we want the procs who - ! owned the rows from the beginning! - ! - call psi_fnd_owner(iszs,works,temp,desc_a,info) - n_col=psb_cd_get_local_cols(desc_ov) - - do i=1,iszs - idx = works(i) - n_col = psb_cd_get_local_cols(desc_ov) - call psi_idx_ins_cnv(idx,lidx,desc_ov,info) - if (psb_cd_get_local_cols(desc_ov) > n_col ) then - ! - ! This is a new index. Assigning a local index as - ! we receive them guarantees that all indices for HALO(I) - ! will be less than those for HALO(J) whenever I size(works)) call psb_realloc(iszs,works,info) + j = 0 + do i=1,iszr + if (maskr(i) < 0) then + j=j+1 + works(j) = workr(i) end if + end do + ! + ! fnd_owner on desc_a because we want the procs who + ! owned the rows from the beginning! + ! + call psi_fnd_owner(iszs,works,temp,desc_a,info) + n_col=psb_cd_get_local_cols(desc_ov) + + do i=1,iszs + idx = works(i) + n_col = psb_cd_get_local_cols(desc_ov) + call psi_idx_ins_cnv(idx,lidx,desc_ov,info) + if (psb_cd_get_local_cols(desc_ov) > n_col ) then + ! + ! This is a new index. Assigning a local index as + ! we receive them guarantees that all indices for HALO(I) + ! will be less than those for HALO(J) whenever I). The sparse input matrix. - ! b - type(). The sparse output matrix. - ! desc_a - type(). The communication descriptor. - ! info - integer. Eventually returns an error code. - ! +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ 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_zspcnv.f90 +! +! Subroutine: psb_zspcnv +! converts sparse matrix a into b +! +! Parameters: +! a - type(). The sparse input matrix. +! b - type(). The sparse output matrix. +! desc_a - type(). The communication descriptor. +! info - integer. Eventually returns an error code. +! subroutine psb_zspcnv(a,b,desc_a,info) use psb_descriptor_type @@ -50,6 +50,49 @@ subroutine psb_zspcnv(a,b,desc_a,info) use psb_penv_mod implicit none + interface zcsdp + + subroutine zcsdp(check,trans,m,n,unitd,d,& + & fida,descra,a,ia1,ia2,infoa,& + & pl,fidh,descrh,h,ih1,ih2,infoh,pr,lh,lh1,lh2,& + & work,lwork,ierror) + integer, intent(in) :: lh, lwork, lh1, lh2, m, n + integer, intent(out) :: ierror + character, intent(in) :: check, trans, unitd + complex(kind(1.d0)), intent(in) :: d(*), a(*) + complex(kind(1.d0)), intent(out) :: h(*) + complex(kind(1.d0)), intent(inout) :: work(*) + integer, intent(in) :: ia1(*), ia2(*), infoa(*) + integer, intent(out) :: ih1(*), ih2(*), pl(*),pr(*), infoh(*) + character, intent(in) :: fida*5, descra*11 + character, intent(out) :: fidh*5, descrh*11 + end subroutine zcsdp + end interface + + + interface zcsrp + + subroutine zcsrp(trans,m,n,fida,descra,ia1,ia2,& + & infoa,p,work,lwork,ierror) + integer, intent(in) :: m, n, lwork + integer, intent(out) :: ierror + character, intent(in) :: trans + complex(kind(1.d0)), intent(inout) :: work(*) + integer, intent(in) :: p(*) + integer, intent(inout) :: ia1(*), ia2(*), infoa(*) + character, intent(in) :: fida*5, descra*11 + end subroutine zcsrp + end interface + + interface zcsprt + subroutine zcsprt(m,n,fida,descra,a,ia1,ia2,infoa ,iout,ierror) + integer, intent(in) :: iout,m, n + integer, intent(out) :: ierror + complex(kind(1.d0)), intent(in) :: a(*) + integer, intent(in) :: ia1(*), ia2(*), infoa(*) + character, intent(in) :: fida*5, descra*11 + end subroutine zcsprt + end interface !...parameters.... type(psb_zspmat_type), intent(in) :: a @@ -58,11 +101,17 @@ subroutine psb_zspcnv(a,b,desc_a,info) integer, intent(out) :: info !....locals.... integer :: int_err(5) + complex(kind(1.d0)) :: d(1) + integer,allocatable :: i_temp(:) + complex(kind(1.d0)),allocatable :: work_dcsdp(:) integer :: ia1_size,ia2_size,aspk_size,err_act& - & ,i,err,np,me,n_col - integer, allocatable :: i_temp(:) - integer :: dectype + & ,i,err,np,me,n_col,l_dcsdp + integer :: lwork_dcsdp,dectype integer :: ictxt,n_row + character :: check*1, trans*1, unitd*1 + + real(kind(1.d0)) :: time(10), mpi_wtime + external mpi_wtime logical, parameter :: debug=.false. character(len=20) :: name, ch_err @@ -71,6 +120,7 @@ subroutine psb_zspcnv(a,b,desc_a,info) name = 'psb_zspcnv' call psb_erractionsave(err_act) + time(1) = mpi_wtime() ictxt = psb_cd_get_context(desc_a) dectype = psb_cd_get_dectype(desc_a) @@ -100,15 +150,46 @@ subroutine psb_zspcnv(a,b,desc_a,info) if (debug) write (0, *) name,' sizes',ia1_size,ia2_size,aspk_size + ! convert only without check + check='N' + trans='N' + unitd='U' + + ! l_dcsdp is the size requested for dcsdp procedure + l_dcsdp=(ia1_size+100) + b%m=n_row b%k=n_col call psb_sp_all(b,ia1_size,ia2_size,aspk_size,info) + allocate(work_dcsdp(l_dcsdp),stat=info) + if (info /= 0) then + info=2025 + int_err(1)=l_dcsdp + call psb_errpush(info, name, i_err=int_err) + goto 9999 + endif - call psb_csdp(a,b,info) + lwork_dcsdp=size(work_dcsdp) + ! set infoa(1) to nnzero + b%pl(:) = 0 + b%pr(:) = 0 + + if (debug) write (0, *) name,' calling dcsdp',lwork_dcsdp,& + &size(work_dcsdp) + ! convert aspk,ia1,ia2 in requested representation mode + if (debug) then + + endif + ! result is put in b + call zcsdp(check,trans,n_row,n_col,unitd,d,a%fida,a%descra,& + & a%aspk,a%ia1,a%ia2,a%infoa,& + & b%pl,b%fida,b%descra,b%aspk,b%ia1,b%ia2,b%infoa,b%pr,& + & size(b%aspk),size(b%ia1),size(b%ia2),& + & work_dcsdp,size(work_dcsdp),info) if(info /= no_err) then info=4010 - ch_err='psb_csdp' + ch_err='zcsdp' call psb_errpush(info, name, a_err=ch_err) goto 9999 end if @@ -148,6 +229,9 @@ subroutine psb_zspcnv(a,b,desc_a,info) endif + if (debug) write (0, *) me,name,' from zcsdp ',& + &b%fida,' pl ', b%pl(:),'pr',b%pr(:) + call psb_erractionrestore(err_act) return diff --git a/base/tools/psb_zsphalo.f90 b/base/tools/psb_zsphalo.f90 index 7e72c78e..7ad58b42 100644 --- a/base/tools/psb_zsphalo.f90 +++ b/base/tools/psb_zsphalo.f90 @@ -49,7 +49,6 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) use psb_serial_mod use psb_descriptor_type - Use psb_prec_type use psb_realloc_mod use psb_tools_mod, only : psb_glob_to_loc, psb_loc_to_glob use psb_error_mod diff --git a/base/tools/psb_zspins.f90 b/base/tools/psb_zspins.f90 index 6240570e..712bb241 100644 --- a/base/tools/psb_zspins.f90 +++ b/base/tools/psb_zspins.f90 @@ -71,6 +71,27 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild) logical :: rebuild_ integer, allocatable :: ila(:),jla(:) +!!$ interface psb_cdins +!!$ subroutine psb_cdins(nz,ia,ja,desc_a,info,ila,jla) +!!$ use psb_descriptor_type +!!$ implicit none +!!$ type(psb_desc_type), intent(inout) :: desc_a +!!$ integer, intent(in) :: nz,ia(:),ja(:) +!!$ integer, intent(out) :: info +!!$ integer, optional, intent(out) :: ila(:), jla(:) +!!$ end subroutine psb_cdins +!!$ end interface +!!$ +!!$ interface psb_glob_to_loc +!!$ subroutine psb_glob_to_loc(x,desc_a,info,iact) +!!$ use psb_descriptor_type +!!$ implicit none +!!$ type(psb_desc_type), intent(in) :: desc_a +!!$ integer, intent(inout) :: x(:) +!!$ integer, intent(out) :: info +!!$ character, intent(in), optional :: iact +!!$ end subroutine psb_glob_to_loc +!!$ end interface character(len=20) :: name, ch_err info = 0 diff --git a/krylov/Makefile b/krylov/Makefile index 0fa70ec6..99c2e36f 100644 --- a/krylov/Makefile +++ b/krylov/Makefile @@ -1,24 +1,28 @@ -include ../../Make.inc +include ../Make.inc -LIBDIR=../../lib - HERE=. -OBJS= psb_dcgstab.o psb_dcg.o psb_dcgs.o \ +LIBDIR=../lib + +OBJS=psb_krylov_mod.o psb_dcgstab.o psb_dcg.o psb_dcgs.o \ psb_dbicg.o psb_dcgstabl.o psb_dgmresr.o\ psb_zcgstab.o psb_zcgs.o -INCDIRS=-I. -I.. -I$(LIBDIR) -lib: $(OBJS) - $(AR) $(LIBDIR)/$(LIBNAME) $(OBJS) - $(RANLIB) $(LIBDIR)/$(LIBNAME) +LIBMOD=psb_krylov_mod$(.mod) +LOCAL_MODS=$(LIBMOD) +LIBNAME=$(METHDLIBNAME) -#$(F90OBJS): $(MODS) +INCDIRS=-I. -I$(LIBDIR) +lib: $(OBJS) + $(AR) $(HERE)/$(LIBNAME) $(OBJS) + $(RANLIB) $(HERE)/$(LIBNAME) + /bin/cp $(HERE)/$(LIBNAME) $(LIBDIR) + /bin/cp $(LIBMOD) $(LIBDIR) veryclean: clean - /bin/rm -f $(LIBNAME) + /bin/rm -f $(HERE)/$(LIBNAME) clean: /bin/rm -f $(OBJS) $(LOCAL_MODS) diff --git a/krylov/psb_dbicg.f90 b/krylov/psb_dbicg.f90 index a56580fe..083ef11b 100644 --- a/krylov/psb_dbicg.f90 +++ b/krylov/psb_dbicg.f90 @@ -75,15 +75,8 @@ ! subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err, itrace,istop) - use psb_serial_mod - use psb_descriptor_type - use psb_prec_type - use psb_psblas_mod - use psb_tools_mod - use psb_const_mod + use psb_base_mod use psb_prec_mod - use psb_error_mod - use psb_penv_mod implicit none !!$ parameters diff --git a/krylov/psb_dcg.f90 b/krylov/psb_dcg.f90 index b00b8f90..6e0f86b2 100644 --- a/krylov/psb_dcg.f90 +++ b/krylov/psb_dcg.f90 @@ -75,15 +75,8 @@ ! Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err, itrace, istop) - use psb_serial_mod - use psb_descriptor_type - use psb_prec_type - use psb_psblas_mod - use psb_tools_mod - use psb_const_mod + use psb_base_mod use psb_prec_mod - use psb_error_mod - use psb_penv_mod implicit none !!$ Parameters diff --git a/krylov/psb_dcgs.f90 b/krylov/psb_dcgs.f90 index 7d2996bd..9416e54f 100644 --- a/krylov/psb_dcgs.f90 +++ b/krylov/psb_dcgs.f90 @@ -73,15 +73,8 @@ ! Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace,istop) - use psb_serial_mod - use psb_descriptor_type - use psb_prec_type - use psb_psblas_mod - use psb_tools_mod - use psb_const_mod + use psb_base_mod use psb_prec_mod - use psb_error_mod - use psb_penv_mod implicit none !!$ parameters diff --git a/krylov/psb_dcgstab.f90 b/krylov/psb_dcgstab.f90 index 14ec828d..ab08eb3b 100644 --- a/krylov/psb_dcgstab.f90 +++ b/krylov/psb_dcgstab.f90 @@ -74,15 +74,8 @@ ! Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace, istop) - use psb_serial_mod - use psb_descriptor_type - use psb_prec_type - use psb_psblas_mod - use psb_tools_mod - use psb_const_mod + use psb_base_mod use psb_prec_mod - use psb_error_mod - use psb_penv_mod Implicit None !!$ parameters Type(psb_dspmat_type), Intent(in) :: a diff --git a/krylov/psb_dcgstabl.f90 b/krylov/psb_dcgstabl.f90 index a41f739d..4045cb7f 100644 --- a/krylov/psb_dcgstabl.f90 +++ b/krylov/psb_dcgstabl.f90 @@ -80,15 +80,8 @@ ! Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace,irst,istop) - use psb_serial_mod - use psb_descriptor_type - use psb_prec_type - use psb_psblas_mod - use psb_tools_mod - use psb_const_mod + use psb_base_mod use psb_prec_mod - use psb_error_mod - use psb_penv_mod implicit none !!$ parameters diff --git a/krylov/psb_dgmresr.f90 b/krylov/psb_dgmresr.f90 index cd9a79f8..e0b59273 100644 --- a/krylov/psb_dgmresr.f90 +++ b/krylov/psb_dgmresr.f90 @@ -82,15 +82,8 @@ ! Subroutine psb_dgmresr(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace,irst,istop) - use psb_serial_mod - use psb_descriptor_type - use psb_prec_type - use psb_psblas_mod - use psb_tools_mod - use psb_const_mod + use psb_base_mod use psb_prec_mod - use psb_error_mod - use psb_penv_mod implicit none !!$ Parameters diff --git a/base/modules/psb_methd_mod.f90 b/krylov/psb_krylov_mod.f90 similarity index 88% rename from base/modules/psb_methd_mod.f90 rename to krylov/psb_krylov_mod.f90 index 260ae701..2bea14b8 100644 --- a/base/modules/psb_methd_mod.f90 +++ b/krylov/psb_krylov_mod.f90 @@ -28,20 +28,21 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -Module psb_methd_mod +Module psb_krylov_mod + + use psb_base_mod + use psb_prec_mod + interface psb_krylov module procedure psb_dkrylov, psb_zkrylov end interface - - interface psb_cg subroutine psb_dcg(a,prec,b,x,eps,& & desc_a,info,itmax,iter,err,itrace,istop) - use psb_serial_mod - use psb_descriptor_type - use psb_prec_type + use psb_base_mod + use psb_prec_mod type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a real(kind(1.d0)), intent(in) :: b(:) @@ -58,9 +59,8 @@ Module psb_methd_mod interface psb_bicg subroutine psb_dbicg(a,prec,b,x,eps,& & desc_a,info,itmax,iter,err,itrace,istop) - use psb_serial_mod - use psb_descriptor_type - use psb_prec_type + use psb_base_mod + use psb_prec_mod type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a real(kind(1.d0)), intent(in) :: b(:) @@ -77,9 +77,8 @@ Module psb_methd_mod interface psb_bicgstab subroutine psb_dcgstab(a,prec,b,x,eps,& & desc_a,info,itmax,iter,err,itrace,istop) - use psb_serial_mod - use psb_descriptor_type - use psb_prec_type + use psb_base_mod + use psb_prec_mod type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a real(kind(1.d0)), intent(in) :: b(:) @@ -93,9 +92,8 @@ Module psb_methd_mod end subroutine psb_dcgstab subroutine psb_zcgstab(a,prec,b,x,eps,& & desc_a,info,itmax,iter,err,itrace,istop) - use psb_serial_mod - use psb_descriptor_type - use psb_prec_type + use psb_base_mod + use psb_prec_mod type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a complex(kind(1.d0)), intent(in) :: b(:) @@ -112,9 +110,8 @@ Module psb_methd_mod interface psb_bicgstabl Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err, itrace,irst,istop) - use psb_serial_mod - use psb_descriptor_type - Use psb_prec_type + use psb_base_mod + use psb_prec_mod Type(psb_dspmat_type), Intent(in) :: a Type(psb_desc_type), Intent(in) :: desc_a type(psb_dprec_type), intent(in) :: prec @@ -131,9 +128,8 @@ Module psb_methd_mod interface psb_rgmres Subroutine psb_dgmresr(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace,irst,istop) - use psb_serial_mod - use psb_descriptor_type - Use psb_prec_type + use psb_base_mod + use psb_prec_mod !!$ parameters Type(psb_dspmat_type), Intent(in) :: a Type(psb_desc_type), Intent(in) :: desc_a @@ -151,9 +147,8 @@ Module psb_methd_mod interface psb_cgs subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace,istop) - use psb_serial_mod - use psb_descriptor_type - use psb_prec_type + use psb_base_mod + use psb_prec_mod !!$ parameters type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a @@ -168,9 +163,8 @@ Module psb_methd_mod end subroutine psb_dcgs subroutine psb_zcgs(a,prec,b,x,eps,& & desc_a,info,itmax,iter,err,itrace,istop) - use psb_serial_mod - use psb_descriptor_type - use psb_prec_type + use psb_base_mod + use psb_prec_mod type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a complex(kind(1.d0)), intent(in) :: b(:) @@ -189,12 +183,6 @@ contains Subroutine psb_dkrylov(method,a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace,irst,istop) - use psb_serial_mod - use psb_descriptor_type - Use psb_prec_type - use psb_string_mod - use psb_penv_mod -!!$ parameters character(len=*) :: method Type(psb_dspmat_type), Intent(in) :: a Type(psb_desc_type), Intent(in) :: desc_a @@ -207,9 +195,8 @@ contains Integer, Optional, Intent(out) :: iter Real(Kind(1.d0)), Optional, Intent(out) :: err - integer :: ictxt, me, np - integer :: itmax_, itrace_, irst_, istop_, iter_ - real(kind(1.d0)) :: err_ + integer :: itmax_, itrace_, irst_, istop_, iter_ + real(kind(1.d0)) :: err_ if (present(itmax)) then itmax_ = itmax @@ -235,8 +222,6 @@ contains istop_ = 1 end if - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt,me,np) select case(toupper(method)) case('CG') @@ -258,8 +243,6 @@ contains call psb_bicgstabl(a,prec,b,x,eps,desc_a,info,& &itmax_,iter_,err_,itrace_,irst_,istop_) case default - if (me==0) write(0,*) & - & 'psb_krylov: unknown method, defaulting to BiCGSTAB' call psb_bicgstab(a,prec,b,x,eps,desc_a,info,& &itmax_,iter_,err_,itrace_,istop_) end select @@ -277,12 +260,6 @@ contains Subroutine psb_zkrylov(method,a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace,irst,istop) - use psb_serial_mod - use psb_descriptor_type - Use psb_prec_type - use psb_string_mod - use psb_penv_mod -!!$ parameters character(len=*) :: method Type(psb_zspmat_type), Intent(in) :: a Type(psb_desc_type), Intent(in) :: desc_a @@ -295,8 +272,6 @@ contains Integer, Optional, Intent(out) :: iter Real(Kind(1.d0)), Optional, Intent(out) :: err - - integer :: ictxt, me, np integer :: itmax_, itrace_, irst_, istop_, iter_ real(kind(1.d0)) :: err_ @@ -325,9 +300,6 @@ contains end if - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt,me,np) - select case(toupper(method)) !!$ case('CG') !!$ call psb_cg(a,prec,b,x,eps,desc_a,info,& @@ -348,8 +320,6 @@ contains !!$ call psb_bicgstabl(a,prec,b,x,eps,desc_a,info,& !!$ &itmax_,iter_,err_,itrace_,irst_,istop_) case default - if (me==0) write(0,*) & - & 'psb_krylov: unknown method, defaulting to BiCGSTAB' call psb_bicgstab(a,prec,b,x,eps,desc_a,info,& &itmax_,iter_,err_,itrace_,istop_) end select @@ -366,7 +336,7 @@ contains -end module psb_methd_mod +end module psb_krylov_mod diff --git a/krylov/psb_zcgs.f90 b/krylov/psb_zcgs.f90 index 68ead03b..8d35c80a 100644 --- a/krylov/psb_zcgs.f90 +++ b/krylov/psb_zcgs.f90 @@ -73,15 +73,8 @@ ! Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace,istop) - use psb_serial_mod - use psb_descriptor_type - use psb_prec_type - use psb_psblas_mod - use psb_tools_mod - use psb_const_mod + use psb_base_mod use psb_prec_mod - use psb_error_mod - use psb_penv_mod implicit none !!$ parameters diff --git a/krylov/psb_zcgstab.f90 b/krylov/psb_zcgstab.f90 index c024710f..dc1c4b95 100644 --- a/krylov/psb_zcgstab.f90 +++ b/krylov/psb_zcgstab.f90 @@ -60,7 +60,8 @@ ! ! Parameters: ! a - type(). The sparse matrix containing A. -! prec - type(). The data structure containing the preconditioner. +! prec - type(). The data structure containing the +! preconditioner. ! b - real,dimension(:). The right hand side. ! x - real,dimension(:). The vector of unknowns. ! eps - real. The error tolerance. @@ -74,15 +75,8 @@ ! Subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace, istop) - use psb_serial_mod - use psb_descriptor_type - use psb_prec_type - use psb_psblas_mod - use psb_tools_mod - use psb_const_mod + use psb_base_mod use psb_prec_mod - use psb_error_mod - use psb_penv_mod Implicit None !!$ parameters Type(psb_zspmat_type), Intent(in) :: a diff --git a/mld2p4/LICENSE.MD2P4 b/mld2p4/LICENSE.MD2P4 new file mode 100644 index 00000000..6df0b8a9 --- /dev/null +++ b/mld2p4/LICENSE.MD2P4 @@ -0,0 +1,33 @@ + MD2P4 + Multilevel Domain Decomposition Parallel Preconditioner Package for PSBLAS + for + Parallel Sparse BLAS v2.0 + (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata + Alfredo Buttari University of Rome Tor Vergata + Daniela di Serafino Second University of Naples + Pasqua D'Ambra ICAR-CNR + + 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 MD2P4 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 MD2P4 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. + diff --git a/mld2p4/Makefile b/mld2p4/Makefile index 22563614..4a30f009 100644 --- a/mld2p4/Makefile +++ b/mld2p4/Makefile @@ -1,31 +1,40 @@ -include ../../Make.inc +include ../Make.inc -LIBDIR=../../lib/ +LIBDIR=../lib +HERE=. +INCDIRS=-I. -I$(LIBDIR) -MPFOBJS=psb_dilu_bld.o psb_dbldaggrmat.o psb_zilu_bld.o psb_zbldaggrmat.o +MODOBJS= psb_prec_type.o psb_prec_mod.o +MPFOBJS=psb_dbldaggrmat.o psb_zbldaggrmat.o F90OBJS=psb_dasmatbld.o psb_dslu_bld.o psb_dumf_bld.o psb_dilu_fct.o\ - psb_dmlprc_bld.o psb_dsp_renum.o\ - psb_dprecbld.o psb_dprecfree.o psb_dprecset.o \ + psb_dmlprc_bld.o psb_dsp_renum.o psb_dilu_bld.o \ + psb_dprecbld.o psb_dprecfree.o psb_dprecset.o \ psb_dbaseprc_bld.o psb_ddiagsc_bld.o psb_dgenaggrmap.o \ psb_dprc_aply.o psb_dmlprc_aply.o \ psb_dbaseprc_aply.o psb_dbjac_aply.o\ psb_zasmatbld.o psb_zslu_bld.o psb_zumf_bld.o psb_zilu_fct.o\ - psb_zmlprc_bld.o psb_zsp_renum.o\ - psb_zprecbld.o psb_zprecfree.o psb_zprecset.o \ + psb_zmlprc_bld.o psb_zsp_renum.o psb_zilu_bld.o \ + psb_zprecbld.o psb_zprecfree.o psb_zprecset.o \ psb_zbaseprc_bld.o psb_zdiagsc_bld.o psb_zgenaggrmap.o \ psb_zprc_aply.o psb_zmlprc_aply.o \ psb_zbaseprc_aply.o psb_zbjac_aply.o\ $(MPFOBJS) - COBJS=psb_slu_impl.o psb_umf_impl.o psb_zslu_impl.o psb_zumf_impl.o -INCDIRS=-I. -I.. -I$(LIBDIR) +OBJS=$(F90OBJS) $(COBJS) $(MPFOBJS) $(MODOBJS) + +LIBMOD=psb_prec_mod$(.mod) +LOCAL_MODS=$(LIBMOD) psb_prec_type$(.mod) +LIBNAME=$(PRECLIBNAME) -OBJS=$(F90OBJS) $(COBJS) $(MPFOBJS) +lib: mpobjs $(OBJS) + $(AR) $(HERE)/$(LIBNAME) $(OBJS) + $(RANLIB) $(HERE)/$(LIBNAME) + /bin/cp $(HERE)/$(LIBNAME) $(LIBDIR) + /bin/cp $(LIBMOD) $(LIBDIR) -lib: mpobjs $(OBJS) - $(AR) $(LIBDIR)/$(LIBNAME) $(MPFOBJS) $(OBJS) - $(RANLIB) $(LIBDIR)/$(LIBNAME) +$(F90OBJS) $(MPFOBJS): $(MODOBJS) +psb_prec_mod.o: psb_prec_type.o mpobjs: (make $(MPFOBJS) F90="$(MPF90)" F90COPT="$(F90COPT)") @@ -35,5 +44,3 @@ veryclean: clean clean: /bin/rm -f $(OBJS) $(LOCAL_MODS) - -veryclean: clean diff --git a/mld2p4/psb_dasmatbld.f90 b/mld2p4/psb_dasmatbld.f90 index a30b998e..a15740f2 100644 --- a/mld2p4/psb_dasmatbld.f90 +++ b/mld2p4/psb_dasmatbld.f90 @@ -53,13 +53,8 @@ !***************************************************************************** Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) - use psb_serial_mod - use psb_descriptor_type - Use psb_prec_type - use psb_tools_mod - use psb_const_mod - use psb_error_mod - use psb_penv_mod + use psb_base_mod + use psb_prec_type Implicit None ! .. Array Arguments .. diff --git a/mld2p4/psb_dbaseprc_aply.f90 b/mld2p4/psb_dbaseprc_aply.f90 index a709166c..9bf9012b 100644 --- a/mld2p4/psb_dbaseprc_aply.f90 +++ b/mld2p4/psb_dbaseprc_aply.f90 @@ -40,14 +40,8 @@ subroutine psb_dbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) ! where K is a a basic preconditioner stored in prec ! - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_psblas_mod - use psb_const_mod - use psb_error_mod - use psb_penv_mod - use psb_prec_mod, only : psb_bjac_aply implicit none type(psb_desc_type),intent(in) :: desc_data @@ -68,6 +62,19 @@ subroutine psb_dbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) external mpi_wtime character(len=20) :: name, ch_err + interface psb_bjac_aply + subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use psb_prec_type + type(psb_desc_type), intent(in) :: desc_data + type(psb_dbaseprc_type), intent(in) :: prec + real(kind(0.d0)),intent(inout) :: x(:), y(:) + real(kind(0.d0)),intent(in) :: alpha,beta + character(len=1) :: trans + real(kind(0.d0)),target :: work(:) + integer, intent(out) :: info + end subroutine psb_dbjac_aply + end interface name='psb_dbaseprc_aply' info = 0 diff --git a/mld2p4/psb_dbaseprc_bld.f90 b/mld2p4/psb_dbaseprc_bld.f90 index 3d317f52..6b5c326a 100644 --- a/mld2p4/psb_dbaseprc_bld.f90 +++ b/mld2p4/psb_dbaseprc_bld.f90 @@ -36,19 +36,8 @@ !!$ subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd) - use psb_serial_mod - Use psb_spmat_type - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_tools_mod - use psb_comm_mod - use psb_const_mod - use psb_psblas_mod - use psb_error_mod - use psb_penv_mod - use psb_prec_mod, only: psb_diagsc_bld, psb_ilu_bld, & - & psb_slu_bld,psb_umf_bld - Implicit None type(psb_dspmat_type), target :: a @@ -57,6 +46,55 @@ subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd) integer, intent(out) :: info character, intent(in), optional :: upd + interface psb_diagsc_bld + subroutine psb_ddiagsc_bld(a,desc_data,p,upd,info) + use psb_base_mod + use psb_prec_type + integer, intent(out) :: info + type(psb_dspmat_type), intent(in), target :: a + type(psb_desc_type),intent(in) :: desc_data + type(psb_dbaseprc_type), intent(inout) :: p + character, intent(in) :: upd + end subroutine psb_ddiagsc_bld + end interface + + interface psb_ilu_bld + subroutine psb_dilu_bld(a,desc_data,p,upd,info) + use psb_base_mod + use psb_prec_type + integer, intent(out) :: info + type(psb_dspmat_type), intent(in), target :: a + type(psb_desc_type),intent(in) :: desc_data + type(psb_dbaseprc_type), intent(inout) :: p + character, intent(in) :: upd + end subroutine psb_dilu_bld + end interface + + interface psb_slu_bld + subroutine psb_dslu_bld(a,desc_a,p,info) + use psb_base_mod + use psb_prec_type + implicit none + + type(psb_dspmat_type), intent(inout) :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_dbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + end subroutine psb_dslu_bld + end interface + + interface psb_umf_bld + subroutine psb_dumf_bld(a,desc_a,p,info) + use psb_base_mod + use psb_prec_type + implicit none + + type(psb_dspmat_type), intent(inout) :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_dbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + end subroutine psb_dumf_bld + end interface ! Local scalars Integer :: err, nnzero, n_row, n_col,I,j,k,ictxt,& diff --git a/mld2p4/psb_dbjac_aply.f90 b/mld2p4/psb_dbjac_aply.f90 index 5c3a20cd..f77dcafd 100644 --- a/mld2p4/psb_dbjac_aply.f90 +++ b/mld2p4/psb_dbjac_aply.f90 @@ -42,13 +42,8 @@ subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) ! but since both are INTENT(IN) this should be legal. ! - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_psblas_mod - use psb_const_mod - use psb_error_mod - use psb_penv_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -190,12 +185,6 @@ subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) tx = dzero ty = dzero -!!$ open(50+me) -!!$ call psb_csprt(50+me,prec%av(ap_nd_)) -!!$ call flush(50+me) -!!$ close(50+me) -!!$ call psb_barrier(ictxt) - select case(prec%iprcparm(f_type_)) case(f_ilu_n_,f_ilu_e_) do i=1, prec%iprcparm(jac_sweeps_) diff --git a/mld2p4/psb_dbldaggrmat.f90 b/mld2p4/psb_dbldaggrmat.f90 index c97798a5..9944c01d 100644 --- a/mld2p4/psb_dbldaggrmat.f90 +++ b/mld2p4/psb_dbldaggrmat.f90 @@ -35,18 +35,12 @@ !!$ !!$ subroutine psb_dbldaggrmat(a,desc_a,ac,desc_ac,p,info) - use psb_serial_mod - use psb_penv_mod + use psb_base_mod use psb_prec_type - use psb_descriptor_type - use psb_spmat_type - use psb_tools_mod - use psb_psblas_mod - use psb_error_mod implicit none type(psb_dspmat_type), intent(in), target :: a - type(psb_dspmat_type), intent(inout), target :: ac + type(psb_dspmat_type), intent(out), target :: ac type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(inout) :: desc_ac type(psb_dbaseprc_type), intent(inout), target :: p @@ -104,11 +98,8 @@ subroutine psb_dbldaggrmat(a,desc_a,ac,desc_ac,p,info) contains subroutine raw_aggregate(info) + use psb_base_mod use psb_prec_type - use psb_const_mod - use psb_psblas_mod - use psb_error_mod - use psb_penv_mod implicit none include 'mpif.h' @@ -147,8 +138,8 @@ contains do i=1, nrow p%mlia(i) = p%mlia(i) + naggrm1 end do - call psb_halo(p%mlia,desc_a,info) end if + call psb_halo(p%mlia,desc_a,info) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_halo') @@ -178,16 +169,10 @@ contains nzt = psb_sp_get_nnzeros(b) - j = 0 do i=1, nzt - if ((1<=b%ia2(i)).and.(b%ia2(i)<=nrow)) then - j = j + 1 - b%aspk(j) = b%aspk(i) - b%ia1(j) = p%mlia(b%ia1(i)) - b%ia2(j) = p%mlia(b%ia2(i)) - end if + b%ia1(i) = p%mlia(b%ia1(i)) + b%ia2(i) = p%mlia(b%ia2(i)) enddo - b%infoa(psb_nnz_)=j call psb_fixcoo(b,info) nzt = psb_sp_get_nnzeros(b) @@ -339,14 +324,10 @@ contains subroutine smooth_aggregate(info) - use psb_serial_mod - use psb_const_mod - use psb_comm_mod - use psb_tools_mod - use psb_error_mod - use psb_penv_mod + use psb_base_mod + use psb_prec_type + use mpi implicit none - include 'mpif.h' integer, intent(out) :: info diff --git a/mld2p4/psb_ddiagsc_bld.f90 b/mld2p4/psb_ddiagsc_bld.f90 index 5b54b81c..7c3c6eb0 100644 --- a/mld2p4/psb_ddiagsc_bld.f90 +++ b/mld2p4/psb_ddiagsc_bld.f90 @@ -35,17 +35,8 @@ !!$ !!$ subroutine psb_ddiagsc_bld(a,desc_a,p,upd,info) - - use psb_serial_mod - Use psb_spmat_type - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_tools_mod - use psb_comm_mod - use psb_const_mod - use psb_psblas_mod - use psb_error_mod - use psb_penv_mod Implicit None type(psb_dspmat_type), target :: a diff --git a/mld2p4/psb_dgenaggrmap.f90 b/mld2p4/psb_dgenaggrmap.f90 index 38b4c091..245bb453 100644 --- a/mld2p4/psb_dgenaggrmap.f90 +++ b/mld2p4/psb_dgenaggrmap.f90 @@ -35,11 +35,8 @@ !!$ !!$ subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info) - use psb_spmat_type - use psb_serial_mod - use psb_descriptor_type - use psb_error_mod - use psb_penv_mod + use psb_base_mod + use psb_prec_type implicit none integer, intent(in) :: aggr_type type(psb_dspmat_type), intent(in) :: a diff --git a/mld2p4/psb_dilu_bld.f90 b/mld2p4/psb_dilu_bld.f90 index 5acce0ec..6744155f 100644 --- a/mld2p4/psb_dilu_bld.f90 +++ b/mld2p4/psb_dilu_bld.f90 @@ -50,17 +50,8 @@ !* * !***************************************************************************** subroutine psb_dilu_bld(a,desc_a,p,upd,info) - use psb_serial_mod - use psb_const_mod + use psb_base_mod use psb_prec_type - use psb_descriptor_type - use psb_spmat_type - use psb_tools_mod - use psb_psblas_mod - use psb_error_mod - use psb_realloc_mod - use psb_penv_mod - use psb_prec_mod, only : psb_as_matbld, psb_ilu_fct, psb_sp_renum implicit none ! ! .. Scalar Arguments .. @@ -84,6 +75,45 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info) integer :: ictxt,np,me character(len=20) :: name, ch_err + interface psb_ilu_fct + subroutine psb_dilu_fct(a,l,u,d,info,blck) + use psb_base_mod + integer, intent(out) :: info + type(psb_dspmat_type),intent(in) :: a + type(psb_dspmat_type),intent(inout) :: l,u + type(psb_dspmat_type),intent(in), optional, target :: blck + real(kind(1.d0)), intent(inout) :: d(:) + end subroutine psb_dilu_fct + end interface + + interface psb_asmatbld + Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) + use psb_base_mod + use psb_prec_type + integer, intent(in) :: ptype,novr + Type(psb_dspmat_type), Intent(in) :: a + Type(psb_dspmat_type), Intent(inout) :: blk + Type(psb_desc_type), Intent(inout) :: desc_p + Type(psb_desc_type), Intent(in) :: desc_data + Character, Intent(in) :: upd + integer, intent(out) :: info + character(len=5), optional :: outfmt + end Subroutine psb_dasmatbld + end interface + + interface psb_sp_renum + subroutine psb_dsp_renum(a,desc_a,blck,p,atmp,info) + use psb_base_mod + use psb_prec_type + implicit none + type(psb_dspmat_type), intent(in) :: a,blck + type(psb_dspmat_type), intent(inout) :: atmp + type(psb_dbaseprc_type), intent(inout) :: p + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psb_dsp_renum + end interface + if(psb_get_errstatus().ne.0) return info=0 name='psb_ilu_bld' @@ -115,18 +145,18 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info) t1= mpi_wtime() - if(debug) write(0,*)me,': calling psb_as_matbld',p%iprcparm(p_type_),p%iprcparm(n_ovr_) + if(debug) write(0,*)me,': calling psb_asmatbld',p%iprcparm(p_type_),p%iprcparm(n_ovr_) if (debug) call psb_barrier(ictxt) - call psb_as_matbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& + call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& & blck,desc_a,upd,p%desc_data,info) if(info/=0) then info=4010 - ch_err='psb_as_matbld' + ch_err='psb_asmatbld' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if t2= mpi_wtime() - if (debug) write(0,*)me,': out of psb_as_matbld' + if (debug) write(0,*)me,': out of psb_asmatbld' if (debug) call psb_barrier(ictxt) if (allocated(p%av)) then @@ -178,7 +208,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info) if (debug) then - write(0,*) me,'Done psb_as_matbld' + write(0,*) me,'Done psb_asmatbld' call psb_barrier(ictxt) endif diff --git a/mld2p4/psb_dilu_fct.f90 b/mld2p4/psb_dilu_fct.f90 index ce9f0449..4b965702 100644 --- a/mld2p4/psb_dilu_fct.f90 +++ b/mld2p4/psb_dilu_fct.f90 @@ -41,11 +41,7 @@ subroutine psb_dilu_fct(a,l,u,d,info,blck) ! into L/D/U. ! ! - use psb_spmat_type - use psb_serial_mod - use psb_tools_mod - use psb_error_mod - use psb_const_mod + use psb_base_mod implicit none ! .. Scalar Arguments .. integer, intent(out) :: info diff --git a/mld2p4/psb_dmlprc_aply.f90 b/mld2p4/psb_dmlprc_aply.f90 index cb6fd55f..b228130d 100644 --- a/mld2p4/psb_dmlprc_aply.f90 +++ b/mld2p4/psb_dmlprc_aply.f90 @@ -83,15 +83,8 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) ! 6. baseprecv(ilev)%nlaggr Number of aggregates on the various procs. ! - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_psblas_mod - use psb_penv_mod - use psb_const_mod - use psb_error_mod - use psb_penv_mod - use psb_prec_mod, only : psb_baseprc_aply implicit none type(psb_desc_type),intent(in) :: desc_data @@ -120,6 +113,20 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) end type psb_mlprec_wrk_type type(psb_mlprec_wrk_type), allocatable :: mlprec_wrk(:) + interface psb_baseprc_aply + subroutine psb_dbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use psb_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(psb_dbaseprc_type), intent(in) :: prec + real(kind(0.d0)),intent(inout) :: x(:), y(:) + real(kind(0.d0)),intent(in) :: alpha,beta + character(len=1) :: trans + real(kind(0.d0)),target :: work(:) + integer, intent(out) :: info + end subroutine psb_dbaseprc_aply + end interface + name='psb_mlprc_aply' info = 0 call psb_erractionsave(err_act) diff --git a/mld2p4/psb_dmlprc_bld.f90 b/mld2p4/psb_dmlprc_bld.f90 index 0db7582b..56ca6bd4 100644 --- a/mld2p4/psb_dmlprc_bld.f90 +++ b/mld2p4/psb_dmlprc_bld.f90 @@ -36,14 +36,8 @@ !!$ subroutine psb_dmlprc_bld(a,desc_a,p,info) - use psb_serial_mod - use psb_tools_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_const_mod - use psb_error_mod - use psb_penv_mod - use psb_prec_mod, only : psb_genaggrmap, psb_bldaggrmat, psb_baseprc_bld implicit none type(psb_dspmat_type), intent(in), target :: a @@ -58,6 +52,43 @@ subroutine psb_dmlprc_bld(a,desc_a,p,info) logical, parameter :: debug=.false. type(psb_dspmat_type) :: ac + interface psb_baseprc_bld + subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd) + use psb_base_mod + use psb_prec_type + type(psb_dspmat_type), target :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_dbaseprc_type),intent(inout) :: p + integer, intent(out) :: info + character, intent(in), optional :: upd + end subroutine psb_dbaseprc_bld + end interface + + interface psb_genaggrmap + subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info) + use psb_base_mod + use psb_prec_type + implicit none + integer, intent(in) :: aggr_type + type(psb_dspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, allocatable :: ilaggr(:),nlaggr(:) + integer, intent(out) :: info + end subroutine psb_dgenaggrmap + end interface + + interface psb_bldaggrmat + subroutine psb_dbldaggrmat(a,desc_a,ac,desc_ac,p,info) + use psb_base_mod + use psb_prec_type + type(psb_dspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_dspmat_type), intent(out),target :: ac + type(psb_desc_type), intent(inout) :: desc_ac + type(psb_dbaseprc_type), intent(inout), target :: p + integer, intent(out) :: info + end subroutine psb_dbldaggrmat + end interface integer :: ictxt, np, me diff --git a/mld2p4/psb_dprc_aply.f90 b/mld2p4/psb_dprc_aply.f90 index e80fb261..0ec31ae6 100644 --- a/mld2p4/psb_dprc_aply.f90 +++ b/mld2p4/psb_dprc_aply.f90 @@ -36,14 +36,8 @@ !!$ subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans, work) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_psblas_mod - use psb_const_mod - use psb_error_mod - use psb_penv_mod - use psb_prec_mod, only: psb_mlprc_aply, psb_baseprc_aply implicit none type(psb_desc_type),intent(in) :: desc_data @@ -61,6 +55,34 @@ subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans, work) external mpi_wtime character(len=20) :: name + interface psb_baseprc_aply + subroutine psb_dbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use psb_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(psb_dbaseprc_type), intent(in) :: prec + real(kind(0.d0)),intent(inout) :: x(:), y(:) + real(kind(0.d0)),intent(in) :: alpha,beta + character(len=1) :: trans + real(kind(0.d0)),target :: work(:) + integer, intent(out) :: info + end subroutine psb_dbaseprc_aply + end interface + + interface psb_mlprc_aply + subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use psb_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(psb_dbaseprc_type), intent(in) :: baseprecv(:) + real(kind(0.d0)),intent(in) :: alpha,beta + real(kind(0.d0)),intent(inout) :: x(:), y(:) + character :: trans + real(kind(0.d0)),target :: work(:) + integer, intent(out) :: info + end subroutine psb_dmlprc_aply + end interface + name='psb_dprc_aply' info = 0 call psb_erractionsave(err_act) @@ -159,18 +181,20 @@ end subroutine psb_dprc_aply !!$ subroutine psb_dprc_aply1(prec,x,desc_data,info,trans) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_psblas_mod - use psb_const_mod - use psb_error_mod - use psb_penv_mod implicit none - interface psb_prc_aply + + type(psb_desc_type),intent(in) :: desc_data + type(psb_dprec_type), intent(in) :: prec + real(kind(0.d0)),intent(inout) :: x(:) + integer, intent(out) :: info + character(len=1), optional :: trans + logical,parameter :: debug=.false., debugprt=.false. + + interface subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans, work) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type implicit none @@ -182,13 +206,6 @@ subroutine psb_dprc_aply1(prec,x,desc_data,info,trans) real(kind(0.d0)), optional, target :: work(:) end subroutine psb_dprc_aply end interface - type(psb_desc_type),intent(in) :: desc_data - type(psb_dprec_type), intent(in) :: prec - real(kind(0.d0)),intent(inout) :: x(:) - integer, intent(out) :: info - character(len=1), optional :: trans - logical,parameter :: debug=.false., debugprt=.false. - ! Local variables character :: trans_ @@ -214,7 +231,7 @@ subroutine psb_dprc_aply1(prec,x,desc_data,info,trans) goto 9999 end if if (debug) write(0,*) 'Prc_aply1 Size(x) ',size(x), size(ww),size(w1) - call psb_prc_aply(prec,x,ww,desc_data,info,trans_,work=w1) + call psb_dprc_aply(prec,x,ww,desc_data,info,trans_,work=w1) if(info /=0) goto 9999 x(:) = ww(:) deallocate(ww,W1) diff --git a/mld2p4/psb_dprecbld.f90 b/mld2p4/psb_dprecbld.f90 index 08388629..53debd43 100644 --- a/mld2p4/psb_dprecbld.f90 +++ b/mld2p4/psb_dprecbld.f90 @@ -36,17 +36,9 @@ !!$ subroutine psb_dprecbld(a,desc_a,p,info,upd) - use psb_serial_mod - Use psb_spmat_type - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_tools_mod - use psb_comm_mod - use psb_const_mod - use psb_psblas_mod - use psb_error_mod - use psb_penv_mod - use psb_prec_mod, only: psb_mlprc_bld, psb_baseprc_bld + use psb_prec_mod Implicit None type(psb_dspmat_type), target :: a @@ -60,9 +52,9 @@ subroutine psb_dprecbld(a,desc_a,p,info,upd) integer :: int_err(5) character :: iupd - logical, parameter :: debug=.false., filedump=.false. + logical, parameter :: debug=.false. integer,parameter :: iroot=0,iout=60,ilout=40 - character(len=20) :: name, ch_err,dumpname + character(len=20) :: name, ch_err if(psb_get_errstatus().ne.0) return info=0 @@ -142,18 +134,7 @@ subroutine psb_dprecbld(a,desc_a,p,info,upd) if (debug) then write(0,*) 'Return from ',i-1,' call to mlprcbld ',info endif - if (filedump) then - write(dumpname,'(a,i2.2,a,i2.2,a)'),'ac_lev_',i,'.',me,'.out' - open(20,file=dumpname) - call psb_csprt(20,p%baseprecv(i)%av(ac_)) - call flush(20) - close(20) - write(dumpname,'(a,i2.2,a,i2.2,a)'),'nd_lev_',i,'.',me,'.out' - open(20,file=dumpname) - call psb_csprt(20,p%baseprecv(i)%av(ap_nd_)) - call flush(20) - close(20) - end if + end do endif diff --git a/mld2p4/psb_dprecfree.f90 b/mld2p4/psb_dprecfree.f90 index d6003d51..e1dd3264 100644 --- a/mld2p4/psb_dprecfree.f90 +++ b/mld2p4/psb_dprecfree.f90 @@ -35,16 +35,9 @@ !!$ !!$ subroutine psb_dprecfree(p,info) - !...free sparse matrix structure... - use psb_descriptor_type - use psb_serial_mod - use psb_const_mod + use psb_base_mod use psb_prec_type - use psb_tools_mod - use psb_error_mod implicit none - !....parameters... - type(psb_dprec_type), intent(inout) :: p integer, intent(out) :: info diff --git a/mld2p4/psb_dprecset.f90 b/mld2p4/psb_dprecset.f90 index 3f2a45a8..58cc4cd2 100644 --- a/mld2p4/psb_dprecset.f90 +++ b/mld2p4/psb_dprecset.f90 @@ -36,10 +36,8 @@ !!$ subroutine psb_dprecset(p,ptype,info,iv,rs,rv,ilev,nlev) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_string_mod implicit none type(psb_dprec_type), intent(inout) :: p character(len=*), intent(in) :: ptype diff --git a/mld2p4/psb_dslu_bld.f90 b/mld2p4/psb_dslu_bld.f90 index 1879e910..b1d824fd 100644 --- a/mld2p4/psb_dslu_bld.f90 +++ b/mld2p4/psb_dslu_bld.f90 @@ -35,13 +35,9 @@ !!$ !!$ subroutine psb_dslu_bld(a,desc_a,p,info) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_tools_mod - use psb_const_mod - use psb_penv_mod - use psb_prec_mod, only: psb_as_matbld + implicit none type(psb_dspmat_type), intent(inout) :: a @@ -57,12 +53,27 @@ subroutine psb_dslu_bld(a,desc_a,p,info) logical, parameter :: debug=.false. character(len=20) :: name, ch_err + interface psb_asmatbld + Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) + use psb_base_mod + use psb_prec_type + integer, intent(in) :: ptype,novr + Type(psb_dspmat_type), Intent(in) :: a + Type(psb_dspmat_type), Intent(inout) :: blk + Type(psb_desc_type), Intent(inout) :: desc_p + Type(psb_desc_type), Intent(in) :: desc_data + Character, Intent(in) :: upd + integer, intent(out) :: info + character(len=5), optional :: outfmt + end Subroutine psb_dasmatbld + end interface + if(psb_get_errstatus().ne.0) return info=0 name='psb_slu_bld' call psb_erractionsave(err_act) - ictxt = desc_A%matrix_data(psb_ctxt_) + ictxt = desc_a%matrix_data(psb_ctxt_) call psb_info(ictxt, me, np) @@ -88,18 +99,18 @@ subroutine psb_dslu_bld(a,desc_a,p,info) write(0,*) me, 'SPLUBLD: Done csdp',info,nza,atmp%m,atmp%k call psb_barrier(ictxt) endif - call psb_as_matbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& + call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& & blck,desc_a,upd,p%desc_data,info,outfmt=fmt) if(info /= 0) then info=4010 - ch_err='psb_as_matbld' + ch_err='psb_asmatbld' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if nzb = blck%infoa(psb_nnz_) if (Debug) then - write(0,*) me, 'SPLUBLD: Done as_matbld',info,nzb,blck%fida + write(0,*) me, 'SPLUBLD: Done asmatbld',info,nzb,blck%fida call psb_barrier(ictxt) endif if (nzb > 0 ) then diff --git a/mld2p4/psb_dsp_renum.f90 b/mld2p4/psb_dsp_renum.f90 index 0d6cbead..347f2582 100644 --- a/mld2p4/psb_dsp_renum.f90 +++ b/mld2p4/psb_dsp_renum.f90 @@ -35,15 +35,8 @@ !!$ !!$ subroutine psb_dsp_renum(a,desc_a,blck,p,atmp,info) - use psb_serial_mod - use psb_const_mod + use psb_base_mod use psb_prec_type - use psb_descriptor_type - use psb_spmat_type - use psb_tools_mod - use psb_psblas_mod - use psb_error_mod - use psb_penv_mod implicit none ! .. array Arguments .. @@ -377,7 +370,6 @@ contains integer,dimension(:,:),allocatable::NDstk integer,dimension(:),allocatable::iOld,renum,ndeg,lvl,lvls1,lvls2,ccstor - !--- Per la common area. character(len=20) :: name, ch_err diff --git a/mld2p4/psb_dumf_bld.f90 b/mld2p4/psb_dumf_bld.f90 index c86c523b..cb3c9008 100644 --- a/mld2p4/psb_dumf_bld.f90 +++ b/mld2p4/psb_dumf_bld.f90 @@ -35,13 +35,8 @@ !!$ !!$ subroutine psb_dumf_bld(a,desc_a,p,info) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_tools_mod - use psb_const_mod - use psb_penv_mod - use psb_prec_mod, only: psb_as_matbld implicit none type(psb_dspmat_type), intent(inout) :: a @@ -58,6 +53,21 @@ subroutine psb_dumf_bld(a,desc_a,p,info) logical, parameter :: debug=.false. character(len=20) :: name, ch_err + interface psb_asmatbld + Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) + use psb_base_mod + use psb_prec_type + integer, intent(in) :: ptype,novr + Type(psb_dspmat_type), Intent(in) :: a + Type(psb_dspmat_type), Intent(inout) :: blk + Type(psb_desc_type), Intent(inout) :: desc_p + Type(psb_desc_type), Intent(in) :: desc_data + Character, Intent(in) :: upd + integer, intent(out) :: info + character(len=5), optional :: outfmt + end Subroutine psb_dasmatbld + end interface + info=0 name='psb_umf_bld' call psb_erractionsave(err_act) @@ -89,18 +99,18 @@ subroutine psb_dumf_bld(a,desc_a,p,info) write(0,*) me, 'UMFBLD: Done csdp',info,nza,atmp%m,atmp%k,nzb call psb_barrier(ictxt) endif - call psb_as_matbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& + call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& & blck,desc_a,upd,p%desc_data,info,outfmt=fmt) if(info /= 0) then info=4010 - ch_err='psb_as_matbld' + ch_err='psb_asmatbld' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if nzb = psb_sp_get_nnzeros(blck) if (Debug) then - write(0,*) me, 'UMFBLD: Done as_matbld',info,nzb,blck%fida + write(0,*) me, 'UMFBLD: Done asmatbld',info,nzb,blck%fida call psb_barrier(ictxt) endif if (nzb > 0 ) then diff --git a/base/modules/psb_prec_mod.f90 b/mld2p4/psb_prec_mod.f90 similarity index 87% rename from base/modules/psb_prec_mod.f90 rename to mld2p4/psb_prec_mod.f90 index 593e1163..5da38c0e 100644 --- a/base/modules/psb_prec_mod.f90 +++ b/mld2p4/psb_prec_mod.f90 @@ -1,7 +1,13 @@ !!$ +!!$ +!!$ MD2P4 +!!$ Multilevel Domain Decomposition Parallel Preconditioner Package for PSBLAS +!!$ for !!$ Parallel Sparse BLAS v2.0 !!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata !!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Daniela di Serafino Second University of Naples +!!$ Pasqua D'Ambra ICAR-CNR !!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions @@ -11,14 +17,14 @@ !!$ 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 +!!$ 3. The name of the MD2P4 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 +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MD2P4 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 @@ -28,14 +34,13 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ - module psb_prec_mod use psb_prec_type interface psb_precbld subroutine psb_dprecbld(a,desc_a,prec,info,upd) - use psb_descriptor_type + use psb_base_mod use psb_prec_type implicit none type(psb_dspmat_type), intent(in), target :: a @@ -45,7 +50,7 @@ module psb_prec_mod character, intent(in),optional :: upd end subroutine psb_dprecbld subroutine psb_zprecbld(a,desc_a,prec,info,upd) - use psb_descriptor_type + use psb_base_mod use psb_prec_type implicit none type(psb_zspmat_type), intent(in), target :: a @@ -58,8 +63,7 @@ module psb_prec_mod interface psb_precset subroutine psb_dprecset(prec,ptype,info,iv,rs,rv,ilev,nlev) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type implicit none type(psb_dprec_type), intent(inout) :: prec @@ -71,8 +75,7 @@ module psb_prec_mod real(kind(1.d0)), optional, intent(in) :: rv(:) end subroutine psb_dprecset subroutine psb_zprecset(prec,ptype,info,iv,rs,rv,ilev,nlev) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type implicit none type(psb_zprec_type), intent(inout) :: prec @@ -88,17 +91,13 @@ module psb_prec_mod interface psb_precfree subroutine psb_dprecfree(p,info) - use psb_descriptor_type - use psb_serial_mod - use psb_const_mod + use psb_base_mod use psb_prec_type type(psb_dprec_type), intent(inout) :: p integer, intent(out) :: info end subroutine psb_dprecfree subroutine psb_zprecfree(p,info) - use psb_descriptor_type - use psb_serial_mod - use psb_const_mod + use psb_base_mod use psb_prec_type type(psb_zprec_type), intent(inout) :: p integer, intent(out) :: info @@ -107,8 +106,7 @@ module psb_prec_mod interface psb_prc_aply subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans,work) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type type(psb_desc_type),intent(in) :: desc_data type(psb_dprec_type), intent(in) :: prec @@ -118,8 +116,7 @@ module psb_prec_mod real(kind(0.d0)),intent(inout), optional, target :: work(:) end subroutine psb_dprc_aply subroutine psb_dprc_aply1(prec,x,desc_data,info,trans) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type type(psb_desc_type),intent(in) :: desc_data type(psb_dprec_type), intent(in) :: prec @@ -128,8 +125,7 @@ module psb_prec_mod character(len=1), optional :: trans end subroutine psb_dprc_aply1 subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans,work) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type type(psb_desc_type),intent(in) :: desc_data type(psb_zprec_type), intent(in) :: prec @@ -139,8 +135,7 @@ module psb_prec_mod complex(kind(0.d0)),intent(inout), optional, target :: work(:) end subroutine psb_zprc_aply subroutine psb_zprc_aply1(prec,x,desc_data,info,trans) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type type(psb_desc_type),intent(in) :: desc_data type(psb_zprec_type), intent(in) :: prec @@ -152,8 +147,7 @@ module psb_prec_mod interface psb_baseprc_bld subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd) - Use psb_spmat_type - use psb_descriptor_type + use psb_base_mod use psb_prec_type type(psb_dspmat_type), target :: a type(psb_desc_type), intent(in), target :: desc_a @@ -162,8 +156,7 @@ module psb_prec_mod character, intent(in), optional :: upd end subroutine psb_dbaseprc_bld subroutine psb_zbaseprc_bld(a,desc_a,p,info,upd) - Use psb_spmat_type - use psb_descriptor_type + use psb_base_mod use psb_prec_type type(psb_zspmat_type), target :: a type(psb_desc_type), intent(in), target :: desc_a @@ -175,24 +168,16 @@ module psb_prec_mod interface psb_mlprc_bld subroutine psb_dmlprc_bld(a,desc_a,p,info) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_const_mod - implicit none - type(psb_dspmat_type), intent(in), target :: a type(psb_desc_type), intent(in), target :: desc_a type(psb_dbaseprc_type), intent(inout), target :: p integer, intent(out) :: info end subroutine psb_dmlprc_bld subroutine psb_zmlprc_bld(a,desc_a,p,info) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_const_mod - implicit none - type(psb_zspmat_type), intent(in), target :: a type(psb_desc_type), intent(in), target :: desc_a type(psb_zbaseprc_type), intent(inout),target :: p @@ -203,7 +188,7 @@ module psb_prec_mod interface psb_baseprc_aply subroutine psb_dbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) - use psb_descriptor_type + use psb_base_mod use psb_prec_type type(psb_desc_type),intent(in) :: desc_data type(psb_dbaseprc_type), intent(in) :: prec @@ -215,7 +200,7 @@ module psb_prec_mod end subroutine psb_dbaseprc_aply subroutine psb_zbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) - use psb_descriptor_type + use psb_base_mod use psb_prec_type type(psb_desc_type),intent(in) :: desc_data type(psb_zbaseprc_type), intent(in) :: prec @@ -229,7 +214,7 @@ module psb_prec_mod interface psb_mlprc_aply subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) - use psb_descriptor_type + use psb_base_mod use psb_prec_type type(psb_desc_type),intent(in) :: desc_data type(psb_dbaseprc_type), intent(in) :: baseprecv(:) @@ -240,7 +225,7 @@ module psb_prec_mod integer, intent(out) :: info end subroutine psb_dmlprc_aply subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) - use psb_descriptor_type + use psb_base_mod use psb_prec_type type(psb_desc_type),intent(in) :: desc_data type(psb_zbaseprc_type), intent(in) :: baseprecv(:) @@ -254,7 +239,7 @@ module psb_prec_mod interface psb_bjac_aply subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) - use psb_descriptor_type + use psb_base_mod use psb_prec_type type(psb_desc_type), intent(in) :: desc_data type(psb_dbaseprc_type), intent(in) :: prec @@ -266,7 +251,7 @@ module psb_prec_mod end subroutine psb_dbjac_aply subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) - use psb_descriptor_type + use psb_base_mod use psb_prec_type type(psb_desc_type), intent(in) :: desc_data type(psb_zbaseprc_type), intent(in) :: prec @@ -281,8 +266,7 @@ module psb_prec_mod interface psb_diagsc_bld subroutine psb_ddiagsc_bld(a,desc_data,p,upd,info) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type integer, intent(out) :: info type(psb_dspmat_type), intent(in), target :: a @@ -291,8 +275,7 @@ module psb_prec_mod character, intent(in) :: upd end subroutine psb_ddiagsc_bld subroutine psb_zdiagsc_bld(a,desc_data,p,upd,info) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type integer, intent(out) :: info type(psb_zspmat_type), intent(in), target :: a @@ -304,8 +287,7 @@ module psb_prec_mod interface psb_ilu_bld subroutine psb_dilu_bld(a,desc_data,p,upd,info) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type integer, intent(out) :: info type(psb_dspmat_type), intent(in), target :: a @@ -314,8 +296,7 @@ module psb_prec_mod character, intent(in) :: upd end subroutine psb_dilu_bld subroutine psb_zilu_bld(a,desc_data,p,upd,info) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type integer, intent(out) :: info type(psb_zspmat_type), intent(in), target :: a @@ -327,24 +308,16 @@ module psb_prec_mod interface psb_slu_bld subroutine psb_dslu_bld(a,desc_a,p,info) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_const_mod - implicit none - type(psb_dspmat_type), intent(inout) :: a type(psb_desc_type), intent(in) :: desc_a type(psb_dbaseprc_type), intent(inout) :: p integer, intent(out) :: info end subroutine psb_dslu_bld subroutine psb_zslu_bld(a,desc_a,p,info) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_const_mod - implicit none - type(psb_zspmat_type), intent(inout) :: a type(psb_desc_type), intent(in) :: desc_a type(psb_zbaseprc_type), intent(inout) :: p @@ -354,24 +327,16 @@ module psb_prec_mod interface psb_umf_bld subroutine psb_dumf_bld(a,desc_a,p,info) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_const_mod - implicit none - type(psb_dspmat_type), intent(inout) :: a type(psb_desc_type), intent(in) :: desc_a type(psb_dbaseprc_type), intent(inout) :: p integer, intent(out) :: info end subroutine psb_dumf_bld subroutine psb_zumf_bld(a,desc_a,p,info) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_const_mod - implicit none - type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a type(psb_zbaseprc_type), intent(inout) :: p @@ -382,7 +347,7 @@ module psb_prec_mod interface psb_ilu_fct subroutine psb_dilu_fct(a,l,u,d,info,blck) - use psb_spmat_type + use psb_base_mod integer, intent(out) :: info type(psb_dspmat_type),intent(in) :: a type(psb_dspmat_type),intent(inout) :: l,u @@ -390,7 +355,7 @@ module psb_prec_mod real(kind(1.d0)), intent(inout) :: d(:) end subroutine psb_dilu_fct subroutine psb_zilu_fct(a,l,u,d,info,blck) - use psb_spmat_type + use psb_base_mod integer, intent(out) :: info type(psb_zspmat_type),intent(in) :: a type(psb_zspmat_type),intent(inout) :: l,u @@ -401,9 +366,8 @@ module psb_prec_mod interface psb_as_matbld Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) - use psb_serial_mod - Use psb_descriptor_type - Use psb_prec_type + use psb_base_mod + use psb_prec_type integer, intent(in) :: ptype,novr Type(psb_dspmat_type), Intent(in) :: a Type(psb_dspmat_type), Intent(inout) :: blk @@ -414,9 +378,8 @@ module psb_prec_mod character(len=5), optional :: outfmt end Subroutine psb_dasmatbld Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) - use psb_serial_mod - Use psb_descriptor_type - Use psb_prec_type + use psb_base_mod + use psb_prec_type integer, intent(in) :: ptype,novr Type(psb_zspmat_type), Intent(in) :: a Type(psb_zspmat_type), Intent(inout) :: blk @@ -430,12 +393,8 @@ module psb_prec_mod interface psb_sp_renum subroutine psb_dsp_renum(a,desc_a,blck,p,atmp,info) + use psb_base_mod use psb_prec_type - use psb_descriptor_type - use psb_spmat_type - implicit none - - ! .. array Arguments .. type(psb_dspmat_type), intent(in) :: a,blck type(psb_dspmat_type), intent(inout) :: atmp type(psb_dbaseprc_type), intent(inout) :: p @@ -443,12 +402,8 @@ module psb_prec_mod integer, intent(out) :: info end subroutine psb_dsp_renum subroutine psb_zsp_renum(a,desc_a,blck,p,atmp,info) + use psb_base_mod use psb_prec_type - use psb_descriptor_type - use psb_spmat_type - implicit none - - ! .. array Arguments .. type(psb_zspmat_type), intent(in) :: a,blck type(psb_zspmat_type), intent(inout) :: atmp type(psb_zbaseprc_type), intent(inout) :: p @@ -460,9 +415,8 @@ module psb_prec_mod interface psb_genaggrmap subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info) - use psb_spmat_type - use psb_descriptor_type - implicit none + use psb_base_mod + use psb_prec_type integer, intent(in) :: aggr_type type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a @@ -470,9 +424,8 @@ module psb_prec_mod integer, intent(out) :: info end subroutine psb_dgenaggrmap subroutine psb_zgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info) - use psb_spmat_type - use psb_descriptor_type - implicit none + use psb_base_mod + use psb_prec_type integer, intent(in) :: aggr_type type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a @@ -483,9 +436,8 @@ module psb_prec_mod interface psb_bldaggrmat subroutine psb_dbldaggrmat(a,desc_a,ac,desc_ac,p,info) + use psb_base_mod use psb_prec_type - use psb_descriptor_type - use psb_spmat_type type(psb_dspmat_type), intent(in), target :: a type(psb_desc_type), intent(in) :: desc_a type(psb_dspmat_type), intent(inout),target :: ac @@ -494,9 +446,8 @@ module psb_prec_mod integer, intent(out) :: info end subroutine psb_dbldaggrmat subroutine psb_zbldaggrmat(a,desc_a,ac,desc_ac,p,info) + use psb_base_mod use psb_prec_type - use psb_descriptor_type - use psb_spmat_type type(psb_zspmat_type), intent(in), target :: a type(psb_zbaseprc_type), intent(inout),target :: p type(psb_zspmat_type), intent(inout),target :: ac diff --git a/base/modules/psb_prec_type.f90 b/mld2p4/psb_prec_type.f90 similarity index 98% rename from base/modules/psb_prec_type.f90 rename to mld2p4/psb_prec_type.f90 index 86d1107c..572a1a8b 100644 --- a/base/modules/psb_prec_type.f90 +++ b/mld2p4/psb_prec_type.f90 @@ -1,7 +1,13 @@ !!$ +!!$ +!!$ MD2P4 +!!$ Multilevel Domain Decomposition Parallel Preconditioner Package for PSBLAS +!!$ for !!$ Parallel Sparse BLAS v2.0 !!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata !!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Daniela di Serafino Second University of Naples +!!$ Pasqua D'Ambra ICAR-CNR !!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions @@ -11,14 +17,14 @@ !!$ 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 +!!$ 3. The name of the MD2P4 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 +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MD2P4 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 @@ -27,17 +33,13 @@ !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. !!$ -!!$ +module psb_prec_type !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Module to define PREC_DATA, !! !! structure for preconditioning. !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -module psb_prec_type - - use psb_const_mod - use psb_spmat_type - use psb_descriptor_type + use psb_base_mod integer, parameter :: min_prec_=0, noprec_=0, diagsc_=1, bja_=2,& & asm_=3, ras_=5, ash_=4, rash_=6, ras2lv_=7, ras2lvm_=8,& @@ -653,9 +655,8 @@ contains end subroutine psb_dcheck_def subroutine psb_dbase_precfree(p,info) - use psb_serial_mod - use psb_descriptor_type - use psb_tools_mod + use psb_base_mod + type(psb_dbaseprc_type), intent(inout) :: p integer, intent(out) :: info integer :: i @@ -728,7 +729,8 @@ contains end subroutine psb_dbase_precfree subroutine psb_nullify_dbaseprec(p) - use psb_descriptor_type + use psb_base_mod + type(psb_dbaseprc_type), intent(inout) :: p nullify(p%base_a) @@ -739,9 +741,7 @@ contains end subroutine psb_nullify_dbaseprec subroutine psb_zbase_precfree(p,info) - use psb_serial_mod - use psb_descriptor_type - use psb_tools_mod + use psb_base_mod type(psb_zbaseprc_type), intent(inout) :: p integer, intent(out) :: info integer :: i @@ -809,7 +809,8 @@ contains end subroutine psb_zbase_precfree subroutine psb_nullify_zbaseprec(p) - use psb_descriptor_type + use psb_base_mod + type(psb_zbaseprc_type), intent(inout) :: p diff --git a/mld2p4/psb_umf_impl.c b/mld2p4/psb_umf_impl.c index 9dfd033f..902ce1a3 100644 --- a/mld2p4/psb_umf_impl.c +++ b/mld2p4/psb_umf_impl.c @@ -35,7 +35,8 @@ * */ /* This file is an interface to the UMFPACK routines for sparse - factorization. + factorization. It was obtained by adapting umfpack_di_demo + under the original copyright terms reproduced below. PSBLAS v 2.0 */ diff --git a/mld2p4/psb_zasmatbld.f90 b/mld2p4/psb_zasmatbld.f90 index bb705d90..dbcf1e98 100644 --- a/mld2p4/psb_zasmatbld.f90 +++ b/mld2p4/psb_zasmatbld.f90 @@ -53,13 +53,8 @@ !***************************************************************************** Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) - use psb_serial_mod - use psb_descriptor_type - Use psb_prec_type - use psb_tools_mod - use psb_const_mod - use psb_error_mod - use psb_penv_mod + use psb_base_mod + use psb_prec_type Implicit None ! .. Array Arguments .. diff --git a/mld2p4/psb_zbaseprc_aply.f90 b/mld2p4/psb_zbaseprc_aply.f90 index dd588774..951aa47e 100644 --- a/mld2p4/psb_zbaseprc_aply.f90 +++ b/mld2p4/psb_zbaseprc_aply.f90 @@ -39,15 +39,8 @@ subroutine psb_zbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) ! Compute Y <- beta*Y + alpha*K^-1 X ! where K is a a basic preconditioner stored in prec ! - - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_psblas_mod - use psb_const_mod - use psb_error_mod - use psb_penv_mod - use psb_prec_mod, only : psb_bjac_aply implicit none type(psb_desc_type),intent(in) :: desc_data @@ -68,6 +61,20 @@ subroutine psb_zbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) external mpi_wtime character(len=20) :: name, ch_err + interface psb_bjac_aply + subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use psb_prec_type + type(psb_desc_type), intent(in) :: desc_data + type(psb_zbaseprc_type), intent(in) :: prec + complex(kind(0.d0)),intent(inout) :: x(:), y(:) + complex(kind(0.d0)),intent(in) :: alpha,beta + character(len=1) :: trans + complex(kind(0.d0)),target :: work(:) + integer, intent(out) :: info + end subroutine psb_zbjac_aply + end interface + name='psb_zbaseprc_aply' info = 0 call psb_erractionsave(err_act) diff --git a/mld2p4/psb_zbaseprc_bld.f90 b/mld2p4/psb_zbaseprc_bld.f90 index ed7a04c3..2c493f61 100644 --- a/mld2p4/psb_zbaseprc_bld.f90 +++ b/mld2p4/psb_zbaseprc_bld.f90 @@ -36,18 +36,8 @@ !!$ subroutine psb_zbaseprc_bld(a,desc_a,p,info,upd) - use psb_serial_mod - Use psb_spmat_type - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_tools_mod - use psb_comm_mod - use psb_const_mod - use psb_psblas_mod - use psb_error_mod - use psb_penv_mod - use psb_prec_mod, only: psb_diagsc_bld, psb_ilu_bld, & - & psb_slu_bld,psb_umf_bld Implicit None type(psb_zspmat_type), target :: a @@ -56,6 +46,51 @@ subroutine psb_zbaseprc_bld(a,desc_a,p,info,upd) integer, intent(out) :: info character, intent(in), optional :: upd + interface psb_diagsc_bld + subroutine psb_zdiagsc_bld(a,desc_data,p,upd,info) + use psb_base_mod + use psb_prec_type + integer, intent(out) :: info + type(psb_zspmat_type), intent(in), target :: a + type(psb_desc_type),intent(in) :: desc_data + type(psb_zbaseprc_type), intent(inout) :: p + character, intent(in) :: upd + end subroutine psb_zdiagsc_bld + end interface + + interface psb_ilu_bld + subroutine psb_zilu_bld(a,desc_data,p,upd,info) + use psb_base_mod + use psb_prec_type + integer, intent(out) :: info + type(psb_zspmat_type), intent(in), target :: a + type(psb_desc_type),intent(in) :: desc_data + type(psb_zbaseprc_type), intent(inout) :: p + character, intent(in) :: upd + end subroutine psb_zilu_bld + end interface + + interface psb_slu_bld + subroutine psb_zslu_bld(a,desc_a,p,info) + use psb_base_mod + use psb_prec_type + type(psb_zspmat_type), intent(inout) :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_zbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + end subroutine psb_zslu_bld + end interface + + interface psb_umf_bld + subroutine psb_zumf_bld(a,desc_a,p,info) + use psb_base_mod + use psb_prec_type + type(psb_zspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_zbaseprc_type), intent(inout) :: p + integer, intent(out) :: info + end subroutine psb_zumf_bld + end interface ! Local scalars Integer :: err, nnzero, n_row, n_col,I,j,k,ictxt,& diff --git a/mld2p4/psb_zbjac_aply.f90 b/mld2p4/psb_zbjac_aply.f90 index e98e9ddf..9ef190e7 100644 --- a/mld2p4/psb_zbjac_aply.f90 +++ b/mld2p4/psb_zbjac_aply.f90 @@ -42,13 +42,8 @@ subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) ! but since both are INTENT(IN) this should be legal. ! - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_psblas_mod - use psb_const_mod - use psb_error_mod - use psb_penv_mod implicit none type(psb_desc_type), intent(in) :: desc_data diff --git a/mld2p4/psb_zbldaggrmat.f90 b/mld2p4/psb_zbldaggrmat.f90 index fc525f71..896ea16a 100644 --- a/mld2p4/psb_zbldaggrmat.f90 +++ b/mld2p4/psb_zbldaggrmat.f90 @@ -35,19 +35,13 @@ !!$ !!$ subroutine psb_zbldaggrmat(a,desc_a,ac,desc_ac,p,info) - use psb_serial_mod - use psb_penv_mod + use psb_base_mod use psb_prec_type - use psb_descriptor_type - use psb_spmat_type - use psb_tools_mod - use psb_psblas_mod - use psb_error_mod implicit none type(psb_zspmat_type), intent(in), target :: a type(psb_zbaseprc_type), intent(inout),target :: p - type(psb_zspmat_type), intent(inout), target :: ac + type(psb_zspmat_type), intent(out), target :: ac type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(inout) :: desc_ac integer, intent(out) :: info @@ -103,16 +97,13 @@ subroutine psb_zbldaggrmat(a,desc_a,ac,desc_ac,p,info) contains subroutine raw_aggregate(info) + use psb_base_mod use psb_prec_type - use psb_const_mod - use psb_psblas_mod - use psb_error_mod - use psb_penv_mod implicit none include 'mpif.h' integer, intent(out) :: info - type(psb_zspmat_type) :: b + type(psb_zspmat_type) :: b, tmp integer, pointer :: nzbr(:), idisp(:) integer :: ictxt, nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& & naggr, np, me, nzt,jl,nzl,nlr,& @@ -146,8 +137,8 @@ contains do i=1, nrow p%mlia(i) = p%mlia(i) + naggrm1 end do - call psb_halo(p%mlia,desc_a,info) end if + call psb_halo(p%mlia,desc_a,info) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_halo') @@ -177,16 +168,10 @@ contains nzt = psb_sp_get_nnzeros(b) - j = 0 do i=1, nzt - if ((1<=b%ia2(i)).and.(b%ia2(i)<=nrow)) then - j = j + 1 - b%aspk(j) = b%aspk(i) - b%ia1(j) = p%mlia(b%ia1(i)) - b%ia2(j) = p%mlia(b%ia2(i)) - end if + b%ia1(i) = p%mlia(b%ia1(i)) + b%ia2(i) = p%mlia(b%ia2(i)) enddo - b%infoa(psb_nnz_)=j call psb_fixcoo(b,info) nzt = psb_sp_get_nnzeros(b) @@ -338,14 +323,10 @@ contains subroutine smooth_aggregate(info) - use psb_serial_mod - use psb_const_mod - use psb_comm_mod - use psb_tools_mod - use psb_error_mod - use psb_penv_mod + use psb_base_mod + use psb_prec_type + use mpi implicit none - include 'mpif.h' integer, intent(out) :: info diff --git a/mld2p4/psb_zdiagsc_bld.f90 b/mld2p4/psb_zdiagsc_bld.f90 index 0db8a0da..b925954f 100644 --- a/mld2p4/psb_zdiagsc_bld.f90 +++ b/mld2p4/psb_zdiagsc_bld.f90 @@ -36,16 +36,8 @@ !!$ subroutine psb_zdiagsc_bld(a,desc_a,p,upd,info) - use psb_serial_mod - Use psb_spmat_type - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_tools_mod - use psb_comm_mod - use psb_const_mod - use psb_psblas_mod - use psb_error_mod - use psb_penv_mod Implicit None type(psb_zspmat_type), target :: a diff --git a/mld2p4/psb_zgenaggrmap.f90 b/mld2p4/psb_zgenaggrmap.f90 index 9b3267a4..f89b00ca 100644 --- a/mld2p4/psb_zgenaggrmap.f90 +++ b/mld2p4/psb_zgenaggrmap.f90 @@ -35,11 +35,8 @@ !!$ !!$ subroutine psb_zgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info) - use psb_spmat_type - use psb_serial_mod - use psb_descriptor_type - use psb_error_mod - use psb_penv_mod + use psb_base_mod + use psb_prec_type implicit none integer, intent(in) :: aggr_type type(psb_zspmat_type), intent(in) :: a diff --git a/mld2p4/psb_zilu_bld.f90 b/mld2p4/psb_zilu_bld.f90 index 33ad2266..47085381 100644 --- a/mld2p4/psb_zilu_bld.f90 +++ b/mld2p4/psb_zilu_bld.f90 @@ -50,17 +50,8 @@ !* * !***************************************************************************** subroutine psb_zilu_bld(a,desc_a,p,upd,info) - use psb_serial_mod - use psb_const_mod + use psb_base_mod use psb_prec_type - use psb_descriptor_type - use psb_spmat_type - use psb_tools_mod - use psb_psblas_mod - use psb_error_mod - use psb_realloc_mod - use psb_penv_mod - use psb_prec_mod, only : psb_as_matbld, psb_ilu_fct, psb_sp_renum implicit none ! ! .. Scalar Arguments .. @@ -84,6 +75,44 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info) integer :: ictxt,np,me character(len=20) :: name, ch_err + interface psb_ilu_fct + subroutine psb_zilu_fct(a,l,u,d,info,blck) + use psb_base_mod + use psb_prec_type + integer, intent(out) :: info + type(psb_zspmat_type),intent(in) :: a + type(psb_zspmat_type),intent(inout) :: l,u + type(psb_zspmat_type),intent(in), optional, target :: blck + complex(kind(1.d0)), intent(inout) :: d(:) + end subroutine psb_zilu_fct + end interface + + interface psb_asmatbld + Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) + use psb_base_mod + use psb_prec_type + integer, intent(in) :: ptype,novr + Type(psb_zspmat_type), Intent(in) :: a + Type(psb_zspmat_type), Intent(inout) :: blk + Type(psb_desc_type), Intent(inout) :: desc_p + Type(psb_desc_type), Intent(in) :: desc_data + Character, Intent(in) :: upd + integer, intent(out) :: info + character(len=5), optional :: outfmt + end Subroutine psb_zasmatbld + end interface + + interface psb_sp_renum + subroutine psb_zsp_renum(a,desc_a,blck,p,atmp,info) + use psb_base_mod + use psb_prec_type + type(psb_zspmat_type), intent(in) :: a,blck + type(psb_zspmat_type), intent(inout) :: atmp + type(psb_zbaseprc_type), intent(inout) :: p + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psb_zsp_renum + end interface if(psb_get_errstatus().ne.0) return info=0 @@ -116,18 +145,18 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info) t1= mpi_wtime() - if(debug) write(0,*)me,': calling psb_as_matbld',p%iprcparm(p_type_),p%iprcparm(n_ovr_) + if(debug) write(0,*)me,': calling psb_asmatbld',p%iprcparm(p_type_),p%iprcparm(n_ovr_) if (debug) call psb_barrier(ictxt) - call psb_as_matbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& + call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& & blck,desc_a,upd,p%desc_data,info) if(info/=0) then info=4010 - ch_err='psb_as_matbld' + ch_err='psb_asmatbld' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if t2= mpi_wtime() - if (debug) write(0,*)me,': out of psb_as_matbld' + if (debug) write(0,*)me,': out of psb_asmatbld' if (debug) call psb_barrier(ictxt) if (allocated(p%av)) then @@ -178,7 +207,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info) if (debug) then - write(0,*) me,'Done psb_as_matbld' + write(0,*) me,'Done psb_asmatbld' call psb_barrier(ictxt) endif diff --git a/mld2p4/psb_zilu_fct.f90 b/mld2p4/psb_zilu_fct.f90 index 54b7a48a..22c96ab8 100644 --- a/mld2p4/psb_zilu_fct.f90 +++ b/mld2p4/psb_zilu_fct.f90 @@ -41,11 +41,8 @@ subroutine psb_zilu_fct(a,l,u,d,info,blck) ! into L/D/U. ! ! - use psb_spmat_type - use psb_serial_mod - use psb_tools_mod - use psb_error_mod - use psb_const_mod + use psb_base_mod + use psb_prec_type implicit none ! .. Scalar Arguments .. integer, intent(out) :: info diff --git a/mld2p4/psb_zmlprc_aply.f90 b/mld2p4/psb_zmlprc_aply.f90 index 771bc210..d55bf707 100644 --- a/mld2p4/psb_zmlprc_aply.f90 +++ b/mld2p4/psb_zmlprc_aply.f90 @@ -83,15 +83,8 @@ subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) ! 6. baseprecv(ilev)%nlaggr Number of aggregates on the various procs. ! - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_psblas_mod - use psb_penv_mod - use psb_const_mod - use psb_error_mod - use psb_penv_mod - use psb_prec_mod, only : psb_baseprc_aply implicit none type(psb_desc_type),intent(in) :: desc_data @@ -119,6 +112,20 @@ subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) end type psb_mlprec_wrk_type type(psb_mlprec_wrk_type), allocatable :: mlprec_wrk(:) + interface psb_baseprc_aply + subroutine psb_zbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use psb_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(psb_zbaseprc_type), intent(in) :: prec + complex(kind(1.d0)),intent(inout) :: x(:), y(:) + complex(kind(1.d0)),intent(in) :: alpha,beta + character(len=1) :: trans + complex(kind(1.d0)),target :: work(:) + integer, intent(out) :: info + end subroutine psb_zbaseprc_aply + end interface + name='psb_mlprc_aply' info = 0 call psb_erractionsave(err_act) diff --git a/mld2p4/psb_zmlprc_bld.f90 b/mld2p4/psb_zmlprc_bld.f90 index b3a9eb38..6fb737c7 100644 --- a/mld2p4/psb_zmlprc_bld.f90 +++ b/mld2p4/psb_zmlprc_bld.f90 @@ -36,14 +36,8 @@ !!$ subroutine psb_zmlprc_bld(a,desc_a,p,info) - use psb_serial_mod - use psb_tools_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_const_mod - use psb_error_mod - use psb_penv_mod - use psb_prec_mod, only : psb_genaggrmap, psb_bldaggrmat, psb_baseprc_bld implicit none type(psb_zspmat_type), intent(in), target :: a @@ -58,6 +52,44 @@ subroutine psb_zmlprc_bld(a,desc_a,p,info) logical, parameter :: debug=.false. type(psb_zspmat_type) :: ac + interface psb_baseprc_bld + subroutine psb_zbaseprc_bld(a,desc_a,p,info,upd) + use psb_base_mod + use psb_prec_type + type(psb_zspmat_type), target :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_zbaseprc_type),intent(inout) :: p + integer, intent(out) :: info + character, intent(in), optional :: upd + end subroutine psb_zbaseprc_bld + end interface + + interface psb_genaggrmap + subroutine psb_zgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info) + use psb_base_mod + use psb_prec_type + implicit none + integer, intent(in) :: aggr_type + type(psb_zspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, allocatable :: ilaggr(:),nlaggr(:) + integer, intent(out) :: info + end subroutine psb_zgenaggrmap + end interface + + interface psb_bldaggrmat + subroutine psb_zbldaggrmat(a,desc_a,ac,desc_ac,p,info) + use psb_base_mod + use psb_prec_type + type(psb_zspmat_type), intent(in), target :: a + type(psb_zbaseprc_type), intent(inout),target :: p + type(psb_zspmat_type), intent(out),target :: ac + type(psb_desc_type), intent(in) :: desc_a + type(psb_desc_type), intent(inout) :: desc_ac + integer, intent(out) :: info + end subroutine psb_zbldaggrmat + end interface + integer :: ictxt, np, me name='psb_mlprec_bld' diff --git a/mld2p4/psb_zprc_aply.f90 b/mld2p4/psb_zprc_aply.f90 index 20b9b0a5..ca48ce96 100644 --- a/mld2p4/psb_zprc_aply.f90 +++ b/mld2p4/psb_zprc_aply.f90 @@ -36,14 +36,8 @@ !!$ subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans, work) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_psblas_mod - use psb_const_mod - use psb_error_mod - use psb_penv_mod - use psb_prec_mod, only: psb_mlprc_aply, psb_baseprc_aply implicit none type(psb_desc_type),intent(in) :: desc_data @@ -61,6 +55,34 @@ subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans, work) external mpi_wtime character(len=20) :: name + interface psb_baseprc_aply + subroutine psb_zbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use psb_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(psb_zbaseprc_type), intent(in) :: prec + complex(kind(0.d0)),intent(inout) :: x(:), y(:) + complex(kind(0.d0)),intent(in) :: alpha,beta + character(len=1) :: trans + complex(kind(0.d0)),target :: work(:) + integer, intent(out) :: info + end subroutine psb_zbaseprc_aply + end interface + + interface psb_mlprc_aply + subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use psb_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(psb_zbaseprc_type), intent(in) :: baseprecv(:) + complex(kind(0.d0)),intent(in) :: alpha,beta + complex(kind(0.d0)),intent(inout) :: x(:), y(:) + character :: trans + complex(kind(0.d0)),target :: work(:) + integer, intent(out) :: info + end subroutine psb_zmlprc_aply + end interface + name='psb_zprc_aply' info = 0 call psb_erractionsave(err_act) @@ -158,37 +180,29 @@ end subroutine psb_zprc_aply !!$ !!$ subroutine psb_zprc_aply1(prec,x,desc_data,info,trans) - - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_psblas_mod - use psb_const_mod - use psb_error_mod - use psb_penv_mod implicit none - interface psb_prc_aply + + type(psb_desc_type),intent(in) :: desc_data + type(psb_zprec_type), intent(in) :: prec + complex(kind(0.d0)),intent(inout) :: x(:) + integer, intent(out) :: info + character(len=1), optional :: trans + logical,parameter :: debug=.false., debugprt=.false. + + interface subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans, work) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - implicit none - type(psb_desc_type),intent(in) :: desc_data type(psb_zprec_type), intent(in) :: prec - complex(kind(0.d0)),intent(inout) :: x(:), y(:) + complex(kind(0.d0)),intent(inout) :: x(:), y(:) integer, intent(out) :: info character(len=1), optional :: trans complex(kind(0.d0)), optional, target :: work(:) end subroutine psb_zprc_aply end interface - type(psb_desc_type),intent(in) :: desc_data - type(psb_zprec_type), intent(in) :: prec - complex(kind(0.d0)),intent(inout) :: x(:) - integer, intent(out) :: info - character(len=1), optional :: trans - logical,parameter :: debug=.false., debugprt=.false. - ! Local variables character :: trans_ @@ -214,7 +228,7 @@ subroutine psb_zprc_aply1(prec,x,desc_data,info,trans) goto 9999 end if if (debug) write(0,*) 'Prc_aply1 Size(x) ',size(x), size(ww),size(w1) - call psb_prc_aply(prec,x,ww,desc_data,info,trans_,work=w1) + call psb_zprc_aply(prec,x,ww,desc_data,info,trans_,work=w1) if(info /=0) goto 9999 x(:) = ww(:) deallocate(ww,W1) diff --git a/mld2p4/psb_zprecbld.f90 b/mld2p4/psb_zprecbld.f90 index bcf5a3fc..2a51df83 100644 --- a/mld2p4/psb_zprecbld.f90 +++ b/mld2p4/psb_zprecbld.f90 @@ -36,17 +36,9 @@ !!$ subroutine psb_zprecbld(a,desc_a,p,info,upd) - use psb_serial_mod - Use psb_spmat_type - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_tools_mod - use psb_comm_mod - use psb_const_mod - use psb_psblas_mod - use psb_error_mod - use psb_penv_mod - use psb_prec_mod, only: psb_mlprc_bld, psb_baseprc_bld + use psb_prec_mod Implicit None type(psb_zspmat_type), target :: a diff --git a/mld2p4/psb_zprecfree.f90 b/mld2p4/psb_zprecfree.f90 index d7e0bb74..7db0b54d 100644 --- a/mld2p4/psb_zprecfree.f90 +++ b/mld2p4/psb_zprecfree.f90 @@ -35,13 +35,8 @@ !!$ !!$ subroutine psb_zprecfree(p,info) - !...free sparse matrix structure... - use psb_descriptor_type - use psb_serial_mod - use psb_const_mod + use psb_base_mod use psb_prec_type - use psb_tools_mod - use psb_error_mod implicit none !....parameters... diff --git a/mld2p4/psb_zprecset.f90 b/mld2p4/psb_zprecset.f90 index 58729dbc..5c79e1d9 100644 --- a/mld2p4/psb_zprecset.f90 +++ b/mld2p4/psb_zprecset.f90 @@ -36,10 +36,8 @@ !!$ subroutine psb_zprecset(p,ptype,info,iv,rs,rv,ilev,nlev) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_string_mod implicit none type(psb_zprec_type), intent(inout) :: p diff --git a/mld2p4/psb_zslu_bld.f90 b/mld2p4/psb_zslu_bld.f90 index 563e1f49..1b51d6d1 100644 --- a/mld2p4/psb_zslu_bld.f90 +++ b/mld2p4/psb_zslu_bld.f90 @@ -35,13 +35,8 @@ !!$ !!$ subroutine psb_zslu_bld(a,desc_a,p,info) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_tools_mod - use psb_const_mod - use psb_penv_mod - use psb_prec_mod, only: psb_as_matbld implicit none type(psb_zspmat_type), intent(inout) :: a @@ -57,6 +52,21 @@ subroutine psb_zslu_bld(a,desc_a,p,info) logical, parameter :: debug=.false. character(len=20) :: name, ch_err + interface psb_asmatbld + Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) + use psb_base_mod + use psb_prec_type + integer, intent(in) :: ptype,novr + Type(psb_zspmat_type), Intent(in) :: a + Type(psb_zspmat_type), Intent(inout) :: blk + Type(psb_desc_type), Intent(inout) :: desc_p + Type(psb_desc_type), Intent(in) :: desc_data + Character, Intent(in) :: upd + integer, intent(out) :: info + character(len=5), optional :: outfmt + end Subroutine psb_zasmatbld + end interface + if(psb_get_errstatus().ne.0) return info=0 name='psb_slu_bld' @@ -88,18 +98,18 @@ subroutine psb_zslu_bld(a,desc_a,p,info) write(0,*) me, 'SPLUBLD: Done csdp',info,nza,atmp%m,atmp%k call psb_barrier(ictxt) endif - call psb_as_matbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& + call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& & blck,desc_a,upd,p%desc_data,info,outfmt=fmt) if(info /= 0) then info=4010 - ch_err='psb_as_matbld' + ch_err='psb_asmatbld' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if nzb = blck%infoa(psb_nnz_) if (Debug) then - write(0,*) me, 'SPLUBLD: Done as_matbld',info,nzb,blck%fida + write(0,*) me, 'SPLUBLD: Done asmatbld',info,nzb,blck%fida call psb_barrier(ictxt) endif if (nzb > 0 ) then diff --git a/mld2p4/psb_zsp_renum.f90 b/mld2p4/psb_zsp_renum.f90 index c6a449d7..7cdf5f83 100644 --- a/mld2p4/psb_zsp_renum.f90 +++ b/mld2p4/psb_zsp_renum.f90 @@ -35,15 +35,8 @@ !!$ !!$ subroutine psb_zsp_renum(a,desc_a,blck,p,atmp,info) - use psb_serial_mod - use psb_const_mod + use psb_base_mod use psb_prec_type - use psb_descriptor_type - use psb_spmat_type - use psb_tools_mod - use psb_psblas_mod - use psb_error_mod - use psb_penv_mod implicit none ! .. array Arguments .. @@ -376,8 +369,6 @@ contains integer,dimension(:,:),allocatable::NDstk integer,dimension(:),allocatable::iOld,renum,ndeg,lvl,lvls1,lvls2,ccstor - !--- Per la common area. - character(len=20) :: name, ch_err @@ -436,12 +427,12 @@ contains do i=1,Npnt iOld(i)=i enddo -!!$ write(0,*) 'gps_red : Preparation done' + write(0,*) 'gps_red : Preparation done' !--- !--- Chiamiamo funzione reduce. call psb_gps_reduce(Ndstk,Npnt,iOld,renum,ndeg,lvl,lvls1, lvls2,ccstor,& - & ibw2,ipf2,n,iDpth,iDeg) -!!$ write(0,*) 'gps_red : Done reduce' + & ibw2,ipf2,n,idpth,ideg) + write(0,*) 'gps_red : Done reduce' !--- Permutazione perm(1:Npnt)=renum(1:Npnt) !--- Inversa permutazione diff --git a/mld2p4/psb_zumf_bld.f90 b/mld2p4/psb_zumf_bld.f90 index c0c1ab4b..c82ce39f 100644 --- a/mld2p4/psb_zumf_bld.f90 +++ b/mld2p4/psb_zumf_bld.f90 @@ -35,13 +35,8 @@ !!$ !!$ subroutine psb_zumf_bld(a,desc_a,p,info) - use psb_serial_mod - use psb_descriptor_type + use psb_base_mod use psb_prec_type - use psb_tools_mod - use psb_const_mod - use psb_penv_mod - use psb_prec_mod, only: psb_as_matbld implicit none type(psb_zspmat_type), intent(inout) :: a @@ -58,6 +53,21 @@ subroutine psb_zumf_bld(a,desc_a,p,info) logical, parameter :: debug=.false. character(len=20) :: name, ch_err + interface psb_asmatbld + Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) + use psb_base_mod + use psb_prec_type + integer, intent(in) :: ptype,novr + Type(psb_zspmat_type), Intent(in) :: a + Type(psb_zspmat_type), Intent(inout) :: blk + Type(psb_desc_type), Intent(inout) :: desc_p + Type(psb_desc_type), Intent(in) :: desc_data + Character, Intent(in) :: upd + integer, intent(out) :: info + character(len=5), optional :: outfmt + end Subroutine psb_zasmatbld + end interface + info=0 name='psb_umf_bld' call psb_erractionsave(err_act) @@ -88,18 +98,18 @@ subroutine psb_zumf_bld(a,desc_a,p,info) write(0,*) me, 'UMFBLD: Done csdp',info,nza,atmp%m,atmp%k,nzb call psb_barrier(ictxt) endif - call psb_as_matbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& + call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& & blck,desc_a,upd,p%desc_data,info,outfmt=fmt) if(info /= 0) then info=4010 - ch_err='psb_as_matbld' + ch_err='psb_asmatbld' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if nzb = psb_sp_get_nnzeros(blck) if (Debug) then - write(0,*) me, 'UMFBLD: Done as_matbld',info,nzb,blck%fida + write(0,*) me, 'UMFBLD: Done asmatbld',info,nzb,blck%fida call psb_barrier(ictxt) endif if (nzb > 0 ) then diff --git a/mld2p4/psb_zumf_impl.c b/mld2p4/psb_zumf_impl.c index f8d7767b..22173d9e 100644 --- a/mld2p4/psb_zumf_impl.c +++ b/mld2p4/psb_zumf_impl.c @@ -34,9 +34,9 @@ * POSSIBILITY OF SUCH DAMAGE. * */ -/* This file is an interface to the UMFPACK routines for sparse - factorization. - +/* This file is an interface to the UMFPACK routines for + factorization. It was obtained by adapting umfpack_zi_demo + under the original copyright terms reproduced below. PSBLAS v 2.0 */ diff --git a/util/Makefile b/util/Makefile new file mode 100644 index 00000000..3c216b3a --- /dev/null +++ b/util/Makefile @@ -0,0 +1,33 @@ +include ../Make.inc + + +LIBDIR=../lib + +HERE=. + +BASEOBJS= psb_blockpart_mod.o psb_graphpart_mod.o \ + psb_hbio_mod.o psb_mmio_mod.o psb_mat_dist_mod.o \ + psb_read_mat_mod.o +MODOBJ=psb_util_mod.o +OBJS=$(BASEOBJS) $(MODOBJ) +LIBMOD=psb_util_mod$(.mod) +LOCAL_MODS=$(OBJS:.o=$(.mod)) +LIBNAME=$(UTILLIBNAME) +INCDIRS=-I. -I$(LIBDIR) + +lib: $(OBJS) + $(AR) $(HERE)/$(LIBNAME) $(OBJS) + $(RANLIB) $(HERE)/$(LIBNAME) + /bin/cp $(HERE)/$(LIBNAME) $(LIBDIR) + /bin/cp $(LIBMOD) $(LIBDIR) + + +psb_util_mod.o: $(BASEOBJ) + +veryclean: clean + /bin/rm -f $(HERE)/$(LIBNAME) + +clean: + /bin/rm -f $(OBJS) $(LOCAL_MODS) + +veryclean: clean diff --git a/util/psb_blockpart_mod.f90 b/util/psb_blockpart_mod.f90 new file mode 100644 index 00000000..cbf921c6 --- /dev/null +++ b/util/psb_blockpart_mod.f90 @@ -0,0 +1,73 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ 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. +!!$ +!!$ +! +! +module psb_blockpart_mod + public part_block, bld_partblock + +contains + subroutine part_block(global_indx,n,np,pv,nv) + + implicit none + + integer global_indx, n, np + integer nv + integer pv(*) + integer dim_block + integer ib1, ib2, ipv + + dim_block = (n + np - 1)/np + nv = 1 + pv(nv) = (global_indx - 1) / dim_block + + return + end subroutine part_block + + + + + subroutine bld_partblock(n,np,ivg) + integer n,np,ivg(*) + + integer dim_block,i + + + dim_block = (n + np - 1)/np + do i=1,n + ivg(i) = (i - 1) / dim_block + enddo + + end subroutine bld_partblock + + + +end module psb_blockpart_mod + diff --git a/util/psb_graphpart_mod.f90 b/util/psb_graphpart_mod.f90 new file mode 100644 index 00000000..e3793a18 --- /dev/null +++ b/util/psb_graphpart_mod.f90 @@ -0,0 +1,222 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ 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. +!!$ +!!$ +! +! Purpose: +! Provide a set of subroutines to define a data distribution based on +! a graph partitioning routine. +! +! Subroutines: +! +! BUILD_GRPPART(A,NPARTS): This subroutine will be called by the root +! process to build define the data distribuition mapping. +! Input parameters: +! TYPE(D_SPMAT) :: A The input matrix. The coefficients are +! ignored; only the structure is used. +! INTEGER :: NPARTS How many parts we are requiring to the +! partition utility +! +! DISTR_GRPPART(RROOT,CROOT,ICTXT): This subroutine will be called by +! all processes to distribute the information computed by the root +! process, to be used subsequently. +! +! +! PART_GRAPH : The subroutine to be passed to PSBLAS sparse library; +! uses information prepared by the previous two subroutines. +! +module psb_graphpart_mod + public part_graph, build_grppart, distr_grppart,& + & getv_grppart, build_usrpart, free_part + private + integer, allocatable, save :: graph_vect(:) + +contains + + subroutine part_graph(global_indx,n,np,pv,nv) + + integer, intent(in) :: global_indx, n, np + integer, intent(out) :: nv + integer, intent(out) :: pv(*) + + IF (.not.allocated(graph_vect)) then + write(0,*) 'Fatal error in PART_GRAPH: vector GRAPH_VECT ',& + & 'not initialized' + return + endif + if ((global_indx<1).or.(global_indx > size(graph_vect))) then + write(0,*) 'Fatal error in PART_GRAPH: index GLOBAL_INDX ',& + & 'outside GRAPH_VECT bounds',global_indx,size(graph_vect) + return + endif + nv = 1 + pv(nv) = graph_vect(global_indx) + return + end subroutine part_graph + + + subroutine distr_grppart(root, ictxt) + use psb_base_mod + integer :: root, ictxt + integer :: n, me, np + + call psb_info(ictxt,me,np) + + if (.not.((root>=0).and.(root1 then we have an overlap in the data + ! distribution. + ! + ! integer :: ictxt + ! on entry: blacs context. + ! on exit : unchanged. + ! + ! type (desc_type) :: desc_a + ! on entry: fresh variable. + ! on exit : the updated array descriptor + ! + ! real(kind(1.d0)), optional :: b_glob(:) + ! on entry: this contains right hand side. + ! on exit : + ! + ! real(kind(1.d0)), allocatable, optional :: b(:) + ! on entry: fresh variable. + ! on exit : this will contain the local right hand side. + ! + ! integer, optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + use psb_base_mod + implicit none + + ! parameters + type(psb_dspmat_type) :: a_glob + real(kind(1.d0)) :: b_glob(:) + integer :: ictxt + type(psb_dspmat_type) :: a + real(kind(1.d0)), allocatable :: b(:) + type (psb_desc_type) :: desc_a + integer, intent(out) :: info + integer, optional :: inroot + character(len=5), optional :: fmt + interface + + ! .....user passed subroutine..... + subroutine parts(global_indx,n,np,pv,nv) + implicit none + integer, intent(in) :: global_indx, n, np + integer, intent(out) :: nv + integer, intent(out) :: pv(*) + end subroutine parts + end interface + + ! local variables + integer :: np, iam + integer :: ircode, length_row, i_count, j_count,& + & k_count, blockdim, root, liwork, nrow, ncol, nnzero, nrhs,& + & i,j,k, ll, nz, isize, iproc, nnr, err, err_act, int_err(5) + integer, allocatable :: iwork(:) + character :: afmt*5, atyp*5 + integer, allocatable :: irow(:),icol(:) + real(kind(1.d0)), allocatable :: val(:) + integer, parameter :: nb=30 + real(kind(1.d0)) :: t0, t1, t2, t3, t4, t5 + logical, parameter :: newt=.true. + character(len=20) :: name, ch_err + + info = 0 + err = 0 + name = 'mat_distf' + call psb_erractionsave(err_act) + + ! executable statements + if (present(inroot)) then + root = inroot + else + root = 0 + end if + call psb_info(ictxt, iam, np) + + if (iam == root) then + ! extract information from a_glob + if (a_glob%fida.ne. 'CSR') then + info=135 + ch_err='CSR' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + nrow = a_glob%m + ncol = a_glob%k + if (nrow /= ncol) then + write(0,*) 'a rectangular matrix ? ',nrow,ncol + info=-1 + call psb_errpush(info,name) + goto 9999 + endif + nnzero = size(a_glob%aspk) + nrhs = 1 + ! broadcast informations to other processors + endif + call psb_bcast(ictxt, nrow,root) + call psb_bcast(ictxt, ncol,root) + call psb_bcast(ictxt, nnzero,root) + call psb_bcast(ictxt, nrhs,root) + + liwork = max(np, nrow + ncol) + allocate(iwork(liwork), stat = info) + if (info /= 0) then + info=2025 + int_err(1)=liwork + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + if (iam == root) then + write (*, fmt = *) 'start matdist',root, size(iwork),& + &nrow, ncol, nnzero,nrhs + endif + if (newt) then + call psb_cdall(nrow,nrow,parts,ictxt,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_cdall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_cdall(nrow,nrow,parts,ictxt,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_pscdall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + call psb_spall(a,desc_a,info,nnz=nnzero/np) + if(info/=0) then + info=4010 + ch_err='psb_psspall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geall(b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_psdsall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + isize = max(3*nb,ncol) + + + allocate(val(nb*ncol),irow(nb*ncol),icol(nb*ncol),stat=info) + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + i_count = 1 + + do while (i_count.le.nrow) + + call parts(i_count,nrow,np,iwork, length_row) + + if (length_row.eq.1) then + j_count = i_count + iproc = iwork(1) + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + call parts(j_count,nrow,np,iwork, length_row) + if (length_row /= 1 ) exit + if (iwork(1) /= iproc ) exit + end do + + ! now we should insert rows i_count..j_count-1 + nnr = j_count - i_count + + if (iam == root) then + + ll = 0 + do i= i_count, j_count-1 + call psb_sp_getrow(i,a_glob,nz,& + & irow(ll+1:),icol(ll+1:),val(ll+1:), info) + if (info /= 0) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(0,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + if (iproc == iam) then + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_spins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(nnr,(/(i,i=i_count,j_count-1)/),& + & b_glob(i_count:j_count-1),b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_ins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,nnr,iproc) + call psb_snd(ictxt,ll,iproc) + call psb_snd(ictxt,irow(1:ll),iproc) + call psb_snd(ictxt,icol(1:ll),iproc) + call psb_snd(ictxt,val(1:ll),iproc) + call psb_snd(ictxt,b_glob(i_count:j_count-1),iproc) + call psb_rcv(ictxt,ll,iproc) + endif + else if (iam /= root) then + + if (iproc == iam) then + call psb_rcv(ictxt,nnr,root) + call psb_rcv(ictxt,ll,root) + if (ll > size(irow)) then + write(0,*) iam,'need to reallocate ',ll + deallocate(val,irow,icol) + allocate(val(ll),irow(ll),icol(ll),stat=info) + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + endif + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_rcv(ictxt,b_glob(i_count:i_count+nnr-1),root) + call psb_snd(ictxt,ll,root) + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(nnr,(/(i,i=i_count,i_count+nnr-1)/),& + & b_glob(i_count:i_count+nnr-1),b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + endif + + i_count = j_count + + else + write(0,*) iam,'unexpected turn' + ! here processors are counted 1..np + do j_count = 1, length_row + k_count = iwork(j_count) + if (iam == root) then + + ll = 0 + do i= i_count, i_count + call psb_sp_getrow(i,a_glob,nz,& + & irow(ll+1:),icol(ll+1:),val(ll+1:), info) + if (info /= 0) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(0,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + if (k_count == iam) then + + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,ll,k_count) + call psb_snd(ictxt,irow(1:ll),k_count) + call psb_snd(ictxt,icol(1:ll),k_count) + call psb_snd(ictxt,val(1:ll),k_count) + call psb_snd(ictxt,b_glob(i_count),k_count) + call psb_rcv(ictxt,ll,k_count) + endif + else if (iam /= root) then + if (k_count == iam) then + + call psb_rcv(ictxt,ll,root) + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_rcv(ictxt,b_glob(i_count),root) + call psb_snd(ictxt,ll,root) + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + endif + end do + i_count = i_count + 1 + endif + end do + + if (present(fmt)) then + afmt=fmt + else + afmt = 'CSR' + endif + if (newt) then + + call psb_barrier(ictxt) + t0 = psb_wtime() + call psb_cdasb(desc_a,info) + t1 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_cdasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + t3 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_spasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + if (iam == root) then + write(*,*) 'descriptor assembly: ',t1-t0 + write(*,*) 'sparse matrix assembly: ',t3-t2 + end if + + + else + call psb_spasb(a,desc_a,info,afmt=afmt,dupl=psb_dupl_err_) + if(info/=0)then + info=4010 + ch_err='psspasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + + + call psb_geasb(b,desc_a,info) + if(info/=0)then + info=4010 + ch_err='psdsasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + deallocate(val,irow,icol,stat=info) + if(info/=0)then + info=4010 + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + deallocate(iwork) + if (iam == root) write (*, fmt = *) 'end matdist' + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.act_abort) then + call psb_error(ictxt) + return + end if + return + + end subroutine dmatdistf + + + subroutine dmatdistv (a_glob, a, v, ictxt, desc_a,& + & b_glob, b, info, inroot,fmt) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(d_spmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! a%fida =='csr' + ! a%aspk for coefficient values + ! a%ia1 for column indices + ! a%ia2 for row pointers + ! a%m for number of global matrix rows + ! a%k for number of global matrix columns + ! on exit : undefined, with unassociated pointers. + ! + ! type(d_spmat) :: a + ! on entry: fresh variable. + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer, intent(in) :: global_indx, n, np + ! integer, intent(out) :: nv + ! integer, intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer :: ictxt + ! on entry: blacs context. + ! on exit : unchanged. + ! + ! type (desc_type) :: desc_a + ! on entry: fresh variable. + ! on exit : the updated array descriptor + ! + ! real(kind(1.d0)), optional :: b_glob(:) + ! on entry: this contains right hand side. + ! on exit : + ! + ! real(kind(1.d0)), allocatable, optional :: b(:) + ! on entry: fresh variable. + ! on exit : this will contain the local right hand side. + ! + ! integer, optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + use psb_base_mod + implicit none ! parameters + type(psb_dspmat_type) :: a_glob + real(kind(1.d0)) :: b_glob(:) + integer :: ictxt, v(:) + type(psb_dspmat_type) :: a + real(kind(1.d0)), allocatable :: b(:) + type (psb_desc_type) :: desc_a + integer, intent(out) :: info + integer, optional :: inroot + character(len=5), optional :: fmt + + integer :: np, iam + integer :: ircode, length_row, i_count, j_count,& + & k_count, blockdim, root, liwork, nrow, ncol, nnzero, nrhs,& + & i,j,k, ll, nz, isize, iproc, nnr, err, err_act, int_err(5) + integer, allocatable :: iwork(:) + character :: afmt*5, atyp*5 + integer, allocatable :: irow(:),icol(:) + real(kind(1.d0)), allocatable :: val(:) + integer, parameter :: nb=30 + logical, parameter :: newt=.true. + real(kind(1.d0)) :: t0, t1, t2, t3, t4, t5 + character(len=20) :: name, ch_err + + info = 0 + err = 0 + name = 'mat_distv' + call psb_erractionsave(err_act) + + ! executable statements + if (present(inroot)) then + root = inroot + else + root = 0 + end if + + call psb_info(ictxt, iam, np) + if (iam == root) then + ! extract information from a_glob + if (a_glob%fida.ne. 'CSR') then + info=135 + ch_err='CSR' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + + nrow = a_glob%m + ncol = a_glob%k + if (nrow /= ncol) then + write(0,*) 'a rectangular matrix ? ',nrow,ncol + info=-1 + call psb_errpush(info,name) + goto 9999 + endif + + nnzero = size(a_glob%aspk) + nrhs = 1 + end if + ! broadcast informations to other processors + call psb_bcast(ictxt,nrow, root) + call psb_bcast(ictxt,ncol, root) + call psb_bcast(ictxt,nnzero, root) + call psb_bcast(ictxt,nrhs, root) + liwork = max(np, nrow + ncol) + allocate(iwork(liwork), stat = info) + if (info /= 0) then + write(0,*) 'matdist allocation failed' + info=2025 + int_err(1)=liwork + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + call psb_cdall(nrow,v,ictxt,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_cdall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_spall(a,desc_a,info,nnz=((nnzero+np-1)/np)) + if(info/=0) then + info=4010 + ch_err='psb_psspall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geall(b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_psdsall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + isize = max(3*nb,ncol) + + + allocate(val(nb*ncol),irow(nb*ncol),icol(nb*ncol),stat=info) + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + i_count = 1 + + do while (i_count <= nrow) + + j_count = i_count + iproc = v(i_count) + + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + if (v(j_count) /= iproc ) exit + end do + + ! now we should insert rows i_count..j_count-1 + nnr = j_count - i_count + + if (iam == root) then + + ll = 0 + do i= i_count, j_count-1 + call psb_sp_getrow(i,a_glob,nz,& + & irow(ll+1:),icol(ll+1:),val(ll+1:), info) + if (info /= 0) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(0,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + if (iproc == iam) then + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_spins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_geins(nnr,(/(i,i=i_count,j_count-1)/),b_glob(i_count:j_count-1),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='dsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,nnr,iproc) + call psb_snd(ictxt,ll,iproc) + call psb_snd(ictxt,irow(1:ll),iproc) + call psb_snd(ictxt,icol(1:ll),iproc) + call psb_snd(ictxt,val(1:ll),iproc) + call psb_snd(ictxt,b_glob(i_count:j_count-1),iproc) + call psb_rcv(ictxt,ll,iproc) + endif + else if (iam /= root) then + + if (iproc == iam) then + call psb_rcv(ictxt,nnr,root) + call psb_rcv(ictxt,ll,root) + if (ll > size(val)) then + write(0,*) iam,'need to reallocate ',ll + deallocate(val,irow,icol) + allocate(val(ll),irow(ll),icol(ll),stat=info) + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_rcv(ictxt,b_glob(i_count:i_count+nnr-1),root) + call psb_snd(ictxt,ll,root) + + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='spins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(nnr,(/(i,i=i_count,i_count+nnr-1)/),& + & b_glob(i_count:i_count+nnr-1),b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + endif + i_count = j_count + + end do + + ! default storage format for sparse matrix; we do not + ! expect duplicated entries. + + if (present(fmt)) then + afmt=fmt + else + afmt = 'CSR' + endif + call psb_barrier(ictxt) + t0 = psb_wtime() + call psb_cdasb(desc_a,info) + t1 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_cdasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + t3 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_spasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_geasb(b,desc_a,info) + + if (iam == root) then + write(*,'("Descriptor assembly : ",es10.4)')t1-t0 + write(*,'("Sparse matrix assembly: ",es10.4)')t3-t2 + end if + + if(info/=0)then + info=4010 + ch_err='psdsasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + deallocate(iwork) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.act_abort) then + call psb_error(ictxt) + return + end if + return + + end subroutine dmatdistv + + + subroutine zmatdistf (a_glob, a, parts, ictxt, desc_a,& + & b_glob, b, info, inroot,fmt) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(d_spmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! a%fida =='csr' + ! a%aspk for coefficient values + ! a%ia1 for column indices + ! a%ia2 for row pointers + ! a%m for number of global matrix rows + ! a%k for number of global matrix columns + ! on exit : undefined, with unassociated pointers. + ! + ! type(d_spmat) :: a + ! on entry: fresh variable. + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer, intent(in) :: global_indx, n, np + ! integer, intent(out) :: nv + ! integer, intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer :: ictxt + ! on entry: blacs context. + ! on exit : unchanged. + ! + ! type (desc_type) :: desc_a + ! on entry: fresh variable. + ! on exit : the updated array descriptor + ! + ! real(kind(1.d0)), optional :: b_glob(:) + ! on entry: this contains right hand side. + ! on exit : + ! + ! real(kind(1.d0)), allocatable, optional :: b(:) + ! on entry: fresh variable. + ! on exit : this will contain the local right hand side. + ! + ! integer, optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + use psb_base_mod + implicit none + + ! parameters + type(psb_zspmat_type) :: a_glob + complex(kind(1.d0)) :: b_glob(:) + integer :: ictxt + type(psb_zspmat_type) :: a + complex(kind(1.d0)), allocatable :: b(:) + type (psb_desc_type) :: desc_a + integer, intent(out) :: info + integer, optional :: inroot + character(len=5), optional :: fmt + interface + + ! .....user passed subroutine..... + subroutine parts(global_indx,n,np,pv,nv) + implicit none + integer, intent(in) :: global_indx, n, np + integer, intent(out) :: nv + integer, intent(out) :: pv(*) + end subroutine parts + end interface + + ! local variables + integer :: np, iam + integer :: ircode, length_row, i_count, j_count,& + & k_count, blockdim, root, liwork, nrow, ncol, nnzero, nrhs,& + & i,j,k, ll, nz, isize, iproc, nnr, err, err_act, int_err(5) + integer, allocatable :: iwork(:) + character :: afmt*5, atyp*5 + integer, allocatable :: irow(:),icol(:) + complex(kind(1.d0)), allocatable :: val(:) + integer, parameter :: nb=30 + real(kind(1.d0)) :: t0, t1, t2, t3, t4, t5 + logical, parameter :: newt=.true. + character(len=20) :: name, ch_err + + info = 0 + err = 0 + name = 'mat_distf' + call psb_erractionsave(err_act) + + ! executable statements + if (present(inroot)) then + root = inroot + else + root = 0 + end if + call psb_info(ictxt, iam, np) + if (iam == root) then + ! extract information from a_glob + if (a_glob%fida.ne. 'CSR') then + info=135 + ch_err='CSR' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + nrow = a_glob%m + ncol = a_glob%k + if (nrow /= ncol) then + write(0,*) 'a rectangular matrix ? ',nrow,ncol + info=-1 + call psb_errpush(info,name) + goto 9999 + endif + nnzero = size(a_glob%aspk) + nrhs = 1 + endif + ! broadcast informations to other processors + call psb_bcast(ictxt,nrow, root) + call psb_bcast(ictxt,ncol, root) + call psb_bcast(ictxt,nnzero, root) + call psb_bcast(ictxt,nrhs, root) + liwork = max(np, nrow + ncol) + allocate(iwork(liwork), stat = info) + if (info /= 0) then + info=2025 + int_err(1)=liwork + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + if (iam == root) then + write (*, fmt = *) 'start matdist',root, size(iwork),& + &nrow, ncol, nnzero,nrhs + endif + if (newt) then + call psb_cdall(nrow,nrow,parts,ictxt,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_cdall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_cdall(nrow,nrow,parts,ictxt,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_pscdall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + call psb_spall(a,desc_a,info,nnz=nnzero/np) + if(info/=0) then + info=4010 + ch_err='psb_psspall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geall(b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_psdsall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + isize = max(3*nb,ncol) + + + allocate(val(nb*ncol),irow(nb*ncol),icol(nb*ncol),stat=info) + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + i_count = 1 + + do while (i_count.le.nrow) + + call parts(i_count,nrow,np,iwork, length_row) + + if (length_row.eq.1) then + j_count = i_count + iproc = iwork(1) + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + call parts(j_count,nrow,np,iwork, length_row) + if (length_row /= 1 ) exit + if (iwork(1) /= iproc ) exit + end do + + ! now we should insert rows i_count..j_count-1 + nnr = j_count - i_count + + if (iam == root) then + + ll = 0 + do i= i_count, j_count-1 + call psb_sp_getrow(i,a_glob,nz,& + & irow(ll+1:),icol(ll+1:),val(ll+1:), info) + if (info /= 0) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(0,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + if (iproc == iam) then + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_spins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(nnr,(/(i,i=i_count,j_count-1)/),b_glob(i_count:j_count-1),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_ins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,nnr,iproc) + call psb_snd(ictxt,ll,iproc) + call psb_snd(ictxt,irow(1:ll),iproc) + call psb_snd(ictxt,icol(1:ll),iproc) + call psb_snd(ictxt,val(1:ll),iproc) + call psb_snd(ictxt,b_glob(i_count:j_count-1),iproc) + call psb_rcv(ictxt,ll,iproc) + endif + else if (iam /= root) then + + if (iproc == iam) then + call psb_rcv(ictxt,nnr,root) + call psb_rcv(ictxt,ll,root) + if (ll > size(irow)) then + write(0,*) iam,'need to reallocate ',ll + deallocate(val,irow,icol) + allocate(val(ll),irow(ll),icol(ll),stat=info) + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + endif + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_rcv(ictxt,b_glob(i_count:i_count+nnr-1),root) + call psb_snd(ictxt,ll,root) + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(nnr,(/(i,i=i_count,i_count+nnr-1)/),& + & b_glob(i_count:i_count+nnr-1),b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + endif + + i_count = j_count + + else + write(0,*) iam,'unexpected turn' + ! here processors are counted 1..np + do j_count = 1, length_row + k_count = iwork(j_count) + if (iam == root) then + + ll = 0 + do i= i_count, i_count + call psb_sp_getrow(i,a_glob,nz,& + & irow(ll+1:),icol(ll+1:),val(ll+1:), info) + if (info /= 0) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(0,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + if (k_count == iam) then + + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,ll,k_count) + call psb_snd(ictxt,irow(1:ll),k_count) + call psb_snd(ictxt,icol(1:ll),k_count) + call psb_snd(ictxt,val(1:ll),k_count) + call psb_snd(ictxt,b_glob(i_count),k_count) + call psb_rcv(ictxt,ll,k_count) + endif + else if (iam /= root) then + if (k_count == iam) then + call psb_rcv(ictxt,ll,root) + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_rcv(ictxt,b_glob(i_count),root) + call psb_snd(ictxt,ll,root) + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + endif + end do + i_count = i_count + 1 + endif + end do + + if (present(fmt)) then + afmt=fmt + else + afmt = 'CSR' + endif + if (newt) then + + call psb_barrier(ictxt) + t0 = psb_wtime() + call psb_cdasb(desc_a,info) + t1 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_cdasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + t3 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_spasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + if (iam == root) then + write(*,*) 'descriptor assembly: ',t1-t0 + write(*,*) 'sparse matrix assembly: ',t3-t2 + end if + + + else + call psb_spasb(a,desc_a,info,afmt=afmt,dupl=psb_dupl_err_) + if(info/=0)then + info=4010 + ch_err='psspasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + + + call psb_geasb(b,desc_a,info) + if(info/=0)then + info=4010 + ch_err='psdsasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + deallocate(val,irow,icol,stat=info) + if(info/=0)then + info=4010 + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + deallocate(iwork) + if (iam == root) write (*, fmt = *) 'end matdist' + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.act_abort) then + call psb_error(ictxt) + return + end if + return + + end subroutine zmatdistf + + + subroutine zmatdistv (a_glob, a, v, ictxt, desc_a,& + & b_glob, b, info, inroot,fmt) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(d_spmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! a%fida =='csr' + ! a%aspk for coefficient values + ! a%ia1 for column indices + ! a%ia2 for row pointers + ! a%m for number of global matrix rows + ! a%k for number of global matrix columns + ! on exit : undefined, with unassociated pointers. + ! + ! type(d_spmat) :: a + ! on entry: fresh variable. + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer, intent(in) :: global_indx, n, np + ! integer, intent(out) :: nv + ! integer, intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer :: ictxt + ! on entry: blacs context. + ! on exit : unchanged. + ! + ! type (desc_type) :: desc_a + ! on entry: fresh variable. + ! on exit : the updated array descriptor + ! + ! real(kind(1.d0)), optional :: b_glob(:) + ! on entry: this contains right hand side. + ! on exit : + ! + ! real(kind(1.d0)), allocatable, optional :: b(:) + ! on entry: fresh variable. + ! on exit : this will contain the local right hand side. + ! + ! integer, optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + use psb_base_mod + implicit none ! parameters + type(psb_zspmat_type) :: a_glob + complex(kind(1.d0)) :: b_glob(:) + integer :: ictxt, v(:) + type(psb_zspmat_type) :: a + complex(kind(1.d0)), allocatable :: b(:) + type(psb_desc_type) :: desc_a + integer, intent(out) :: info + integer, optional :: inroot + character(len=5), optional :: fmt + + integer :: np, iam + integer :: ircode, length_row, i_count, j_count,& + & k_count, blockdim, root, liwork, nrow, ncol, nnzero, nrhs,& + & i,j,k, ll, nz, isize, iproc, nnr, err, err_act, int_err(5) + integer, allocatable :: iwork(:) + character :: afmt*5, atyp*5 + integer, allocatable :: irow(:),icol(:) + complex(kind(1.d0)), allocatable :: val(:) + integer, parameter :: nb=30 + logical, parameter :: newt=.true. + real(kind(1.d0)) :: t0, t1, t2, t3, t4, t5 + character(len=20) :: name, ch_err + + info = 0 + err = 0 + name = 'mat_distv' + call psb_erractionsave(err_act) + + ! executable statements + if (present(inroot)) then + root = inroot + else + root = 0 + end if + + call psb_info(ictxt, iam, np) + if (iam == root) then + ! extract information from a_glob + if (toupper(a_glob%fida) /= 'CSR') then + info=135 + ch_err='CSR' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + + nrow = a_glob%m + ncol = a_glob%k + if (nrow /= ncol) then + write(0,*) 'a rectangular matrix ? ',nrow,ncol + info=-1 + call psb_errpush(info,name) + goto 9999 + endif + + nnzero = size(a_glob%aspk) + nrhs = 1 + end if + ! broadcast informations to other processors + call psb_bcast(ictxt,nrow, root) + call psb_bcast(ictxt,ncol, root) + call psb_bcast(ictxt,nnzero, root) + call psb_bcast(ictxt,nrhs, root) + liwork = max(np, nrow + ncol) + allocate(iwork(liwork), stat = info) + if (info /= 0) then + write(0,*) 'matdist allocation failed' + info=2025 + int_err(1)=liwork + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + call psb_cdall(nrow,v,ictxt,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_cdall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_spall(a,desc_a,info,nnz=((nnzero+np-1)/np)) + if(info/=0) then + info=4010 + ch_err='psb_psspall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geall(b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_psdsall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + isize = max(3*nb,ncol) + + + allocate(val(nb*ncol),irow(nb*ncol),icol(nb*ncol),stat=info) + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + i_count = 1 + + do while (i_count <= nrow) + + j_count = i_count + iproc = v(i_count) + + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + if (v(j_count) /= iproc ) exit + end do + + ! now we should insert rows i_count..j_count-1 + nnr = j_count - i_count + + if (iam == root) then + ll = 0 + do i= i_count, j_count-1 + call psb_sp_getrow(i,a_glob,nz,& + & irow(ll+1:),icol(ll+1:),val(ll+1:), info) + if (info /= 0) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(0,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + if (iproc == iam) then + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_spins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_geins(nnr,(/(i,i=i_count,j_count-1)/),b_glob(i_count:j_count-1),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='dsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,nnr,iproc) + call psb_snd(ictxt,ll,iproc) + call psb_snd(ictxt,irow(1:ll),iproc) + call psb_snd(ictxt,icol(1:ll),iproc) + call psb_snd(ictxt,val(1:ll),iproc) + call psb_snd(ictxt,b_glob(i_count:j_count-1),iproc) + call psb_rcv(ictxt,ll,iproc) + endif + else if (iam /= root) then + + if (iproc == iam) then + call psb_rcv(ictxt,nnr,root) + call psb_rcv(ictxt,ll,root) + if (ll > size(val)) then + write(0,*) iam,'need to reallocate ',ll + deallocate(val,irow,icol) + allocate(val(ll),irow(ll),icol(ll),stat=info) + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_rcv(ictxt,b_glob(i_count:i_count+nnr-1),root) + call psb_snd(ictxt,ll,root) + + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='spins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(nnr,(/(i,i=i_count,i_count+nnr-1)/),& + & b_glob(i_count:i_count+nnr-1),b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + endif + i_count = j_count + + end do + + ! default storage format for sparse matrix; we do not + ! expect duplicated entries. + + if (present(fmt)) then + afmt=fmt + else + afmt = 'CSR' + endif + call psb_barrier(ictxt) + t0 = psb_wtime() + call psb_cdasb(desc_a,info) + t1 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_cdasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + t3 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_spasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_geasb(b,desc_a,info) + + if (iam == root) then + write(*,'("Descriptor assembly : ",es10.4)')t1-t0 + write(*,'("Sparse matrix assembly: ",es10.4)')t3-t2 + end if + + if(info/=0)then + info=4010 + ch_err='psdsasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + deallocate(iwork) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.act_abort) then + call psb_error(ictxt) + return + end if + return + + end subroutine zmatdistv + +end module psb_mat_dist_mod diff --git a/util/psb_mmio_mod.f90 b/util/psb_mmio_mod.f90 new file mode 100644 index 00000000..9ab55ece --- /dev/null +++ b/util/psb_mmio_mod.f90 @@ -0,0 +1,379 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ 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. +!!$ +!!$ +module psb_mmio_mod + use psb_base_mod + public mm_mat_read, mm_mat_write + interface mm_mat_read + module procedure dmm_mat_read, zmm_mat_read + end interface + interface mm_mat_write + module procedure dmm_mat_write,zmm_mat_write + end interface + +contains + + subroutine dmm_mat_read(a, iret, iunit, filename) + use psb_base_mod + implicit none + type(psb_dspmat_type), intent(out) :: a + integer, intent(out) :: iret + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character :: mmheader*15, fmt*15, object*10, type*10, sym*15 + character(1024) :: line + integer :: nrow, ncol, nnzero, neltvl, nrhs, nrhsix + integer :: ircode, i,iel,nzr,infile, j + logical, parameter :: debug=.false. + + iret = 0 + + if (present(filename)) then + if (filename=='-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read(infile,fmt=*,end=902) mmheader, object, fmt, type, sym + + if ( (tolower(object) /= 'matrix').or.(tolower(fmt)/='coordinate')) then + write(0,*) 'READ_MATRIX: input file type not yet supported' + iret=909 + return + end if + if (debug) write(*,*) mmheader,':', object, ':',fmt,':', type,':', sym + + do + read(infile,fmt='(a)') line + if (line(1:1) /= '%') exit + end do + if (debug) write(*,*) 'Line on input : "',line,'"' + read(line,fmt=*) nrow,ncol,nnzero + if (debug) write(*,*) 'Out: ',nrow,ncol,nnzero + + if ((tolower(type) == 'real').and.(tolower(sym) == 'general')) then + call psb_sp_all(nrow,ncol,a,nnzero,ircode) + a%fida = 'COO' + a%descra = 'G' + if (ircode /= 0) goto 993 + do i=1,nnzero + read(infile,fmt=*,end=902) a%ia1(i),a%ia2(i),a%aspk(i) + end do + a%infoa(psb_nnz_) = nnzero + call psb_ipcoo2csr(a,ircode) + + else if ((tolower(type) == 'real').and.(tolower(sym) == 'symmetric')) then + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + call psb_sp_all(nrow,ncol,a,2*nnzero,ircode) + a%fida = 'COO' + a%descra = 'G' + if (ircode /= 0) goto 993 + do i=1,nnzero + read(infile,fmt=*,end=902) a%ia1(i),a%ia2(i),a%aspk(i) + end do + + nzr = nnzero + do i=1,nnzero + if (a%ia1(i) /= a%ia2(i)) then + nzr = nzr + 1 + a%aspk(nzr) = a%aspk(i) + a%ia1(nzr) = a%ia2(i) + a%ia2(nzr) = a%ia1(i) + end if + end do + a%infoa(psb_nnz_) = nzr + call psb_ipcoo2csr(a,ircode) + + else + write(0,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + if (infile/=5) close(infile) + return + + ! open failed +901 iret=901 + write(0,*) 'read_matrix: could not open file ',filename,' for input' + return +902 iret=902 + write(0,*) 'READ_MATRIX: Unexpected end of file ' + return +993 iret=993 + write(0,*) 'READ_MATRIX: Memory allocation failure' + return + end subroutine dmm_mat_read + + + + + + subroutine dmm_mat_write(a,mtitle,iret,eiout,filename) + use psb_base_mod + implicit none + type(psb_dspmat_type), intent(in) :: a + integer, intent(out) :: iret + character(len=*), intent(in) :: mtitle + integer, optional, intent(in) :: eiout + character(len=*), optional, intent(in) :: filename + integer :: iout + + + iret = 0 + + if (present(filename)) then + if (filename=='-') then + iout=6 + else + if (present(eiout)) then + iout = eiout + else + iout=99 + endif + open(iout,file=filename, err=901, action='WRITE') + endif + else + if (present(eiout)) then + iout = eiout + else + iout=6 + endif + endif + + call psb_csprt(iout,a,head=mtitle) + + if (iout /= 6) close(iout) + + + return + +901 continue + iret=901 + write(0,*) 'Error while opening ',filename + return + end subroutine dmm_mat_write + + + + subroutine zmm_mat_read(a, iret, iunit, filename) + use psb_base_mod + implicit none + type(psb_zspmat_type), intent(out) :: a + integer, intent(out) :: iret + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character :: mmheader*15, fmt*15, object*10, type*10, sym*15 + character(1024) :: line + integer :: nrow, ncol, nnzero, neltvl, nrhs, nrhsix + integer :: ircode, i,iel,nzr,infile,j + real(kind(1.d0)) :: are, aim + logical, parameter :: debug=.false. + + + iret = 0 + + if (present(filename)) then + if (filename=='-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read(infile,fmt=*,end=902) mmheader, object, fmt, type, sym + + if ( (tolower(object) /= 'matrix').or.(tolower(fmt)/='coordinate')) then + write(0,*) 'READ_MATRIX: input file type not yet supported' + iret=909 + return + end if + if (debug) write(*,*) mmheader,':', object, ':',fmt,':', type,':', sym + + do + read(infile,fmt='(a)') line + if (line(1:1) /= '%') exit + end do + if (debug) write(*,*) 'Line on input : "',line,'"' + read(line,fmt=*) nrow,ncol,nnzero + if (debug) write(*,*) 'Out: ',nrow,ncol,nnzero + + if ((tolower(type) == 'complex').and.(tolower(sym) == 'general')) then + call psb_sp_all(nrow,ncol,a,nnzero,ircode) + if (ircode /= 0) goto 993 + a%fida = 'COO' + a%descra = 'G' + do i=1,nnzero + read(infile,fmt=*,end=902) a%ia1(i),a%ia2(i),are,aim + a%aspk(i) = cmplx(are,aim) + end do + a%infoa(psb_nnz_) = nnzero + + call psb_ipcoo2csr(a,ircode) + + else if ((tolower(type) == 'complex').and.(tolower(sym) == 'symmetric')) then + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + call psb_sp_all(nrow,ncol,a,2*nnzero,ircode) + if (ircode /= 0) goto 993 + a%fida = 'COO' + a%descra = 'G' + do i=1,nnzero + read(infile,fmt=*,end=902) a%ia1(i),a%ia2(i),are,aim + a%aspk(i) = cmplx(are,aim) + end do + + nzr = nnzero + do i=1,nnzero + if (a%ia1(i) /= a%ia2(i)) then + nzr = nzr + 1 + a%aspk(nzr) = a%aspk(i) + a%ia1(nzr) = a%ia2(i) + a%ia2(nzr) = a%ia1(i) + end if + end do + a%infoa(psb_nnz_) = nzr + call psb_ipcoo2csr(a,ircode) + + else if ((tolower(type) == 'complex').and.(tolower(sym) == 'hermitian')) then + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + call psb_sp_all(nrow,ncol,a,2*nnzero,ircode) + if (ircode /= 0) goto 993 + a%fida = 'COO' + a%descra = 'G' + do i=1,nnzero + read(infile,fmt=*,end=902) a%ia1(i),a%ia2(i),are,aim + a%aspk(i) = cmplx(are,aim) + end do + + nzr = nnzero + do i=1,nnzero + if (a%ia1(i) /= a%ia2(i)) then + nzr = nzr + 1 + a%aspk(nzr) = conjg(a%aspk(i)) + a%ia1(nzr) = a%ia2(i) + a%ia2(nzr) = a%ia1(i) + end if + end do + a%infoa(psb_nnz_) = nzr + call psb_ipcoo2csr(a,ircode) + + else + write(0,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + if (infile/=5) close(infile) + return + + ! open failed +901 iret=901 + write(0,*) 'read_matrix: could not open file ',filename,' for input' + return +902 iret=902 + write(0,*) 'READ_MATRIX: Unexpected end of file ' + return +993 iret=993 + write(0,*) 'READ_MATRIX: Memory allocation failure' + return + end subroutine zmm_mat_read + + + + subroutine zmm_mat_write(a,mtitle,iret,eiout,filename) + use psb_base_mod + implicit none + type(psb_zspmat_type), intent(in) :: a + integer, intent(out) :: iret + character(len=*), intent(in) :: mtitle + integer, optional, intent(in) :: eiout + character(len=*), optional, intent(in) :: filename + integer :: iout + + + iret = 0 + + if (present(filename)) then + if (filename=='-') then + iout=6 + else + if (present(eiout)) then + iout = eiout + else + iout=99 + endif + open(iout,file=filename, err=901, action='WRITE') + endif + else + if (present(eiout)) then + iout = eiout + else + iout=6 + endif + endif + + call psb_csprt(iout,a,head=mtitle) + + if (iout /= 6) close(iout) + + + return + +901 continue + iret=901 + write(0,*) 'Error while opening ',filename + return + end subroutine zmm_mat_write + + +end module psb_mmio_mod diff --git a/util/psb_read_mat_mod.f90 b/util/psb_read_mat_mod.f90 new file mode 100644 index 00000000..4936467d --- /dev/null +++ b/util/psb_read_mat_mod.f90 @@ -0,0 +1,253 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ 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. +!!$ +!!$ +! +! READ_MAT subroutine reads a matrix and its right hand sides, +! all stored in Matrix Market format file. The B field is optional,. +! +! Character :: filename*20 +! On Entry: name of file to be processed. +! On Exit : unchanged. +! +! Type(D_SPMAT) :: A +! On Entry: fresh variable. +! On Exit : will contain the global sparse matrix as follows: +! A%AS for coefficient values +! A%IA1 for column indices +! A%IA2 for row pointers +! A%M for number of global matrix rows +! A%K for number of global matrix columns +! +! Integer :: ICTXT +! On Entry: BLACS context. +! On Exit : unchanged. +! +! Real(Kind(1.D0)), Pointer, Optional :: B(:,:) +! On Entry: fresh variable. +! On Exit: will contain right hand side(s). +! +! Integer, Optional :: inroot +! On Entry: Index of root processor (default: 0) +! On Exit : unchanged. +! +module psb_read_mat_mod + interface read_mat + module procedure dreadmat, zreadmat + end interface + interface read_rhs + module procedure dread_rhs, zread_rhs + end interface + + +contains + + subroutine dreadmat (filename, a, ictxt, inroot) + use psb_base_mod + use psb_mmio_mod + implicit none + integer :: ictxt + type(psb_dspmat_type) :: a + character(len=*) :: filename + integer, optional :: inroot + integer, parameter :: infile = 2 + integer :: info, root, nprow, npcol, myprow, mypcol + + if (present(inroot)) then + root = inroot + else + root = 0 + end if + call psb_info(ictxt, myprow, nprow) + if (myprow == root) then + write(*, '("Reading matrix...")') ! open input file + call mm_mat_read(a,info,infile,filename) + if (info /= 0) then + write(0,*) 'Error return from MM_MAT_READ ',info + call psb_abort(ictxt) ! Unexpected End of File + endif + end if + return + + end subroutine dreadmat + + + subroutine dread_rhs (filename, b, ictxt, inroot) + use psb_base_mod + implicit none + integer :: ictxt + character :: filename*(*) + integer, optional :: inroot + integer, parameter :: infile = 2 + integer :: nrow, ncol, i,root, nprow, npcol, myprow, mypcol, ircode, j + character :: mmheader*15, fmt*15, object*10, type*10, sym*15,& + & line*1024 + real(kind(1.0d0)), allocatable :: b(:,:) + if (present(inroot)) then + root = inroot + else + root = 0 + end if + call psb_info(ictxt, myprow, nprow) + if (myprow == root) then + write(*, '("Reading rhs...")') ! open input file + open(infile,file=filename, status='old', err=901, action="read") + read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym + write(0,*)'obj fmt',object, fmt + if ( (object .ne. 'matrix').or.(fmt.ne.'array')) then + write(0,*) 'read_rhs: input file type not yet supported' + call psb_abort(ictxt) + end if + + do + read(infile,fmt='(a)') line + if (line(1:1) /= '%') exit + end do + + read(line,fmt=*)nrow,ncol + + if ((tolower(type) == 'real').and.(tolower(sym) == 'general')) then + allocate(b(nrow,ncol),stat = ircode) + if (ircode /= 0) goto 993 + read(infile,fmt=*,end=902) ((b(i,j), i=1,nrow),j=1,ncol) + + else + write(0,*) 'read_rhs: rhs type not yet supported' + call psb_abort(ictxt) + end if ! read right hand sides + write(*,*) 'end read_rhs' + end if + return + ! open failed +901 write(0,*) 'read_rhs: could not open file ',& + & infile,' for input' + call psb_abort(ictxt) ! unexpected end of file +902 write(0,*) 'read_rhs: unexpected end of file ',infile,& + & ' during input' + call psb_abort(ictxt) ! allocation failed +993 write(0,*) 'read_rhs: memory allocation failure' + call psb_abort(ictxt) + end subroutine dread_rhs + + + subroutine zreadmat (filename, a, ictxt, inroot) + use psb_base_mod + use psb_mmio_mod + implicit none + integer :: ictxt + type(psb_zspmat_type) :: a + character(len=*) :: filename + integer, optional :: inroot + integer, parameter :: infile = 2 + integer :: info, root, nprow, npcol, myprow, mypcol + + if (present(inroot)) then + root = inroot + else + root = 0 + end if + call psb_info(ictxt, myprow, nprow) + if (myprow == root) then + write(*, '("Reading matrix...")') ! open input file + call mm_mat_read(a,info,infile,filename) + if (info /= 0) then + write(0,*) 'Error return from MM_MAT_READ ',info + call psb_abort(ictxt) ! Unexpected End of File + endif + end if + return + + end subroutine zreadmat + + + subroutine zread_rhs (filename, b, ictxt, inroot) + use psb_base_mod + implicit none + integer :: ictxt + character :: filename*(*) + integer, optional :: inroot + integer, parameter :: infile = 2 + integer :: nrow, ncol, i,root, nprow, npcol, myprow, mypcol, ircode, j + character :: mmheader*15, fmt*15, object*10, type*10, sym*15,& + & line*1024 + real(kind(1.d0)) :: bre, bim + complex(kind(1.0d0)), allocatable :: b(:,:) + if (present(inroot)) then + root = inroot + else + root = 0 + end if + call psb_info(ictxt, myprow, nprow) + if (myprow == root) then + write(*, '("Reading rhs...")') ! open input file + open(infile,file=filename, status='old', err=901, action="read") + read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym +!!$ write(0,*)'obj fmt',object, fmt + if ( (object .ne. 'matrix').or.(fmt.ne.'array')) then + write(0,*) 'read_rhs: input file type not yet supported' + call psb_abort(ictxt) + end if + + do + read(infile,fmt='(a)') line + if (line(1:1) /= '%') exit + end do + + read(line,fmt=*)nrow,ncol + + if ((tolower(type) == 'complex').and.(tolower(sym) == 'general')) then + allocate(b(nrow,ncol),stat = ircode) + if (ircode /= 0) goto 993 + do j=1, ncol + do i=1, nrow + read(infile,fmt=*,end=902) bre,bim + b(i,j) = cmplx(bre,bim) + end do + end do + else + write(0,*) 'read_rhs: rhs type not yet supported' + call psb_abort(ictxt) + end if ! read right hand sides + write(*,*) 'end read_rhs' + end if + return + ! open failed +901 write(0,*) 'read_rhs: could not open file ',& + & infile,' for input' + call psb_abort(ictxt) ! unexpected end of file +902 write(0,*) 'read_rhs: unexpected end of file ',infile,& + & ' during input' + call psb_abort(ictxt) ! allocation failed +993 write(0,*) 'read_rhs: memory allocation failure' + call psb_abort(ictxt) + end subroutine zread_rhs + + + +end module psb_read_mat_mod diff --git a/base/modules/psb_all_mod.f90 b/util/psb_util_mod.f90 similarity index 84% rename from base/modules/psb_all_mod.f90 rename to util/psb_util_mod.f90 index 3313ae7a..ded09d8c 100644 --- a/base/modules/psb_all_mod.f90 +++ b/util/psb_util_mod.f90 @@ -28,21 +28,14 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -module psb_all_mod - ! the interface modules - use psb_tools_mod - use psb_const_mod - use psb_prec_mod - use psb_methd_mod - use psb_serial_mod - use psb_penv_mod - use psb_comm_mod - use psb_error_mod - use psb_psblas_mod +! +! +module psb_util_mod + use psb_blockpart_mod + use psb_graphpart_mod + use psb_hbio_mod + use psb_mmio_mod + use psb_read_mat_mod + use psb_mat_dist_mod +end module psb_util_mod - ! the types - use psb_spmat_type - use psb_descriptor_type - use psb_prec_type - -end module psb_all_mod