Initial import for new separate version of mld2p4.
Salvatore Filippone
18 years ago
parent
a63ad6e568
commit
db5c62e5c9
@ -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.
|
||||
|
||||
@ -0,0 +1,86 @@
|
||||
.mod=.mod
|
||||
.fh=.fh
|
||||
.SUFFIXES: .f90 $(.mod) .F90
|
||||
|
||||
|
||||
####################### Section 1 #######################
|
||||
# Define your compilers and compiler flags here #
|
||||
##########################################################
|
||||
F90=/usr/local/gcc42/bin/gfortran
|
||||
FC=/usr/local/gcc42/bin/gfortran
|
||||
F77=$(FC)
|
||||
CC=/usr/local/gcc42/bin/gcc
|
||||
F90COPT=-O3 -ggdb
|
||||
FCOPT=-O3 -ggdb
|
||||
CCOPT=-O3 -ggdb
|
||||
|
||||
####################### Section 2 #######################
|
||||
# Define your linker and linker flags here #
|
||||
##########################################################
|
||||
F90LINK=/usr/local/mpich-gcc42/bin/mpif90
|
||||
FLINK=/usr/local/mpich-gcc42/bin/mpif77
|
||||
MPF90=/usr/local/mpich-gcc42/bin/mpif90
|
||||
MPF77=/usr/local/mpich-gcc42/bin/mpif77
|
||||
MPCC=/usr/local/mpich-gcc42/bin/mpicc
|
||||
|
||||
####################### Section 3 #######################
|
||||
# Specify paths to libraries #
|
||||
##########################################################
|
||||
BLAS=-lblas-gcc42 -L$(HOME)/LIB
|
||||
BLACS=-lmpiblacs-gcc42 -L$(HOME)/LIB
|
||||
|
||||
|
||||
####################### Section 4 #######################
|
||||
# Other useful tools&defines #
|
||||
##########################################################
|
||||
SLUDIR=/usr/local/SuperLU_3.0
|
||||
SLU=-lslu_lx_gcc42 -L$(SLUDIR)
|
||||
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)
|
||||
FDEFINES=-DNETLIB_BLACS -DHAVE_MOVE_ALLOC
|
||||
|
||||
AR=ar -cur
|
||||
RANLIB=ranlib
|
||||
|
||||
|
||||
|
||||
####################### Section 5 #######################
|
||||
# Do not edit this #
|
||||
##########################################################
|
||||
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:
|
||||
|
||||
.f.o:
|
||||
$(FC) $(FCOPT) $(INCDIRS) -c $<
|
||||
.c.o:
|
||||
$(CC) $(CCOPT) $(INCDIRS) $(CDEFINES) -c $<
|
||||
.f$(.mod):
|
||||
$(F90) $(FCOPT) $(INCDIRS) -c $<
|
||||
.f90$(.mod):
|
||||
$(F90) $(F90COPT) $(INCDIRS) -c $<
|
||||
.f90.o:
|
||||
$(F90) $(F90COPT) $(INCDIRS) -c $<
|
||||
.F90.o:
|
||||
$(F90) $(F90COPT) $(INCDIRS) $(FDEFINES) -c $<
|
||||
|
||||
|
||||
|
||||
|
||||
@ -0,0 +1,85 @@
|
||||
.mod=.mod
|
||||
.fh=.fh
|
||||
.SUFFIXES: .f90 $(.mod) .F90
|
||||
|
||||
|
||||
####################### Section 1 #######################
|
||||
# Define your compilers and compiler flags here #
|
||||
##########################################################
|
||||
F90=/usr/local/bin/g95
|
||||
FC=/usr/local/bin/g95
|
||||
F77=$(FC)
|
||||
F90COPT= -O3
|
||||
FCOPT=-O3
|
||||
CCOPT=-O3
|
||||
|
||||
####################### Section 2 #######################
|
||||
# Define your linker and linker flags here #
|
||||
##########################################################
|
||||
F90LINK=/usr/local/mpich-g95/bin/mpif90
|
||||
FLINK=/usr/local/mpich-g95/bin/mpif77
|
||||
MPF90=/usr/local/mpich-g95/bin/mpif90
|
||||
MPF77=/usr/local/mpich-g95/bin/mpif77
|
||||
MPCC=/usr/local/mpich-g95/bin/mpicc
|
||||
|
||||
####################### Section 3 #######################
|
||||
# Specify paths to libraries #
|
||||
##########################################################
|
||||
BLAS=-lblasg95 -L$(HOME)/LIB
|
||||
BLACS=-lmpiblacsg95 -L$(HOME)/LIB
|
||||
|
||||
|
||||
####################### Section 4 #######################
|
||||
# Other useful tools&defines #
|
||||
##########################################################
|
||||
#SLUDIR=/usr/local/SuperLU_3.0
|
||||
#SLU=-lslu_lx_gfort -L$(SLUDIR)
|
||||
#SLUDEF=-DHave_SLU_ -I$(SLUDIR)
|
||||
|
||||
#UMFDIR=$(HOME)/LIB/Umfpack_gcc41
|
||||
#UMF=-lumfpack -lamd -L$(UMFDIR)
|
||||
#UMFDEF=-DHave_UMF_ -I$(UMFDIR)
|
||||
|
||||
# Add -DLargeFptr for 64-bit addresses
|
||||
CDEFINES=-DAdd_ $(SLUDEF) $(UMFDEF)
|
||||
FDEFINES=-DNORMAL
|
||||
|
||||
AR=ar -cur
|
||||
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)
|
||||
|
||||
# Under Linux/gmake there is a rule interpreting .mod as Modula source!
|
||||
$(.mod).o:
|
||||
|
||||
.f.o:
|
||||
$(FC) $(FCOPT) $(INCDIRS) -c $<
|
||||
.c.o:
|
||||
$(CC) $(CCOPT) $(INCDIRS) $(CDEFINES) -c $<
|
||||
.f$(.mod):
|
||||
$(F90) $(FCOPT) $(INCDIRS) -c $<
|
||||
.f90$(.mod):
|
||||
$(F90) $(F90COPT) $(INCDIRS) -c $<
|
||||
.f90.o:
|
||||
$(F90) $(F90COPT) $(INCDIRS) -c $<
|
||||
.F90.o:
|
||||
$(F90) $(F90COPT) $(INCDIRS) $(FDEFINES) -c $<
|
||||
@ -0,0 +1,86 @@
|
||||
.mod=.mod
|
||||
.fh=.fh
|
||||
.SUFFIXES: .f90 $(.mod) .F90
|
||||
|
||||
|
||||
####################### Section 1 #######################
|
||||
# Define your compilers and compiler flags here #
|
||||
##########################################################
|
||||
F90=/usr/local/gcc42/bin/gfortran
|
||||
FC=/usr/local/gcc42/bin/gfortran
|
||||
F77=$(FC)
|
||||
CC=/usr/local/gcc42/bin/gcc
|
||||
F90COPT=-O3 -ggdb
|
||||
FCOPT=-O3 -ggdb
|
||||
CCOPT=-O3 -ggdb
|
||||
|
||||
####################### Section 2 #######################
|
||||
# Define your linker and linker flags here #
|
||||
##########################################################
|
||||
F90LINK=/usr/local/mpich-gcc42/bin/mpif90
|
||||
FLINK=/usr/local/mpich-gcc42/bin/mpif77
|
||||
MPF90=/usr/local/mpich-gcc42/bin/mpif90
|
||||
MPF77=/usr/local/mpich-gcc42/bin/mpif77
|
||||
MPCC=/usr/local/mpich-gcc42/bin/mpicc
|
||||
|
||||
####################### Section 3 #######################
|
||||
# Specify paths to libraries #
|
||||
##########################################################
|
||||
BLAS=-lblas-gcc42 -L$(HOME)/LIB
|
||||
BLACS=-lmpiblacs-gcc42 -L$(HOME)/LIB
|
||||
|
||||
|
||||
####################### Section 4 #######################
|
||||
# Other useful tools&defines #
|
||||
##########################################################
|
||||
SLUDIR=/usr/local/SuperLU_3.0
|
||||
SLU=-lslu_lx_gcc42 -L$(SLUDIR)
|
||||
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)
|
||||
FDEFINES=-DNETLIB_BLACS -DHAVE_MOVE_ALLOC
|
||||
|
||||
AR=ar -cur
|
||||
RANLIB=ranlib
|
||||
|
||||
|
||||
|
||||
####################### Section 5 #######################
|
||||
# Do not edit this #
|
||||
##########################################################
|
||||
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:
|
||||
|
||||
.f.o:
|
||||
$(FC) $(FCOPT) $(INCDIRS) -c $<
|
||||
.c.o:
|
||||
$(CC) $(CCOPT) $(INCDIRS) $(CDEFINES) -c $<
|
||||
.f$(.mod):
|
||||
$(F90) $(FCOPT) $(INCDIRS) -c $<
|
||||
.f90$(.mod):
|
||||
$(F90) $(F90COPT) $(INCDIRS) -c $<
|
||||
.f90.o:
|
||||
$(F90) $(F90COPT) $(INCDIRS) -c $<
|
||||
.F90.o:
|
||||
$(F90) $(F90COPT) $(INCDIRS) $(FDEFINES) -c $<
|
||||
|
||||
|
||||
|
||||
|
||||
@ -0,0 +1,88 @@
|
||||
.mod=.mod
|
||||
.fh=.fh
|
||||
.SUFFIXES: .f90 $(.mod) .F90
|
||||
|
||||
|
||||
####################### Section 1 #######################
|
||||
# Define your compilers and compiler flags here #
|
||||
##########################################################
|
||||
IFC9=/opt/intel/fc/9.1.033
|
||||
F90=$(IFC9)/bin/ifort
|
||||
FC=$(IFC9)/bin/ifort
|
||||
F77=$(FC)
|
||||
CC=gcc
|
||||
F90COPT=-O3
|
||||
FCOPT=-O3
|
||||
CCOPT=-O3
|
||||
|
||||
####################### Section 2 #######################
|
||||
# Define your linker and linker flags here #
|
||||
##########################################################
|
||||
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 #
|
||||
##########################################################
|
||||
BLAS=-lblas-intel -L$(HOME)/NUMERICAL/LIB
|
||||
BLACS=-lmpiblacs-intel -L$(HOME)/NUMERICAL/LIB
|
||||
|
||||
|
||||
|
||||
####################### Section 4 #######################
|
||||
# Other useful tools&defines #
|
||||
##########################################################
|
||||
SLUDIR=/usr/local/SuperLU_3.0
|
||||
SLU=-lslu_lx_ifc9 -L$(SLUDIR)
|
||||
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)
|
||||
FDEFINES=-DNETLIB_BLACS -DHAVE_MOVE_ALLOC
|
||||
|
||||
AR=ar -cur
|
||||
RANLIB=ranlib
|
||||
|
||||
|
||||
|
||||
####################### Section 5 #######################
|
||||
# Do not edit this #
|
||||
##########################################################
|
||||
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:
|
||||
|
||||
.f.o:
|
||||
$(FC) $(FCOPT) $(INCDIRS) -c $<
|
||||
.c.o:
|
||||
$(CC) $(CCOPT) $(INCDIRS) $(CDEFINES) -c $<
|
||||
.f$(.mod):
|
||||
$(F90) $(FCOPT) $(INCDIRS) -c $<
|
||||
.f90$(.mod):
|
||||
$(F90) $(F90COPT) $(INCDIRS) -c $<
|
||||
.f90.o:
|
||||
$(F90) $(F90COPT) $(INCDIRS) -c $<
|
||||
.F90.o:
|
||||
$(F90) $(F90COPT) $(INCDIRS) $(FDEFINES) -c $<
|
||||
|
||||
|
||||
|
||||
|
||||
@ -0,0 +1,86 @@
|
||||
.mod=.mod
|
||||
.fh=.fh
|
||||
.SUFFIXES: .f90 $(.mod) .F90
|
||||
|
||||
|
||||
####################### Section 1 #######################
|
||||
# Define your compilers and compiler flags here #
|
||||
##########################################################
|
||||
F90=xlf95 -qsuffix=f=f90:cpp=F90
|
||||
FC=xlf
|
||||
F77=$(FC)
|
||||
CC=xlc
|
||||
F90COPT= -O3
|
||||
FCOPT=-O3
|
||||
CCOPT=-O3
|
||||
|
||||
####################### Section 2 #######################
|
||||
# Define your linker and linker flags here #
|
||||
##########################################################
|
||||
MPF90=mpxlf95 -qsuffix=f=f90
|
||||
F90LINK=$(MPF90)
|
||||
FLINK=$(MPF90)
|
||||
MPF77=mpxlf95 -qfixed
|
||||
MPCC=mpxlc
|
||||
|
||||
####################### Section 3 #######################
|
||||
# Specify paths to libraries #
|
||||
##########################################################
|
||||
BLAS=-lessl
|
||||
BLACS=-lmpiblacs
|
||||
|
||||
|
||||
####################### Section 4 #######################
|
||||
# Other useful tools&defines #
|
||||
##########################################################
|
||||
#SLUDIR=/usr/local/SuperLU_3.0
|
||||
#SLU=-lslu -L$(SLUDIR)
|
||||
#SLUDEF=-DHave_SLU_ -I$(SLUDIR)
|
||||
|
||||
#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
|
||||
FDEFINES=-WF,-DESSL_BLACS -WF,-DHAVE_MOVE_ALLOC
|
||||
|
||||
AR=ar -cur
|
||||
RANLIB=ranlib
|
||||
|
||||
|
||||
|
||||
####################### Section 5 #######################
|
||||
# Do not edit this #
|
||||
##########################################################
|
||||
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:
|
||||
|
||||
.f.o:
|
||||
$(FC) $(FCOPT) $(INCDIRS) -c $<
|
||||
.c.o:
|
||||
$(CC) $(CCOPT) $(INCDIRS) $(CDEFINES) -c $<
|
||||
.f$(.mod):
|
||||
$(F90) $(FCOPT) $(INCDIRS) -c $<
|
||||
.f90$(.mod):
|
||||
$(F90) $(F90COPT) $(INCDIRS) -c $<
|
||||
.f90.o:
|
||||
$(F90) $(F90COPT) $(INCDIRS) -c $<
|
||||
.F90.o:
|
||||
$(F90) $(F90COPT) $(INCDIRS) $(FDEFINES) -c $<
|
||||
|
||||
|
||||
|
||||
|
||||
@ -0,0 +1,46 @@
|
||||
include ./Make.inc
|
||||
|
||||
|
||||
LIBDIR=../psblas2/lib
|
||||
HERE=.
|
||||
INCDIRS=-I. -I$(LIBDIR)
|
||||
|
||||
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_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_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
|
||||
OBJS=$(F90OBJS) $(COBJS) $(MPFOBJS) $(MODOBJS)
|
||||
|
||||
LIBMOD=psb_prec_mod$(.mod)
|
||||
LOCAL_MODS=$(LIBMOD) psb_prec_type$(.mod)
|
||||
LIBNAME=$(PRECLIBNAME)
|
||||
|
||||
lib: mpobjs $(OBJS)
|
||||
$(AR) $(HERE)/$(LIBNAME) $(OBJS)
|
||||
$(RANLIB) $(HERE)/$(LIBNAME)
|
||||
/bin/cp -p $(HERE)/$(LIBNAME) $(LIBDIR)
|
||||
/bin/cp -p $(LIBMOD) $(LIBDIR)
|
||||
|
||||
$(F90OBJS) $(MPFOBJS): $(MODOBJS)
|
||||
psb_prec_mod.o: psb_prec_type.o
|
||||
|
||||
mpobjs:
|
||||
(make $(MPFOBJS) F90="$(MPF90)" F90COPT="$(F90COPT)")
|
||||
|
||||
veryclean: clean
|
||||
/bin/rm -f $(LIBNAME)
|
||||
|
||||
clean:
|
||||
/bin/rm -f $(OBJS) $(LOCAL_MODS)
|
||||
@ -0,0 +1,130 @@
|
||||
This directory contains the PSBLAS library, version 2.1.0
|
||||
|
||||
|
||||
Version 1.0 of the library was described in:
|
||||
S. Filippone, M. Colajanni
|
||||
PSBLAS: A library for parallel linear algebra computation on sparse matrices
|
||||
ACM Trans. on Math. Software, 26(4), Dec. 2000, pp. 527-550.
|
||||
|
||||
PLATFORMS:
|
||||
|
||||
The compilation process relies on the choice of an appropriate
|
||||
Make.inc file; we have tested with AIX XLF, Intel ifc/Linux, Lahey
|
||||
F95/Linux, Nag f95/Linux, GNU Fortran/Linux. If you succeed in compiling with
|
||||
other compiler/operating systems please let us know.
|
||||
|
||||
|
||||
LINUX:
|
||||
|
||||
There finally exist a GNU Fortran 95 implementation: we are using the
|
||||
development snapshots from GCC 3.5.0, later 4.1 and 4.2 since July
|
||||
2004, and it appears to work. The 4.2 version of GNU compilers is now
|
||||
our reference platform; the official 4.2.0 release is due pretty
|
||||
soon. It now includes support for ALLOCATABLES.
|
||||
|
||||
|
||||
The Lahey version we got access to (6.0 and 6.1) seems to suffer from
|
||||
spurious extra copies problem; this is most apparent in the matrix
|
||||
build process.
|
||||
|
||||
For the Intel compilers, we recommend moving to version 9; previous
|
||||
versions of the library have been compiled with version 7 and 8 of
|
||||
ifort.
|
||||
|
||||
IBM SP.
|
||||
The library has been tested on an IBM SP2, SP4 and SP5, with XLC and XLF
|
||||
compilers, and a version of the BLACS based on MPI.
|
||||
The setting
|
||||
F90=xlf90 -qsuffix=f=f90
|
||||
in Make.inc.rs6k takes care of the f90 extension.
|
||||
WARNING: xlf 8.1 introduced a performance bug, whereas a Fortan 90
|
||||
code calling a Fortan 77 code would incur spurious array copies;
|
||||
please make sure your system has the PTF xlf 8102 installed.
|
||||
|
||||
|
||||
|
||||
UTILITIES
|
||||
The TEST/Fileread directory contains some utilities to convert to/from
|
||||
Harwell-Boeing and MatrixMarket file formats.
|
||||
|
||||
|
||||
DOCUMENTATION
|
||||
|
||||
See userguide.pdf
|
||||
Please consult the sample programs, especially TEST/pargen/ppde90.f90.
|
||||
|
||||
|
||||
OTHER SOFTWARE CREDITS
|
||||
|
||||
We include our modified implementation of some of the Sparker (serial
|
||||
sparse BLAS) material, e.g. Jagged diagonal, plus a number of
|
||||
extensions of our own design. The original file spblas.f can be
|
||||
downloaded from matisa.cc.rl.ac.uk; of course any bugs in our
|
||||
implementation are our own to fix. The main reference for the serial
|
||||
sparse BLAS is:
|
||||
Duff, I., Marrone, M., Radicati, G., and Vittoli, C.
|
||||
Level 3 basic linear algebra subprograms for sparse matrices: a user
|
||||
level interface
|
||||
ACM Trans. Math. Softw., 23(3), 379-401, 1997.
|
||||
|
||||
In the multilevel preconditioners we use SMMP by Randolph E. Bank and
|
||||
Craig C. Douglas na.bank@na-net.ornl.gov and
|
||||
na.cdouglas@na-net.ornl.gov; we wrapped it in a Fortran 95 interface
|
||||
with dynamic memory allocation.
|
||||
|
||||
To compile and run our software you will need
|
||||
|
||||
1. A working version of MPI
|
||||
|
||||
2. The MPI version of the BLACS from
|
||||
http://www.netlib.org/blacs/index.html
|
||||
|
||||
3. A version of the BLAS; if you don't have a specific version for
|
||||
your platform you may try ATLAS available from
|
||||
http://math-atlas.sourceforge.net/
|
||||
|
||||
4. We have had good results with the METIS library, from
|
||||
http://www-users.cs.umn.edu/~karypis/metis/metis/main.html
|
||||
This is not necessary to compile our library, but the test program
|
||||
in test/Fileread assumes you have it installed.
|
||||
|
||||
5. For our preconditioners we include interfaces to the following
|
||||
software packages:
|
||||
-- SuperLU 3.0 http://crd.lbl.gov/~xiaoye/SuperLU/
|
||||
-- UMFPACK 4.4 http://www.cise.ufl.edu/research/sparse/umfpack/
|
||||
These are optional, you only need to install them if you actually
|
||||
want to use them.
|
||||
|
||||
|
||||
TODO:
|
||||
- As soon as TR 15581 and MOVE_ALLOC become available in GNU Fortran
|
||||
we shall move from POINTERS to ALLOCATABLE for both vectors and
|
||||
derived data types components.
|
||||
- The GLOB_TO_LOC array should be changed for large test cases.
|
||||
|
||||
|
||||
The PSBLAS team.
|
||||
|
||||
|
||||
Contact: Salvatore Filippone salvatore.filippone@uniroma2.it
|
||||
|
||||
Credits for version 2.0:
|
||||
Salvatore Filippone
|
||||
Alfredo Buttari
|
||||
|
||||
The MD2P4 multilevel parallel preconditioners contained in directory
|
||||
src/prec were developed with the contribution of:
|
||||
Pasqua D'Ambra
|
||||
Daniela di Serafino
|
||||
They are still in an early experimental stage, use at your own risk!
|
||||
|
||||
Credits for version 1.0:
|
||||
Salvatore Filippone
|
||||
Michele Colajanni
|
||||
Fabio Cerioni
|
||||
Stefano Maiolatesi
|
||||
Dario Pascucci
|
||||
|
||||
|
||||
|
||||
|
||||
@ -0,0 +1,245 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
!*****************************************************************************
|
||||
!* *
|
||||
!* This routine does two things: *
|
||||
!* 1. Builds the auxiliary descriptor. This is always done even for *
|
||||
!* Block Jacobi. *
|
||||
!* 2. Retrieves the remote matrix pieces. *
|
||||
!* *
|
||||
!* All of 1. is done under psb_cdovr, which is independent of CSR, and *
|
||||
!* has been placed in the TOOLS directory because it might be used for *
|
||||
!* building a descriptor for an extended stencil in a PDE solver without *
|
||||
!* necessarily applying AS precond. *
|
||||
!* *
|
||||
!* *
|
||||
!* *
|
||||
!* *
|
||||
!* *
|
||||
!*****************************************************************************
|
||||
Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
|
||||
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
Implicit None
|
||||
|
||||
! .. Array Arguments ..
|
||||
integer, intent(in) :: ptype,novr
|
||||
Type(psb_dspmat_type), Intent(in) :: a
|
||||
Type(psb_dspmat_type), Intent(inout) :: blk
|
||||
integer, intent(out) :: info
|
||||
Type(psb_desc_type), Intent(inout) :: desc_p
|
||||
Type(psb_desc_type), Intent(in) :: desc_data
|
||||
Character, Intent(in) :: upd
|
||||
character(len=5), optional :: outfmt
|
||||
|
||||
|
||||
real(kind(1.d0)) :: t1,t2,t3,mpi_wtime
|
||||
external mpi_wtime
|
||||
integer icomm
|
||||
|
||||
! .. Local Scalars ..
|
||||
Integer :: k, np,me,m,nnzero,&
|
||||
& ictxt, n_col,ier,n,int_err(5),&
|
||||
& tot_recv, ircode, n_row,nhalo, nrow_a,err_act
|
||||
Logical,Parameter :: debug=.false., debugprt=.false.
|
||||
character(len=20) :: name, ch_err
|
||||
name='psb_dasmatbld'
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=0
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
If(debug) Write(0,*)'IN DASMATBLD ', upd
|
||||
ictxt=desc_data%matrix_data(psb_ctxt_)
|
||||
Call psb_info(ictxt, me, np)
|
||||
|
||||
tot_recv=0
|
||||
|
||||
nrow_a = desc_data%matrix_data(psb_n_row_)
|
||||
nnzero = Size(a%aspk)
|
||||
n_col = desc_data%matrix_data(psb_n_col_)
|
||||
nhalo = n_col-nrow_a
|
||||
|
||||
|
||||
If (ptype == bja_) Then
|
||||
!
|
||||
! Block Jacobi. Copy the descriptor, just in case we want to
|
||||
! do the renumbering.
|
||||
!
|
||||
If(debug) Write(0,*)' asmatbld calling allocate '
|
||||
call psb_sp_all(0,0,blk,1,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'
|
||||
blk%infoa(psb_nnz_) = 0
|
||||
If(debug) Write(0,*)' asmatbld done spallocate'
|
||||
If (upd == 'F') Then
|
||||
call psb_cdcpy(desc_data,desc_p,info)
|
||||
If(debug) Write(0,*)' asmatbld done cdcpy'
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_cdcpy'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
|
||||
Else If (ptype == asm_) Then
|
||||
|
||||
|
||||
!
|
||||
! Additive Schwarz variant.
|
||||
!
|
||||
!
|
||||
|
||||
|
||||
if (novr < 0) then
|
||||
info=3
|
||||
int_err(1)=novr
|
||||
call psb_errpush(info,name,i_err=int_err)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
if (novr == 0) then
|
||||
!
|
||||
! This is really just Block Jacobi.....
|
||||
!
|
||||
If(debug) Write(0,*)' asmatbld calling allocate novr=0'
|
||||
call psb_sp_all(0,0,blk,1,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'
|
||||
blk%infoa(psb_nnz_)=0
|
||||
if (debug) write(0,*) 'Calling desccpy'
|
||||
if (upd == 'F') then
|
||||
call psb_cdcpy(desc_data,desc_p,info)
|
||||
If(debug) Write(0,*)' asmatbld done cdcpy'
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_cdcpy'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
if (debug) write(0,*) 'Early return from asmatbld: P>=3 N_OVR=0'
|
||||
endif
|
||||
return
|
||||
endif
|
||||
|
||||
call psb_get_mpicomm(ictxt,icomm)
|
||||
|
||||
If(debug)Write(0,*)'BEGIN dasmatbld',me,upd,novr
|
||||
t1 = mpi_wtime()
|
||||
|
||||
If (upd == 'F') Then
|
||||
!
|
||||
! Build the auiliary descriptor',desc_p%matrix_data(psb_n_row_)
|
||||
!
|
||||
call psb_cdbldovr(a,desc_data,novr,desc_p,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_cdbldovr'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
Endif
|
||||
|
||||
if(debug) write(0,*) me,' From cdbldovr _:',desc_p%matrix_data(psb_n_row_),&
|
||||
& desc_p%matrix_data(psb_n_col_)
|
||||
|
||||
|
||||
n_row = desc_p%matrix_data(psb_n_row_)
|
||||
t2 = mpi_wtime()
|
||||
!!$ open(60+me)
|
||||
!!$ call psb_cdprt(60+me,desc_p,short=.false.)
|
||||
!!$ call flush(60+me)
|
||||
!!$ close(60+me)
|
||||
!!$ call psb_barrier(ictxt)
|
||||
if (debug) write(0,*) 'Before sphalo ',blk%fida,blk%m,psb_nnz_,blk%infoa(psb_nnz_)
|
||||
!!$ ierr = MPE_Log_event( iovrb, 0, "st OVR" )
|
||||
!!$ blk%m = n_row-nrow_a
|
||||
!!$ blk%k = n_row
|
||||
|
||||
if (present(outfmt)) then
|
||||
if(debug) write(0,*) me,': Calling SPHALO with ',size(blk%ia2)
|
||||
Call psb_sphalo(a,desc_p,blk,info,outfmt=outfmt)
|
||||
else
|
||||
if(debug) write(0,*) me,': Calling SPHALO with ',size(blk%ia2)
|
||||
Call psb_sphalo(a,desc_p,blk,info)
|
||||
end if
|
||||
|
||||
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_sphalo'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (debug) write(0,*) 'After psb_sphalo ',blk%fida,blk%m,psb_nnz_,blk%infoa(psb_nnz_)
|
||||
!!$ ierr = MPE_Log_event( iovre, 0, "ed OVR" )
|
||||
|
||||
t3 = mpi_wtime()
|
||||
if (debugprt) then
|
||||
open(40+me)
|
||||
call psb_csprt(40+me,blk,head='% Ovrlap rows')
|
||||
close(40+me)
|
||||
endif
|
||||
|
||||
|
||||
End If
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
Return
|
||||
|
||||
End Subroutine psb_dasmatbld
|
||||
|
||||
@ -0,0 +1,281 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_dbaseprc_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_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
|
||||
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
|
||||
|
||||
! Local variables
|
||||
integer :: n_row,n_col, int_err(5)
|
||||
real(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:)
|
||||
character ::diagl, diagu
|
||||
integer :: ictxt,np,me,i, isz, nrg, err_act
|
||||
real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime
|
||||
logical,parameter :: debug=.false., debugprt=.false.
|
||||
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
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
ictxt=desc_data%matrix_data(psb_ctxt_)
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
diagl='U'
|
||||
diagu='U'
|
||||
|
||||
select case(trans)
|
||||
case('N','n')
|
||||
case('T','t','C','c')
|
||||
case default
|
||||
info=40
|
||||
int_err(1)=6
|
||||
ch_err(2:2)=trans
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
select case(prec%iprcparm(p_type_))
|
||||
|
||||
case(noprec_)
|
||||
|
||||
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
|
||||
|
||||
case(diagsc_)
|
||||
|
||||
if (size(work) >= size(x)) then
|
||||
ww => work
|
||||
else
|
||||
allocate(ww(size(x)),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
|
||||
n_row=desc_data%matrix_data(psb_n_row_)
|
||||
ww(1:n_row) = x(1:n_row)*prec%d(1:n_row)
|
||||
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
|
||||
|
||||
if (size(work) < size(x)) then
|
||||
deallocate(ww,stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Deallocate')
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
|
||||
case(bja_)
|
||||
|
||||
call psb_bjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
|
||||
if(info.ne.0) then
|
||||
info=4010
|
||||
ch_err='psb_bjac_aply'
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
case(asm_,ras_,ash_,rash_)
|
||||
|
||||
if (prec%iprcparm(n_ovr_)==0) then
|
||||
! shortcut: this fixes performance for RAS(0) == BJA
|
||||
call psb_bjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
|
||||
if(info.ne.0) then
|
||||
info=4010
|
||||
ch_err='psb_bjacaply'
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
else
|
||||
! Note: currently trans is unused.
|
||||
n_row=prec%desc_data%matrix_data(psb_n_row_)
|
||||
n_col=prec%desc_data%matrix_data(psb_n_col_)
|
||||
|
||||
isz=max(n_row,N_COL)
|
||||
if ((6*isz) <= size(work)) then
|
||||
ww => work(1:isz)
|
||||
tx => work(isz+1:2*isz)
|
||||
ty => work(2*isz+1:3*isz)
|
||||
aux => work(3*isz+1:)
|
||||
else if ((4*isz) <= size(work)) then
|
||||
aux => work(1:)
|
||||
allocate(ww(isz),tx(isz),ty(isz),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
else if ((3*isz) <= size(work)) then
|
||||
ww => work(1:isz)
|
||||
tx => work(isz+1:2*isz)
|
||||
ty => work(2*isz+1:3*isz)
|
||||
allocate(aux(4*isz),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
else
|
||||
allocate(ww(isz),tx(isz),ty(isz),&
|
||||
&aux(4*isz),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
endif
|
||||
|
||||
if (debugprt) write(0,*)' vdiag: ',prec%d(:)
|
||||
if (debug) write(0,*) 'Bi-CGSTAB with Additive Schwarz prec'
|
||||
|
||||
tx(1:desc_data%matrix_data(psb_n_row_)) = x(1:desc_data%matrix_data(psb_n_row_))
|
||||
tx(desc_data%matrix_data(psb_n_row_)+1:isz) = dzero
|
||||
|
||||
if (prec%iprcparm(restr_)==psb_halo_) then
|
||||
call psb_halo(tx,prec%desc_data,info,work=aux)
|
||||
if(info /=0) then
|
||||
info=4010
|
||||
ch_err='psb_halo'
|
||||
goto 9999
|
||||
end if
|
||||
else if (prec%iprcparm(restr_) /= psb_none_) then
|
||||
write(0,*) 'Problem in PRC_APLY: Unknown value for restriction ',&
|
||||
&prec%iprcparm(restr_)
|
||||
end if
|
||||
|
||||
if (prec%iprcparm(iren_)>0) then
|
||||
call dgelp('N',n_row,1,prec%perm,tx,isz,ww,isz,info)
|
||||
if(info /=0) then
|
||||
info=4010
|
||||
ch_err='psb_dgelp'
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
|
||||
call psb_bjac_aply(done,prec,tx,dzero,ty,prec%desc_data,trans,aux,info)
|
||||
if(info.ne.0) then
|
||||
info=4010
|
||||
ch_err='psb_bjac_aply'
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (prec%iprcparm(iren_)>0) then
|
||||
call dgelp('N',n_row,1,prec%invperm,ty,isz,ww,isz,info)
|
||||
if(info /=0) then
|
||||
info=4010
|
||||
ch_err='psb_dgelp'
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
|
||||
select case (prec%iprcparm(prol_))
|
||||
|
||||
case(psb_none_)
|
||||
! Would work anyway, but since it's supposed to do nothing...
|
||||
! call f90_psovrl(ty,prec%desc_data,update=prec%a_restrict)
|
||||
|
||||
case(psb_sum_,psb_avg_)
|
||||
call psb_ovrl(ty,prec%desc_data,info,&
|
||||
& update=prec%iprcparm(prol_),work=aux)
|
||||
if(info /=0) then
|
||||
info=4010
|
||||
ch_err='psb_ovrl'
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
case default
|
||||
write(0,*) 'Problem in PRC_APLY: Unknown value for prolongation ',&
|
||||
& prec%iprcparm(prol_)
|
||||
end select
|
||||
|
||||
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
|
||||
if ((6*isz) <= size(work)) then
|
||||
else if ((4*isz) <= size(work)) then
|
||||
deallocate(ww,tx,ty)
|
||||
else if ((3*isz) <= size(work)) then
|
||||
deallocate(aux)
|
||||
else
|
||||
deallocate(ww,aux,tx,ty)
|
||||
endif
|
||||
end if
|
||||
case default
|
||||
write(0,*) 'Invalid PRE%PREC ',prec%iprcparm(p_type_),':',&
|
||||
& min_prec_,noprec_,diagsc_,bja_,&
|
||||
& asm_,ras_,ash_,rash_
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine psb_dbaseprc_aply
|
||||
|
||||
@ -0,0 +1,267 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd)
|
||||
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
Implicit None
|
||||
|
||||
type(psb_dspmat_type), target :: a
|
||||
type(psb_desc_type), intent(in), target :: desc_a
|
||||
type(psb_dbaseprc_type),intent(inout) :: p
|
||||
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,&
|
||||
& me,mycol,np,npcol,mglob,lw, mtype, nrg, nzg, err_act
|
||||
real(kind(1.d0)) :: temp, real_err(5)
|
||||
real(kind(1.d0)),pointer :: gd(:), work(:)
|
||||
integer :: int_err(5)
|
||||
character :: iupd
|
||||
|
||||
logical, parameter :: debug=.false.
|
||||
integer,parameter :: iroot=0,iout=60,ilout=40
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=0
|
||||
err=0
|
||||
call psb_erractionsave(err_act)
|
||||
name = 'psb_baseprc_bld'
|
||||
|
||||
if (debug) write(0,*) 'Entering baseprc_bld'
|
||||
info = 0
|
||||
int_err(1) = 0
|
||||
ictxt = psb_cd_get_context(desc_a)
|
||||
n_row = psb_cd_get_local_rows(desc_a)
|
||||
n_col = psb_cd_get_local_cols(desc_a)
|
||||
mglob = psb_cd_get_global_rows(desc_a)
|
||||
|
||||
if (debug) write(0,*) 'Preconditioner Blacs_gridinfo'
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
if (present(upd)) then
|
||||
if (debug) write(0,*) 'UPD ', upd
|
||||
if ((UPD.eq.'F').or.(UPD.eq.'T')) then
|
||||
IUPD=UPD
|
||||
else
|
||||
IUPD='F'
|
||||
endif
|
||||
else
|
||||
IUPD='F'
|
||||
endif
|
||||
|
||||
!
|
||||
! Should add check to ensure all procs have the same...
|
||||
!
|
||||
! ALso should define symbolic names for the preconditioners.
|
||||
!
|
||||
|
||||
call psb_check_def(p%iprcparm(p_type_),'base_prec',&
|
||||
& diagsc_,is_legal_base_prec)
|
||||
|
||||
!!$ allocate(p%desc_data,stat=info)
|
||||
!!$ if (info /= 0) then
|
||||
!!$ call psb_errpush(4010,name,a_err='Allocate')
|
||||
!!$ goto 9999
|
||||
!!$ end if
|
||||
|
||||
call psb_nullify_desc(p%desc_data)
|
||||
|
||||
select case(p%iprcparm(p_type_))
|
||||
case (noprec_)
|
||||
! Do nothing.
|
||||
call psb_cdcpy(desc_a,p%desc_data,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_cdcpy'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
case (diagsc_)
|
||||
|
||||
call psb_diagsc_bld(a,desc_a,p,iupd,info)
|
||||
if(debug) write(0,*)me,': out of psb_diagsc_bld'
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_diagsc_bld'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
case (bja_,asm_)
|
||||
|
||||
call psb_check_def(p%iprcparm(n_ovr_),'overlap',&
|
||||
& 0,is_legal_n_ovr)
|
||||
call psb_check_def(p%iprcparm(restr_),'restriction',&
|
||||
& psb_halo_,is_legal_restrict)
|
||||
call psb_check_def(p%iprcparm(prol_),'prolongator',&
|
||||
& psb_none_,is_legal_prolong)
|
||||
call psb_check_def(p%iprcparm(iren_),'renumbering',&
|
||||
& renum_none_,is_legal_renum)
|
||||
call psb_check_def(p%iprcparm(f_type_),'fact',&
|
||||
& f_ilu_n_,is_legal_ml_fact)
|
||||
|
||||
if (debug) write(0,*)me, ': Calling PSB_ILU_BLD'
|
||||
if (debug) call psb_barrier(ictxt)
|
||||
|
||||
select case(p%iprcparm(f_type_))
|
||||
|
||||
case(f_ilu_n_,f_ilu_e_)
|
||||
call psb_ilu_bld(a,desc_a,p,iupd,info)
|
||||
if(debug) write(0,*)me,': out of psb_ilu_bld'
|
||||
if (debug) call psb_barrier(ictxt)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_ilu_bld'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
case(f_slu_)
|
||||
|
||||
if(debug) write(0,*)me,': calling slu_bld'
|
||||
call psb_slu_bld(a,desc_a,p,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='slu_bld'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
case(f_umf_)
|
||||
if(debug) write(0,*)me,': calling umf_bld'
|
||||
call psb_umf_bld(a,desc_a,p,info)
|
||||
if(debug) write(0,*)me,': Done umf_bld ',info
|
||||
if (info /= 0) then
|
||||
info=4010
|
||||
ch_err='umf_bld'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
case(f_none_)
|
||||
write(0,*) 'Fact=None in BASEPRC_BLD Bja/ASM??'
|
||||
info=4010
|
||||
ch_err='Inconsistent prec f_none_'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
|
||||
case default
|
||||
write(0,*) 'Unknown factor type in baseprc_bld bja/asm: ',&
|
||||
&p%iprcparm(f_type_)
|
||||
info=4010
|
||||
ch_err='Unknown f_type_'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end select
|
||||
case default
|
||||
info=4010
|
||||
ch_err='Unknown p_type_'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
|
||||
end select
|
||||
|
||||
p%base_a => a
|
||||
p%base_desc => desc_a
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine psb_dbaseprc_bld
|
||||
|
||||
@ -0,0 +1,270 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
|
||||
!
|
||||
! Compute Y <- beta*Y + alpha*K^-1 X
|
||||
! where K is a a Block Jacobi preconditioner stored in prec
|
||||
! Note that desc_data may or may not be the same as prec%desc_data,
|
||||
! but since both are INTENT(IN) this should be legal.
|
||||
!
|
||||
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
|
||||
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
|
||||
|
||||
! Local variables
|
||||
integer :: n_row,n_col
|
||||
real(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:),tb(:)
|
||||
character ::diagl, diagu
|
||||
integer :: ictxt,np,me,i, nrg, err_act, int_err(5)
|
||||
real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime
|
||||
logical,parameter :: debug=.false., debugprt=.false.
|
||||
external mpi_wtime
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name='psb_bjac_aply'
|
||||
info = 0
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
ictxt=psb_cd_get_context(desc_data)
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
diagl='U'
|
||||
diagu='U'
|
||||
|
||||
select case(trans)
|
||||
case('N','n')
|
||||
case('T','t','C','c')
|
||||
case default
|
||||
call psb_errpush(40,name)
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
|
||||
n_row=desc_data%matrix_data(psb_n_row_)
|
||||
n_col=desc_data%matrix_data(psb_n_col_)
|
||||
|
||||
if (n_col <= size(work)) then
|
||||
ww => work(1:n_col)
|
||||
if ((4*n_col+n_col) <= size(work)) then
|
||||
aux => work(n_col+1:)
|
||||
else
|
||||
allocate(aux(4*n_col),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
endif
|
||||
else
|
||||
allocate(ww(n_col),aux(4*n_col),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
|
||||
|
||||
if (prec%iprcparm(jac_sweeps_) == 1) then
|
||||
|
||||
|
||||
select case(prec%iprcparm(f_type_))
|
||||
case(f_ilu_n_,f_ilu_e_)
|
||||
|
||||
select case(trans)
|
||||
case('N','n')
|
||||
|
||||
call psb_spsm(done,prec%av(l_pr_),x,dzero,ww,desc_data,info,&
|
||||
& trans='N',unit=diagl,choice=psb_none_,work=aux)
|
||||
if(info /=0) goto 9999
|
||||
ww(1:n_row) = ww(1:n_row)*prec%d(1:n_row)
|
||||
call psb_spsm(alpha,prec%av(u_pr_),ww,beta,y,desc_data,info,&
|
||||
& trans='N',unit=diagu,choice=psb_none_, work=aux)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
case('T','t','C','c')
|
||||
call psb_spsm(done,prec%av(u_pr_),x,dzero,ww,desc_data,info,&
|
||||
& trans=trans,unit=diagu,choice=psb_none_, work=aux)
|
||||
if(info /=0) goto 9999
|
||||
ww(1:n_row) = ww(1:n_row)*prec%d(1:n_row)
|
||||
call psb_spsm(alpha,prec%av(l_pr_),ww,beta,y,desc_data,info,&
|
||||
& trans=trans,unit=diagl,choice=psb_none_,work=aux)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
end select
|
||||
|
||||
case(f_slu_)
|
||||
|
||||
ww(1:n_row) = x(1:n_row)
|
||||
|
||||
select case(trans)
|
||||
case('N','n')
|
||||
call psb_dslu_solve(0,n_row,1,ww,n_row,prec%iprcparm(slu_ptr_),info)
|
||||
case('T','t','C','c')
|
||||
call psb_dslu_solve(1,n_row,1,ww,n_row,prec%iprcparm(slu_ptr_),info)
|
||||
end select
|
||||
|
||||
if(info /=0) goto 9999
|
||||
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
|
||||
|
||||
case (f_umf_)
|
||||
|
||||
|
||||
select case(trans)
|
||||
case('N','n')
|
||||
call psb_dumf_solve(0,n_row,ww,x,n_row,prec%iprcparm(umf_numptr_),info)
|
||||
case('T','t','C','c')
|
||||
call psb_dumf_solve(1,n_row,ww,x,n_row,prec%iprcparm(umf_numptr_),info)
|
||||
end select
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
|
||||
|
||||
case default
|
||||
write(0,*) 'Unknown factorization type in bjac_aply',prec%iprcparm(f_type_)
|
||||
end select
|
||||
if (debugprt) write(0,*)' Y: ',y(:)
|
||||
|
||||
else if (prec%iprcparm(jac_sweeps_) > 1) then
|
||||
|
||||
! Note: we have to add TRANS to this one !!!!!!!!!
|
||||
|
||||
if (size(prec%av) < ap_nd_) then
|
||||
info = 4011
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
allocate(tx(n_col),ty(n_col),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
tx = dzero
|
||||
ty = dzero
|
||||
select case(prec%iprcparm(f_type_))
|
||||
case(f_ilu_n_,f_ilu_e_)
|
||||
do i=1, prec%iprcparm(jac_sweeps_)
|
||||
! X(k+1) = M^-1*(b-N*X(k))
|
||||
ty(1:n_row) = x(1:n_row)
|
||||
call psb_spmm(-done,prec%av(ap_nd_),tx,done,ty,&
|
||||
& prec%desc_data,info,work=aux)
|
||||
if(info /=0) goto 9999
|
||||
call psb_spsm(done,prec%av(l_pr_),ty,dzero,ww,&
|
||||
& prec%desc_data,info,&
|
||||
& trans='N',unit='U',choice=psb_none_,work=aux)
|
||||
if(info /=0) goto 9999
|
||||
ww(1:n_row) = ww(1:n_row)*prec%d(1:n_row)
|
||||
call psb_spsm(done,prec%av(u_pr_),ww,dzero,tx,&
|
||||
& prec%desc_data,info,&
|
||||
& trans='N',unit='U',choice=psb_none_,work=aux)
|
||||
if(info /=0) goto 9999
|
||||
end do
|
||||
|
||||
case(f_slu_)
|
||||
do i=1, prec%iprcparm(jac_sweeps_)
|
||||
! X(k+1) = M^-1*(b-N*X(k))
|
||||
ty(1:n_row) = x(1:n_row)
|
||||
call psb_spmm(-done,prec%av(ap_nd_),tx,done,ty,&
|
||||
& prec%desc_data,info,work=aux)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
call psb_dslu_solve(0,n_row,1,ty,n_row,prec%iprcparm(slu_ptr_),info)
|
||||
if(info /=0) goto 9999
|
||||
tx(1:n_row) = ty(1:n_row)
|
||||
end do
|
||||
case(f_umf_)
|
||||
do i=1, prec%iprcparm(jac_sweeps_)
|
||||
! X(k+1) = M^-1*(b-N*X(k))
|
||||
ty(1:n_row) = x(1:n_row)
|
||||
call psb_spmm(-done,prec%av(ap_nd_),tx,done,ty,&
|
||||
& prec%desc_data,info,work=aux)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
call psb_dumf_solve(0,n_row,ww,ty,n_row,&
|
||||
& prec%iprcparm(umf_numptr_),info)
|
||||
if(info /=0) goto 9999
|
||||
tx(1:n_row) = ww(1:n_row)
|
||||
end do
|
||||
|
||||
end select
|
||||
|
||||
call psb_geaxpby(alpha,tx,beta,y,desc_data,info)
|
||||
|
||||
|
||||
deallocate(tx,ty)
|
||||
|
||||
|
||||
else
|
||||
|
||||
goto 9999
|
||||
|
||||
endif
|
||||
|
||||
if (n_col <= size(work)) then
|
||||
if ((4*n_col+n_col) <= size(work)) then
|
||||
else
|
||||
deallocate(aux)
|
||||
endif
|
||||
else
|
||||
deallocate(ww,aux)
|
||||
endif
|
||||
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine psb_dbjac_aply
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,168 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_ddiagsc_bld(a,desc_a,p,upd,info)
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
Implicit None
|
||||
|
||||
type(psb_dspmat_type), target :: a
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
type(psb_dbaseprc_type),intent(inout) :: p
|
||||
character, intent(in) :: upd
|
||||
integer, intent(out) :: info
|
||||
|
||||
|
||||
! Local scalars
|
||||
Integer :: err, n_row, n_col,I,j,k,ictxt,&
|
||||
& me,np,mglob,lw, err_act
|
||||
real(kind(1.d0)),allocatable :: gd(:), work(:)
|
||||
integer :: int_err(5)
|
||||
character :: iupd
|
||||
|
||||
logical, parameter :: debug=.false.
|
||||
integer,parameter :: iroot=0,iout=60,ilout=40
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=0
|
||||
err=0
|
||||
call psb_erractionsave(err_act)
|
||||
name = 'psb_diagsc_bld'
|
||||
|
||||
if (debug) write(0,*) 'Entering diagsc_bld'
|
||||
info = 0
|
||||
int_err(1) = 0
|
||||
ictxt = psb_cd_get_context(desc_a)
|
||||
n_row = psb_cd_get_local_rows(desc_a)
|
||||
n_col = psb_cd_get_local_cols(desc_a)
|
||||
mglob = psb_cd_get_global_rows(desc_a)
|
||||
|
||||
if (debug) write(0,*) 'Preconditioner Blacs_gridinfo'
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
if (debug) write(0,*) 'Precond: Diagonal scaling'
|
||||
! diagonal scaling
|
||||
|
||||
call psb_realloc(n_col,p%d,info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='psb_realloc')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_csrws(p%d,a,info,trans='N')
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_csrws'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
call psb_cdcpy(desc_a,p%desc_Data,info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='psb_cdcpy')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (debug) write(ilout+me,*) 'VDIAG ',n_row
|
||||
do i=1,n_row
|
||||
if (p%d(i).eq.dzero) then
|
||||
p%d(i) = done
|
||||
else
|
||||
p%d(i) = done/p%d(i)
|
||||
endif
|
||||
|
||||
if (debug) write(ilout+me,*) i,desc_a%loc_to_glob(i), p%d(i)
|
||||
if (p%d(i).lt.0.d0) then
|
||||
write(0,*) me,'Negative RWS? ',i,p%d(i)
|
||||
endif
|
||||
end do
|
||||
if (a%pl(1) /= 0) then
|
||||
allocate(work(n_row),stat=info)
|
||||
if (info /= 0) then
|
||||
info=4000
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
call psb_gelp('n',a%pl,p%d,desc_a,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_dgelp'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
deallocate(work)
|
||||
endif
|
||||
|
||||
if (debug) then
|
||||
allocate(gd(mglob),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_gather(gd, p%d, desc_a, info, iroot=iroot)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_dgatherm'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (me.eq.iroot) then
|
||||
write(iout+np,*) 'VDIAG CHECK ',mglob
|
||||
do i=1,mglob
|
||||
write(iout+np,*) i,gd(i)
|
||||
enddo
|
||||
endif
|
||||
deallocate(gd)
|
||||
endif
|
||||
if (debug) write(*,*) 'Preconditioner DIAG computed OK'
|
||||
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine psb_ddiagsc_bld
|
||||
|
||||
@ -0,0 +1,292 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
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
|
||||
! Locals
|
||||
integer, allocatable :: ils(:), neigh(:)
|
||||
integer :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m
|
||||
|
||||
logical :: recovery
|
||||
logical, parameter :: debug=.false.
|
||||
integer ::ictxt,np,me,err_act
|
||||
integer :: nrow, ncol, n_ne
|
||||
integer, parameter :: one=1, two=2
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=0
|
||||
name = 'psb_bldaggrmat'
|
||||
call psb_erractionsave(err_act)
|
||||
!
|
||||
! Note. At the time being we are ignoring aggr_type
|
||||
! so that we only have local decoupled aggregation. This might
|
||||
! change in the future.
|
||||
!
|
||||
ictxt=psb_cd_get_context(desc_a)
|
||||
call psb_info(ictxt,me,np)
|
||||
nrow = psb_cd_get_local_rows(desc_a)
|
||||
ncol = psb_cd_get_local_cols(desc_a)
|
||||
|
||||
nr = a%m
|
||||
allocate(ilaggr(nr),neigh(nr),stat=info)
|
||||
if(info.ne.0) then
|
||||
info=4000
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
do i=1, nr
|
||||
ilaggr(i) = -(nr+1)
|
||||
end do
|
||||
! Note: -(nr+1) Untouched as yet
|
||||
! -i 1<=i<=nr Adjacent to aggregate i
|
||||
! i 1<=i<=nr Belonging to aggregate i
|
||||
|
||||
!
|
||||
! Phase one: group nodes together.
|
||||
! Very simple minded strategy.
|
||||
!
|
||||
naggr = 0
|
||||
nlp = 0
|
||||
do
|
||||
icnt = 0
|
||||
do i=1, nr
|
||||
if (ilaggr(i) == -(nr+1)) then
|
||||
!
|
||||
! 1. Untouched nodes are marked >0 together
|
||||
! with their neighbours
|
||||
!
|
||||
icnt = icnt + 1
|
||||
naggr = naggr + 1
|
||||
ilaggr(i) = naggr
|
||||
|
||||
call psb_neigh(a,i,neigh,n_ne,info,lev=one)
|
||||
if (info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_neigh'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
do k=1, n_ne
|
||||
j = neigh(k)
|
||||
if ((1<=j).and.(j<=nr)) then
|
||||
ilaggr(j) = naggr
|
||||
!!$ if (ilaggr(j) < 0) ilaggr(j) = naggr
|
||||
!!$ if (ilaggr(j) == -(nr+1)) ilaggr(j) = naggr
|
||||
endif
|
||||
enddo
|
||||
!
|
||||
! 2. Untouched neighbours of these nodes are marked <0.
|
||||
!
|
||||
call psb_neigh(a,i,neigh,n_ne,info,lev=two)
|
||||
if (info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_neigh'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
do n = 1, n_ne
|
||||
m = neigh(n)
|
||||
if ((1<=m).and.(m<=nr)) then
|
||||
if (ilaggr(m) == -(nr+1)) ilaggr(m) = -naggr
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
nlp = nlp + 1
|
||||
if (icnt == 0) exit
|
||||
enddo
|
||||
if (debug) then
|
||||
write(0,*) 'Check 1:',count(ilaggr == -(nr+1)),(a%ia1(i),i=a%ia2(1),a%ia2(2)-1)
|
||||
end if
|
||||
|
||||
!
|
||||
! Phase two: sweep over leftovers.
|
||||
!
|
||||
allocate(ils(naggr+10),stat=info)
|
||||
if(info.ne.0) then
|
||||
info=4000
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
do i=1, size(ils)
|
||||
ils(i) = 0
|
||||
end do
|
||||
do i=1, nr
|
||||
n = ilaggr(i)
|
||||
if (n>0) then
|
||||
if (n>naggr) then
|
||||
write(0,*) 'loc_Aggregate: n > naggr 1 ? ',n,naggr
|
||||
else
|
||||
ils(n) = ils(n) + 1
|
||||
end if
|
||||
|
||||
end if
|
||||
end do
|
||||
if (debug) then
|
||||
write(0,*) 'Phase 1: number of aggregates ',naggr
|
||||
write(0,*) 'Phase 1: nodes aggregated ',sum(ils)
|
||||
end if
|
||||
|
||||
recovery=.false.
|
||||
do i=1, nr
|
||||
if (ilaggr(i) < 0) then
|
||||
!
|
||||
! Now some silly rule to break ties:
|
||||
! Group with smallest adjacent aggregate.
|
||||
!
|
||||
isz = nr+1
|
||||
ia = -1
|
||||
|
||||
call psb_neigh(a,i,neigh,n_ne,info,lev=one)
|
||||
if (info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_neigh'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
do j=1, n_ne
|
||||
k = neigh(j)
|
||||
if ((1<=k).and.(k<=nr)) then
|
||||
n = ilaggr(k)
|
||||
if (n>0) then
|
||||
if (n>naggr) then
|
||||
write(0,*) 'loc_Aggregate: n > naggr 2? ',n,naggr
|
||||
end if
|
||||
|
||||
if (ils(n) < isz) then
|
||||
ia = n
|
||||
isz = ils(n)
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
if (ia == -1) then
|
||||
if (ilaggr(i) > -(nr+1)) then
|
||||
ilaggr(i) = abs(ilaggr(i))
|
||||
if (ilaggr(I)>naggr) then
|
||||
write(0,*) 'loc_Aggregate: n > naggr 3? ',ilaggr(i),naggr
|
||||
end if
|
||||
ils(ilaggr(i)) = ils(ilaggr(i)) + 1
|
||||
!
|
||||
! This might happen if the pattern is non symmetric.
|
||||
! Need a better handling.
|
||||
!
|
||||
recovery = .true.
|
||||
else
|
||||
write(0,*) 'Unrecoverable error !!',ilaggr(i), nr
|
||||
endif
|
||||
else
|
||||
ilaggr(i) = ia
|
||||
if (ia>naggr) then
|
||||
write(0,*) 'loc_Aggregate: n > naggr 4? ',ia,naggr
|
||||
end if
|
||||
|
||||
ils(ia) = ils(ia) + 1
|
||||
endif
|
||||
end if
|
||||
enddo
|
||||
if (recovery) then
|
||||
write(0,*) 'Had to recover from strange situation in loc_aggregate.'
|
||||
write(0,*) 'Perhaps an unsymmetric pattern?'
|
||||
endif
|
||||
if (debug) then
|
||||
write(0,*) 'Phase 2: number of aggregates ',naggr
|
||||
write(0,*) 'Phase 2: nodes aggregated ',sum(ils)
|
||||
do i=1, naggr
|
||||
write(*,*) 'Size of aggregate ',i,' :',count(ilaggr==i), ils(i)
|
||||
enddo
|
||||
write(*,*) maxval(ils(1:naggr))
|
||||
write(*,*) 'Leftovers ',count(ilaggr<0), ' in ',nlp,' loops'
|
||||
end if
|
||||
|
||||
!!$ write(0,*) 'desc_a loc_aggr 4 : ', desc_a%matrix_data(m_)
|
||||
if (count(ilaggr<0) >0) then
|
||||
write(0,*) 'Fatal error: some leftovers!!!'
|
||||
endif
|
||||
|
||||
deallocate(ils,neigh,stat=info)
|
||||
if (info/=0) then
|
||||
info=4000
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (nrow /= size(ilaggr)) then
|
||||
write(0,*) 'SOmething wrong ilaggr ',nrow,size(ilaggr)
|
||||
endif
|
||||
call psb_realloc(ncol,ilaggr,info)
|
||||
if (info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
allocate(nlaggr(np),stat=info)
|
||||
if (info/=0) then
|
||||
info=4000
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
nlaggr(:) = 0
|
||||
nlaggr(me+1) = naggr
|
||||
call psb_sum(ictxt,nlaggr(1:np))
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine psb_dgenaggrmap
|
||||
@ -0,0 +1,366 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
!*****************************************************************************
|
||||
!* *
|
||||
!* This is where the action takes place. *
|
||||
!* ASMATBLD does the setup: building the prec descriptor plus retrieving *
|
||||
!* matrix rows if needed *
|
||||
!* *
|
||||
!* *
|
||||
!* *
|
||||
!* *
|
||||
!* some open code does the renumbering *
|
||||
!* *
|
||||
!* *
|
||||
!* *
|
||||
!* *
|
||||
!*****************************************************************************
|
||||
subroutine psb_dilu_bld(a,desc_a,p,upd,info)
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
!
|
||||
! .. Scalar Arguments ..
|
||||
integer, intent(out) :: info
|
||||
! .. array Arguments ..
|
||||
type(psb_dspmat_type), intent(in), target :: a
|
||||
type(psb_dbaseprc_type), intent(inout) :: p
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
character, intent(in) :: upd
|
||||
|
||||
! .. Local Scalars ..
|
||||
integer :: i, j, jj, k, kk, m
|
||||
integer :: int_err(5)
|
||||
character :: trans, unitd
|
||||
type(psb_dspmat_type) :: blck, atmp
|
||||
real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6,mpi_wtime, t7, t8
|
||||
external mpi_wtime
|
||||
logical, parameter :: debugprt=.false., debug=.false., aggr_dump=.false.
|
||||
integer nztota, nztotb, nztmp, nzl, nnr, ir, err_act,&
|
||||
& n_row, nrow_a,n_col, nhalo, ind, iind, i1,i2,ia
|
||||
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'
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
ictxt=psb_cd_get_context(desc_a)
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
m = a%m
|
||||
if (m < 0) then
|
||||
info = 10
|
||||
int_err(1) = 1
|
||||
int_err(2) = m
|
||||
call psb_errpush(info,name,i_err=int_err)
|
||||
goto 9999
|
||||
endif
|
||||
trans = 'N'
|
||||
unitd = 'U'
|
||||
if (p%iprcparm(n_ovr_) < 0) then
|
||||
info = 11
|
||||
int_err(1) = 1
|
||||
int_err(2) = p%iprcparm(n_ovr_)
|
||||
call psb_errpush(info,name,i_err=int_err)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
call psb_nullify_sp(blck)
|
||||
call psb_nullify_sp(atmp)
|
||||
|
||||
t1= mpi_wtime()
|
||||
|
||||
if(debug) write(0,*)me,': calling psb_asmatbld',p%iprcparm(p_type_),p%iprcparm(n_ovr_)
|
||||
if (debug) call psb_barrier(ictxt)
|
||||
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_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_asmatbld'
|
||||
if (debug) call psb_barrier(ictxt)
|
||||
|
||||
if (allocated(p%av)) then
|
||||
if (size(p%av) < bp_ilu_avsz) then
|
||||
call psb_errpush(4010,name,a_err='Insufficient av size')
|
||||
goto 9999
|
||||
endif
|
||||
else
|
||||
call psb_errpush(4010,name,a_err='AV not associated')
|
||||
goto 9999
|
||||
endif
|
||||
!!$ call psb_csprt(50+me,a,head='% (A)')
|
||||
|
||||
nrow_a = psb_cd_get_local_rows(desc_a)
|
||||
nztota = psb_sp_get_nnzeros(a)
|
||||
nztotb = psb_sp_get_nnzeros(blck)
|
||||
if (debug) write(0,*)me,': out get_nnzeros',nztota
|
||||
if (debug) call psb_barrier(ictxt)
|
||||
|
||||
n_col = psb_cd_get_local_cols(desc_a)
|
||||
nhalo = n_col-nrow_a
|
||||
n_row = p%desc_data%matrix_data(psb_n_row_)
|
||||
p%av(l_pr_)%m = n_row
|
||||
p%av(l_pr_)%k = n_row
|
||||
p%av(u_pr_)%m = n_row
|
||||
p%av(u_pr_)%k = n_row
|
||||
call psb_sp_all(n_row,n_row,p%av(l_pr_),nztota+nztotb,info)
|
||||
if (info == 0) call psb_sp_all(n_row,n_row,p%av(u_pr_),nztota+nztotb,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 (allocated(p%d)) then
|
||||
if (size(p%d) < n_row) then
|
||||
deallocate(p%d)
|
||||
endif
|
||||
endif
|
||||
if (.not.allocated(p%d)) then
|
||||
allocate(p%d(n_row),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
endif
|
||||
|
||||
|
||||
if (debug) then
|
||||
write(0,*) me,'Done psb_asmatbld'
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
|
||||
|
||||
if (p%iprcparm(iren_) > 0) then
|
||||
|
||||
!
|
||||
! Here we allocate a full copy to hold local A and received BLK
|
||||
!
|
||||
|
||||
nztota = psb_sp_get_nnzeros(a)
|
||||
nztotb = psb_sp_get_nnzeros(blck)
|
||||
call psb_sp_all(atmp,nztota+nztotb,info)
|
||||
if(info/=0) then
|
||||
info=4011
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
! write(0,*) 'ILU_BLD ',nztota,nztotb,a%m
|
||||
|
||||
call psb_sp_renum(a,desc_a,blck,p,atmp,info)
|
||||
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_sp_renum'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
t3 = mpi_wtime()
|
||||
if (debugprt) then
|
||||
call psb_barrier(ictxt)
|
||||
open(40+me)
|
||||
call psb_csprt(40+me,atmp,head='% Local matrix')
|
||||
close(40+me)
|
||||
endif
|
||||
if (debug) write(0,*) me,' Factoring rows ',&
|
||||
&atmp%m,a%m,blck%m,atmp%ia2(atmp%m+1)-1
|
||||
|
||||
!
|
||||
! Ok, factor the matrix.
|
||||
!
|
||||
t5 = mpi_wtime()
|
||||
blck%m=0
|
||||
call psb_ilu_fct(atmp,p%av(l_pr_),p%av(u_pr_),p%d,info,blck=blck)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_ilu_fct'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_sp_free(atmp,info)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_sp_free'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
else if (p%iprcparm(iren_) == 0) then
|
||||
t3 = mpi_wtime()
|
||||
! This is where we have mo renumbering, thus no need
|
||||
! for ATMP
|
||||
|
||||
if (debugprt) then
|
||||
open(40+me)
|
||||
call psb_barrier(ictxt)
|
||||
call psb_csprt(40+me,a,iv=p%desc_data%loc_to_glob,&
|
||||
& head='% Local matrix')
|
||||
if (p%iprcparm(p_type_)==asm_) then
|
||||
call psb_csprt(40+me,blck,iv=p%desc_data%loc_to_glob,&
|
||||
& irs=a%m,head='% Received rows')
|
||||
endif
|
||||
close(40+me)
|
||||
endif
|
||||
|
||||
t5= mpi_wtime()
|
||||
if (debug) write(0,*) me,' Going for ilu_fct'
|
||||
if (debug) call psb_barrier(ictxt)
|
||||
call psb_ilu_fct(a,p%av(l_pr_),p%av(u_pr_),p%d,info,blck=blck)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_ilu_fct'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
if (debug) write(0,*) me,' Done dilu_fct'
|
||||
endif
|
||||
|
||||
|
||||
if (debugprt) then
|
||||
!
|
||||
! Print out the factors on file.
|
||||
!
|
||||
open(80+me)
|
||||
|
||||
call psb_csprt(80+me,p%av(l_pr_),head='% Local L factor')
|
||||
write(80+me,*) '% Diagonal: ',p%av(l_pr_)%m
|
||||
do i=1,p%av(l_pr_)%m
|
||||
write(80+me,*) i,i,p%d(i)
|
||||
enddo
|
||||
call psb_csprt(80+me,p%av(u_pr_),head='% Local U factor')
|
||||
|
||||
close(80+me)
|
||||
endif
|
||||
|
||||
!!$ call psb_csprt(60+me,a,head='% (A)')
|
||||
|
||||
|
||||
! ierr = MPE_Log_event( ifcte, 0, "st SIMPLE" )
|
||||
t6 = mpi_wtime()
|
||||
!
|
||||
! write(0,'(i3,1x,a,3(1x,g18.9))') me,'renum/factor time',t3-t2,t6-t5
|
||||
! if (me==0) write(0,'(a,3(1x,g18.9))') 'renum/factor time',t3-t2,t6-t5
|
||||
|
||||
call psb_sp_free(blck,info)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_sp_free'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (psb_sp_getifld(psb_upd_,p%av(u_pr_),info) /= psb_upd_perm_) then
|
||||
call psb_sp_trimsize(p%av(u_pr_),i1,i2,ia,info)
|
||||
if (info == 0) call psb_sp_reall(p%av(u_pr_),i1,i2,ia,info)
|
||||
endif
|
||||
|
||||
if (psb_sp_getifld(psb_upd_,p%av(l_pr_),info) /= psb_upd_perm_) then
|
||||
call psb_sp_trimsize(p%av(l_pr_),i1,i2,ia,info)
|
||||
if (info == 0) call psb_sp_reall(p%av(l_pr_),i1,i2,ia,info)
|
||||
endif
|
||||
|
||||
|
||||
if (debug) write(0,*) me,'End of ilu_bld'
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
|
||||
end subroutine psb_dilu_bld
|
||||
|
||||
|
||||
@ -0,0 +1,475 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_dilu_fct(a,l,u,d,info,blck)
|
||||
|
||||
!
|
||||
! This routine copies and factors "on the fly" from A and BLCK
|
||||
! into L/D/U.
|
||||
!
|
||||
!
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
! .. Scalar Arguments ..
|
||||
integer, intent(out) :: info
|
||||
! .. Array Arguments ..
|
||||
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(:)
|
||||
! .. Local Scalars ..
|
||||
real(kind(1.d0)) :: dia, temp
|
||||
integer :: i, j, jj, k, kk, l1, l2, ll, low1, low2,m,ma,err_act
|
||||
|
||||
type(psb_dspmat_type), pointer :: blck_
|
||||
character(len=20) :: name, ch_err
|
||||
logical, parameter :: debug=.false.
|
||||
name='psb_dcsrlu'
|
||||
info = 0
|
||||
call psb_erractionsave(err_act)
|
||||
! .. Executable Statements ..
|
||||
!
|
||||
|
||||
if (present(blck)) then
|
||||
blck_ => blck
|
||||
else
|
||||
allocate(blck_,stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_nullify_sp(blck_) ! Why do we need this? Who knows....
|
||||
call psb_sp_all(0,0,blck_,1,info)
|
||||
if(info.ne.0) then
|
||||
info=4010
|
||||
ch_err='psb_sp_all'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
blck_%m=0
|
||||
endif
|
||||
|
||||
!!$ write(0,*) 'ilu_fct: ',size(l%ia2),size(u%ia2),a%m,blck_%m
|
||||
call psb_dilu_fctint(m,a%m,a,blck_%m,blck_,&
|
||||
& d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info)
|
||||
if(info.ne.0) then
|
||||
info=4010
|
||||
ch_err='psb_dilu_fctint'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
l%infoa(1) = l1
|
||||
l%fida = 'CSR'
|
||||
l%descra = 'TLU'
|
||||
u%infoa(1) = l2
|
||||
u%fida = 'CSR'
|
||||
u%descra = 'TUU'
|
||||
l%m = m
|
||||
l%k = m
|
||||
u%m = m
|
||||
u%k = m
|
||||
if (present(blck)) then
|
||||
blck_ => null()
|
||||
else
|
||||
call psb_sp_free(blck_,info)
|
||||
if(info.ne.0) then
|
||||
info=4010
|
||||
ch_err='psb_sp_free'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
deallocate(blck_)
|
||||
endif
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
contains
|
||||
subroutine psb_dilu_fctint(m,ma,a,mb,b,&
|
||||
& d,laspk,lia1,lia2,uaspk,uia1,uia2,l1,l2,info)
|
||||
implicit none
|
||||
|
||||
type(psb_dspmat_type) :: a,b
|
||||
integer :: m,ma,mb,l1,l2,info
|
||||
integer, dimension(*) :: lia1,lia2,uia1,uia2
|
||||
real(kind(1.d0)), dimension(*) :: laspk,uaspk,d
|
||||
|
||||
integer :: i,j,k,l,low1,low2,kk,jj,ll, irb, ktrw,err_act
|
||||
real(kind(1.d0)) :: dia,temp
|
||||
integer, parameter :: nrb=16
|
||||
logical,parameter :: debug=.false.
|
||||
type(psb_dspmat_type) :: trw
|
||||
integer :: int_err(5)
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name='psb_dilu_fctint'
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=0
|
||||
call psb_erractionsave(err_act)
|
||||
call psb_nullify_sp(trw)
|
||||
trw%m=0
|
||||
trw%k=0
|
||||
if(debug) write(0,*)'LUINT Allocating TRW'
|
||||
call psb_sp_all(trw,1,info)
|
||||
if(info.ne.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,*)'LUINT Done Allocating TRW'
|
||||
lia2(1) = 1
|
||||
uia2(1) = 1
|
||||
l1=0
|
||||
l2=0
|
||||
m = ma+mb
|
||||
if(debug) write(0,*)'In DCSRLU Begin cycle',m,ma,mb
|
||||
|
||||
do i = 1, ma
|
||||
if(debug) write(0,*)'LUINT: Loop index ',i,ma
|
||||
d(i) = 0.d0
|
||||
|
||||
!
|
||||
! Here we take a fast shortcut if possible, otherwise
|
||||
! use spgtblk, slower but able (in principle) to handle
|
||||
! anything.
|
||||
!
|
||||
if (a%fida=='CSR') then
|
||||
do j = a%ia2(i), a%ia2(i+1) - 1
|
||||
k = a%ia1(j)
|
||||
! write(0,*)'KKKKK',k
|
||||
if ((k < i).and.(k >= 1)) then
|
||||
l1 = l1 + 1
|
||||
laspk(l1) = a%aspk(j)
|
||||
lia1(l1) = k
|
||||
else if (k == i) then
|
||||
d(i) = a%aspk(j)
|
||||
else if ((k > i).and.(k <= m)) then
|
||||
l2 = l2 + 1
|
||||
uaspk(l2) = a%aspk(j)
|
||||
uia1(l2) = k
|
||||
end if
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
if ((mod(i,nrb) == 1).or.(nrb==1)) then
|
||||
irb = min(ma-i+1,nrb)
|
||||
call psb_sp_getblk(i,a,trw,info,lrw=i+irb-1)
|
||||
if(info.ne.0) then
|
||||
info=4010
|
||||
ch_err='psb_sp_getblk'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
ktrw=1
|
||||
end if
|
||||
|
||||
do
|
||||
if (ktrw > trw%infoa(psb_nnz_)) exit
|
||||
if (trw%ia1(ktrw) > i) exit
|
||||
k = trw%ia2(ktrw)
|
||||
if ((k < i).and.(k >= 1)) then
|
||||
l1 = l1 + 1
|
||||
laspk(l1) = trw%aspk(ktrw)
|
||||
lia1(l1) = k
|
||||
else if (k == i) then
|
||||
d(i) = trw%aspk(ktrw)
|
||||
else if ((k > i).and.(k <= m)) then
|
||||
l2 = l2 + 1
|
||||
uaspk(l2) = trw%aspk(ktrw)
|
||||
uia1(l2) = k
|
||||
end if
|
||||
ktrw = ktrw + 1
|
||||
enddo
|
||||
|
||||
end if
|
||||
|
||||
!!$
|
||||
|
||||
lia2(i+1) = l1 + 1
|
||||
uia2(i+1) = l2 + 1
|
||||
|
||||
dia = d(i)
|
||||
do kk = lia2(i), lia2(i+1) - 1
|
||||
!
|
||||
! compute element alo(i,k) of incomplete factorization
|
||||
!
|
||||
temp = laspk(kk)
|
||||
k = lia1(kk)
|
||||
laspk(kk) = temp*d(k)
|
||||
! update the rest of row i using alo(i,k)
|
||||
low1 = kk + 1
|
||||
low2 = uia2(i)
|
||||
updateloop: do jj = uia2(k), uia2(k+1) - 1
|
||||
j = uia1(jj)
|
||||
!
|
||||
if (j < i) then
|
||||
! search alo(i,*) for matching index J
|
||||
do ll = low1, lia2(i+1) - 1
|
||||
l = lia1(ll)
|
||||
if (l > j) then
|
||||
low1 = ll
|
||||
exit
|
||||
else if (l == j) then
|
||||
laspk(ll) = laspk(ll) - temp*uaspk(jj)
|
||||
low1 = ll + 1
|
||||
cycle updateloop
|
||||
end if
|
||||
enddo
|
||||
!
|
||||
else if (j == i) then
|
||||
! j=i update diagonal
|
||||
! write(0,*)'aggiorno dia',dia,'temp',temp,'jj',jj,'u%aspk',uaspk(jj)
|
||||
dia = dia - temp*uaspk(jj)
|
||||
! write(0,*)'dia',dia,'temp',temp,'jj',jj,'aspk',uaspk(jj)
|
||||
cycle updateloop
|
||||
!
|
||||
else if (j > i) then
|
||||
! search aup(i,*) for matching index j
|
||||
do ll = low2, uia2(i+1) - 1
|
||||
l = uia1(ll)
|
||||
if (l > j) then
|
||||
low2 = ll
|
||||
exit
|
||||
else if (l == j) then
|
||||
uaspk(ll) = uaspk(ll) - temp*uaspk(jj)
|
||||
low2 = ll + 1
|
||||
cycle updateloop
|
||||
end if
|
||||
enddo
|
||||
end if
|
||||
!
|
||||
! for milu al=1.; for ilu al=0.
|
||||
! al = 1.d0
|
||||
! dia = dia - al*temp*aup(jj)
|
||||
enddo updateloop
|
||||
enddo
|
||||
!
|
||||
!
|
||||
! Non singularity
|
||||
!
|
||||
if (dabs(dia) < epstol) then
|
||||
!
|
||||
! Pivot too small: unstable factorization
|
||||
!
|
||||
info = 2
|
||||
int_err(1) = i
|
||||
write(ch_err,'(g20.10)') dia
|
||||
call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
|
||||
goto 9999
|
||||
else
|
||||
dia = 1.d0/dia
|
||||
end if
|
||||
d(i) = dia
|
||||
! write(6,*)'diag(',i,')=',d(i)
|
||||
! Scale row i of upper triangle
|
||||
do kk = uia2(i), uia2(i+1) - 1
|
||||
uaspk(kk) = uaspk(kk)*dia
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do i = ma+1, m
|
||||
d(i) = 0.d0
|
||||
|
||||
|
||||
if (b%fida=='CSR') then
|
||||
|
||||
do j = b%ia2(i-ma), b%ia2(i-ma+1) - 1
|
||||
k = b%ia1(j)
|
||||
! if (me.eq.2) write(0,*)'ecco k=',k
|
||||
if ((k < i).and.(k >= 1)) then
|
||||
l1 = l1 + 1
|
||||
laspk(l1) = b%aspk(j)
|
||||
lia1(l1) = k
|
||||
! if(me.eq.2) write(0,*)'scrivo l'
|
||||
else if (k == i) then
|
||||
d(i) = b%aspk(j)
|
||||
else if ((k > i).and.(k <= m)) then
|
||||
l2 = l2 + 1
|
||||
uaspk(l2) = b%aspk(j)
|
||||
! write(0,*)'KKKKK',k
|
||||
uia1(l2) = k
|
||||
end if
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
if ((mod((i-ma),nrb) == 1).or.(nrb==1)) then
|
||||
irb = min(m-i+1,nrb)
|
||||
call psb_sp_getblk(i-ma,b,trw,info,lrw=i-ma+irb-1)
|
||||
if(info.ne.0) then
|
||||
info=4010
|
||||
ch_err='psb_sp_getblk'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
ktrw=1
|
||||
end if
|
||||
|
||||
do
|
||||
if (ktrw > trw%infoa(psb_nnz_)) exit
|
||||
if (trw%ia1(ktrw) > i) exit
|
||||
k = trw%ia2(ktrw)
|
||||
! write(0,*)'KKKKK',k
|
||||
if ((k < i).and.(k >= 1)) then
|
||||
l1 = l1 + 1
|
||||
laspk(l1) = trw%aspk(ktrw)
|
||||
lia1(l1) = k
|
||||
else if (k == i) then
|
||||
d(i) = trw%aspk(ktrw)
|
||||
else if ((k > i).and.(k <= m)) then
|
||||
l2 = l2 + 1
|
||||
uaspk(l2) = trw%aspk(ktrw)
|
||||
uia1(l2) = k
|
||||
end if
|
||||
ktrw = ktrw + 1
|
||||
enddo
|
||||
|
||||
endif
|
||||
|
||||
|
||||
lia2(i+1) = l1 + 1
|
||||
uia2(i+1) = l2 + 1
|
||||
|
||||
dia = d(i)
|
||||
do kk = lia2(i), lia2(i+1) - 1
|
||||
!
|
||||
! compute element alo(i,k) of incomplete factorization
|
||||
!
|
||||
temp = laspk(kk)
|
||||
k = lia1(kk)
|
||||
laspk(kk) = temp*d(k)
|
||||
! update the rest of row i using alo(i,k)
|
||||
low1 = kk + 1
|
||||
low2 = uia2(i)
|
||||
updateloopb: do jj = uia2(k), uia2(k+1) - 1
|
||||
j = uia1(jj)
|
||||
!
|
||||
if (j < i) then
|
||||
! search alo(i,*) for matching index J
|
||||
do ll = low1, lia2(i+1) - 1
|
||||
l = lia1(ll)
|
||||
if (l > j) then
|
||||
low1 = ll
|
||||
exit
|
||||
else if (l == j) then
|
||||
laspk(ll) = laspk(ll) - temp*uaspk(jj)
|
||||
low1 = ll + 1
|
||||
cycle updateloopb
|
||||
end if
|
||||
enddo
|
||||
!
|
||||
else if (j == i) then
|
||||
! j=i update diagonal
|
||||
dia = dia - temp*uaspk(jj)
|
||||
cycle updateloopb
|
||||
!
|
||||
else if (j > i) then
|
||||
! search aup(i,*) for matching index j
|
||||
do ll = low2, uia2(i+1) - 1
|
||||
l = uia1(ll)
|
||||
if (l > j) then
|
||||
low2 = ll
|
||||
exit
|
||||
else if (l == j) then
|
||||
uaspk(ll) = uaspk(ll) - temp*uaspk(jj)
|
||||
low2 = ll + 1
|
||||
cycle updateloopb
|
||||
end if
|
||||
enddo
|
||||
end if
|
||||
!
|
||||
! for milu al=1.; for ilu al=0.
|
||||
! al = 1.d0
|
||||
! dia = dia - al*temp*aup(jj)
|
||||
enddo updateloopb
|
||||
enddo
|
||||
!
|
||||
!
|
||||
! Non singularity
|
||||
!
|
||||
if (dabs(dia) < epstol) then
|
||||
!
|
||||
! Pivot too small: unstable factorization
|
||||
!
|
||||
int_err(1) = i
|
||||
write(ch_err,'(g20.10)') dia
|
||||
info = 2
|
||||
call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
|
||||
goto 9999
|
||||
else
|
||||
dia = 1.d0/dia
|
||||
end if
|
||||
d(i) = dia
|
||||
! Scale row i of upper triangle
|
||||
do kk = uia2(i), uia2(i+1) - 1
|
||||
uaspk(kk) = uaspk(kk)*dia
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call psb_sp_free(trw,info)
|
||||
if(info.ne.0) then
|
||||
info=4010
|
||||
ch_err='psb_sp_free'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
if(debug) write(0,*)'Leaving ilu_fct'
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
end subroutine psb_dilu_fctint
|
||||
end subroutine psb_dilu_fct
|
||||
@ -0,0 +1,782 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
|
||||
!
|
||||
! Compute Y <- beta*Y + alpha*K^-1 X
|
||||
! where K is a multilevel preconditioner stored in baseprecv
|
||||
!
|
||||
! cfr.: Smith, Biorstad & Gropp
|
||||
! Domain Decomposition
|
||||
! Cambridge Univ. Press
|
||||
!
|
||||
! To each level I there corresponds a matrix A(I) and a preconditioner K(I)
|
||||
!
|
||||
! A notational difference: in the DD reference above the preconditioner for
|
||||
! a given level K(I) is written out as a sum over the subdomains
|
||||
!
|
||||
! SUM_k(R_k^T A_k R_k)
|
||||
!
|
||||
! whereas in this code the sum is implicit in the parallelization,
|
||||
! i.e. each process takes care of one subdomain, and for each level we have
|
||||
! as many subdomains as there are processes (except for the coarsest level where
|
||||
! we might have a replicated index space). Thus the sum apparently disappears
|
||||
! from our code, but only apparently, because it is implicit in the call
|
||||
! to psb_baseprc_aply.
|
||||
!
|
||||
! A bit of description of the baseprecv(:) data structure:
|
||||
! 1. Number of levels = NLEV = size(baseprecv(:))
|
||||
! 2. baseprecv(ilev)%av(:) sparse matrices needed for the current level.
|
||||
! Includes:
|
||||
! 2.1.: baseprecv(ilev)%av(l_pr_) L factor of ILU preconditioners
|
||||
! 2.2.: baseprecv(ilev)%av(u_pr_) U factor of ILU preconditioners
|
||||
! 2.3.: baseprecv(ilev)%av(ap_nd_) Off-diagonal part of A for Jacobi sweeps
|
||||
! 2.4.: baseprecv(ilev)%av(ac_) Aggregated matrix of level ILEV
|
||||
! 2.5.: baseprecv(ilev)%av(sm_pr_t_) Smoother prolongator transpose; maps vectors
|
||||
! (ilev-1) ---> (ilev)
|
||||
! 2.6.: baseprecv(ilev)%av(sm_pr_) Smoother prolongator; maps vectors
|
||||
! (ilev) ---> (ilev-1)
|
||||
! Shouldn't we keep just one of them and handle transpose in the sparse BLAS? maybe
|
||||
!
|
||||
! 3. baseprecv(ilev)%desc_data comm descriptor for level ILEV
|
||||
! 4. baseprecv(ilev)%base_a Pointer (really a pointer!) to the base matrix
|
||||
! of the current level, i.e.: if ILEV=1 then A
|
||||
! else the aggregated matrix av(ac_); so we have
|
||||
! a unified treatment of residuals. Need this to
|
||||
! avoid passing explicitly matrix A to the
|
||||
! outer prec. routine
|
||||
! 5. baseprecv(ilev)%mlia The aggregation map from (ilev-1)-->(ilev)
|
||||
! if no smoother, it is used instead of sm_pr_
|
||||
! 6. baseprecv(ilev)%nlaggr Number of aggregates on the various procs.
|
||||
!
|
||||
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
|
||||
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
|
||||
|
||||
|
||||
|
||||
! Local variables
|
||||
integer :: n_row,n_col
|
||||
character ::diagl, diagu
|
||||
integer :: ictxt,np,me,i, isz, nrg,nr2l,err_act, iptype, int_err(5)
|
||||
real(kind(1.d0)) :: omega
|
||||
real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime
|
||||
logical, parameter :: debug=.false., debugprt=.false.
|
||||
integer :: ismth, nlev, ilev
|
||||
external mpi_wtime
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
type psb_mlprec_wrk_type
|
||||
real(kind(1.d0)), allocatable :: tx(:), ty(:), x2l(:), y2l(:)
|
||||
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)
|
||||
|
||||
|
||||
ictxt=desc_data%matrix_data(psb_ctxt_)
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
nlev = size(baseprecv)
|
||||
allocate(mlprec_wrk(nlev),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
select case(baseprecv(2)%iprcparm(ml_type_))
|
||||
|
||||
case(no_ml_)
|
||||
! Should not really get here.
|
||||
call psb_errpush(4010,name,a_err='no_ml_ in mlprc_aply?')
|
||||
goto 9999
|
||||
|
||||
|
||||
case(add_ml_prec_)
|
||||
|
||||
|
||||
!
|
||||
! Additive is very simple.
|
||||
! 1. X(1) = Xext
|
||||
! 2. DO ILEV=2,NLEV
|
||||
! X(ILEV) = AV(PR_SM_T_)*X(ILEV-1)
|
||||
! Y(ILEV) = (K(ILEV)**(-1))*X(ILEV)
|
||||
! 3. DO ILEV=NLEV-1,1,-1
|
||||
! Y(ILEV) = AV(PR_SM_)*Y(ILEV+1)
|
||||
! 4. Yext = beta*Yext + alpha*Y(1)
|
||||
!
|
||||
! Note: level numbering reversed wrt ref. DD, i.e.
|
||||
! 1..NLEV <=> (j) <-> 0
|
||||
|
||||
|
||||
call psb_baseprc_aply(alpha,baseprecv(1),x,beta,y,&
|
||||
& baseprecv(1)%base_desc,trans,work,info)
|
||||
if(info /=0) goto 9999
|
||||
allocate(mlprec_wrk(1)%x2l(size(x)),mlprec_wrk(1)%y2l(size(y)))
|
||||
mlprec_wrk(1)%x2l(:) = x(:)
|
||||
|
||||
|
||||
do ilev = 2, nlev
|
||||
n_row = baseprecv(ilev-1)%base_desc%matrix_data(psb_n_row_)
|
||||
n_col = baseprecv(ilev-1)%desc_data%matrix_data(psb_n_col_)
|
||||
nr2l = baseprecv(ilev)%desc_data%matrix_data(psb_n_col_)
|
||||
nrg = baseprecv(ilev)%desc_data%matrix_data(psb_n_row_)
|
||||
allocate(mlprec_wrk(ilev)%x2l(nr2l),mlprec_wrk(ilev)%y2l(nr2l),&
|
||||
& mlprec_wrk(ilev)%tx(max(n_row,n_col)),&
|
||||
& mlprec_wrk(ilev)%ty(max(n_row,n_col)), stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
mlprec_wrk(ilev)%x2l(:) = dzero
|
||||
mlprec_wrk(ilev)%y2l(:) = dzero
|
||||
mlprec_wrk(ilev)%tx(1:n_row) = mlprec_wrk(ilev-1)%x2l(1:n_row)
|
||||
mlprec_wrk(ilev)%tx(n_row+1:max(n_row,n_col)) = dzero
|
||||
mlprec_wrk(ilev)%ty(:) = dzero
|
||||
|
||||
ismth=baseprecv(ilev)%iprcparm(smth_kind_)
|
||||
|
||||
if (ismth /= no_smth_) then
|
||||
!
|
||||
! Smoothed aggregation
|
||||
!
|
||||
|
||||
|
||||
if (baseprecv(ilev)%iprcparm(glb_smth_) >0) then
|
||||
call psb_halo(mlprec_wrk(ilev-1)%x2l,baseprecv(ilev-1)%base_desc,&
|
||||
& info,work=work)
|
||||
if(info /=0) goto 9999
|
||||
else
|
||||
mlprec_wrk(ilev-1)%x2l(n_row+1:max(n_row,n_col)) = dzero
|
||||
end if
|
||||
|
||||
call psb_csmm(done,baseprecv(ilev)%av(sm_pr_t_),mlprec_wrk(ilev-1)%x2l,&
|
||||
& dzero,mlprec_wrk(ilev)%x2l,info)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
else
|
||||
!
|
||||
! Raw aggregation, may take shortcut
|
||||
!
|
||||
do i=1,n_row
|
||||
mlprec_wrk(ilev)%x2l(baseprecv(ilev)%mlia(i)) = &
|
||||
& mlprec_wrk(ilev)%x2l(baseprecv(ilev)%mlia(i)) + &
|
||||
& mlprec_wrk(ilev-1)%x2l(i)
|
||||
end do
|
||||
|
||||
end if
|
||||
|
||||
if (baseprecv(ilev)%iprcparm(coarse_mat_)==mat_repl_) Then
|
||||
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nrg))
|
||||
else if (baseprecv(ilev)%iprcparm(coarse_mat_) /= mat_distr_) Then
|
||||
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',&
|
||||
& baseprecv(ilev)%iprcparm(coarse_mat_)
|
||||
endif
|
||||
|
||||
call psb_baseprc_aply(done,baseprecv(ilev),&
|
||||
& mlprec_wrk(ilev)%x2l,dzero,mlprec_wrk(ilev)%y2l,&
|
||||
& baseprecv(ilev)%desc_data, 'N',work,info)
|
||||
|
||||
enddo
|
||||
|
||||
do ilev =nlev,2,-1
|
||||
|
||||
ismth=baseprecv(ilev)%iprcparm(smth_kind_)
|
||||
n_row = baseprecv(ilev-1)%base_desc%matrix_data(psb_n_row_)
|
||||
n_col = baseprecv(ilev-1)%desc_data%matrix_data(psb_n_col_)
|
||||
nr2l = baseprecv(ilev)%desc_data%matrix_data(psb_n_col_)
|
||||
nrg = baseprecv(ilev)%desc_data%matrix_data(psb_n_row_)
|
||||
|
||||
if (ismth /= no_smth_) then
|
||||
|
||||
call psb_csmm(done,baseprecv(ilev)%av(sm_pr_),mlprec_wrk(ilev)%y2l,&
|
||||
& done,mlprec_wrk(ilev-1)%y2l,info)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
else
|
||||
|
||||
do i=1, n_row
|
||||
mlprec_wrk(ilev-1)%y2l(i) = mlprec_wrk(ilev-1)%y2l(i) + &
|
||||
& mlprec_wrk(ilev)%y2l(baseprecv(ilev)%mlia(i))
|
||||
enddo
|
||||
|
||||
end if
|
||||
end do
|
||||
|
||||
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,done,y,baseprecv(1)%base_desc,info)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
|
||||
case(mult_ml_prec_)
|
||||
|
||||
!
|
||||
! Multiplicative multilevel
|
||||
! Pre/post smoothing versions.
|
||||
!
|
||||
|
||||
select case(baseprecv(2)%iprcparm(smth_pos_))
|
||||
|
||||
case(post_smooth_)
|
||||
|
||||
|
||||
!
|
||||
! Post smoothing.
|
||||
! 1. X(1) = Xext
|
||||
! 2. DO ILEV=2, NLEV :: X(ILEV) = AV(PR_SM_T_,ILEV)*X(ILEV-1)
|
||||
! 3. Y(NLEV) = (K(NLEV)**(-1))*X(NLEV)
|
||||
! 4. DO ILEV=NLEV-1,1,-1
|
||||
! Y(ILEV) = AV(PR_SM_,ILEV+1)*Y(ILEV+1)
|
||||
! Y(ILEV) = Y(ILEV) + (K(ILEV)**(-1))*(X(ILEV)-A(ILEV)*Y(ILEV))
|
||||
!
|
||||
! 5. Yext = beta*Yext + alpha*Y(1)
|
||||
!
|
||||
! Note: level numbering reversed wrt ref. DD, i.e.
|
||||
! 1..NLEV <=> (j) <-> 0
|
||||
!
|
||||
! Also: post smoothing in the ref. DD is only presented for NLEV=2.
|
||||
!
|
||||
!
|
||||
|
||||
n_col = desc_data%matrix_data(psb_n_col_)
|
||||
nr2l = baseprecv(1)%desc_data%matrix_data(psb_n_col_)
|
||||
|
||||
allocate(mlprec_wrk(1)%x2l(nr2l),mlprec_wrk(1)%y2l(nr2l), &
|
||||
& mlprec_wrk(1)%tx(nr2l), stat=info)
|
||||
mlprec_wrk(1)%x2l(:) = dzero
|
||||
mlprec_wrk(1)%y2l(:) = dzero
|
||||
mlprec_wrk(1)%tx(:) = dzero
|
||||
|
||||
call psb_geaxpby(done,x,dzero,mlprec_wrk(1)%tx,&
|
||||
& baseprecv(1)%base_desc,info)
|
||||
call psb_geaxpby(done,x,dzero,mlprec_wrk(1)%x2l,&
|
||||
& baseprecv(1)%base_desc,info)
|
||||
|
||||
do ilev=2, nlev
|
||||
n_row = baseprecv(ilev-1)%base_desc%matrix_data(psb_n_row_)
|
||||
n_col = baseprecv(ilev-1)%desc_data%matrix_data(psb_n_col_)
|
||||
nr2l = baseprecv(ilev)%desc_data%matrix_data(psb_n_col_)
|
||||
nrg = baseprecv(ilev)%desc_data%matrix_data(psb_n_row_)
|
||||
ismth = baseprecv(ilev)%iprcparm(smth_kind_)
|
||||
|
||||
allocate(mlprec_wrk(ilev)%tx(nr2l),mlprec_wrk(ilev)%y2l(nr2l),&
|
||||
& mlprec_wrk(ilev)%x2l(nr2l), stat=info)
|
||||
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
mlprec_wrk(ilev)%x2l(:) = dzero
|
||||
mlprec_wrk(ilev)%y2l(:) = dzero
|
||||
mlprec_wrk(ilev)%tx(:) = dzero
|
||||
if (ismth /= no_smth_) then
|
||||
!
|
||||
! Smoothed aggregation
|
||||
!
|
||||
if (baseprecv(ilev)%iprcparm(glb_smth_) >0) then
|
||||
call psb_halo(mlprec_wrk(ilev-1)%x2l,&
|
||||
& baseprecv(ilev-1)%base_desc,info,work=work)
|
||||
if(info /=0) goto 9999
|
||||
else
|
||||
mlprec_wrk(ilev-1)%x2l(n_row+1:max(n_row,n_col)) = dzero
|
||||
end if
|
||||
|
||||
call psb_csmm(done,baseprecv(ilev)%av(sm_pr_t_),mlprec_wrk(ilev-1)%x2l, &
|
||||
& dzero,mlprec_wrk(ilev)%x2l,info)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
else
|
||||
!
|
||||
! Raw aggregation, may take shortcut
|
||||
!
|
||||
do i=1,n_row
|
||||
mlprec_wrk(ilev)%x2l(baseprecv(ilev)%mlia(i)) = &
|
||||
& mlprec_wrk(ilev)%x2l(baseprecv(ilev)%mlia(i)) + &
|
||||
& mlprec_wrk(ilev-1)%x2l(i)
|
||||
end do
|
||||
end if
|
||||
|
||||
if (baseprecv(ilev)%iprcparm(coarse_mat_)==mat_repl_) Then
|
||||
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nrg))
|
||||
else if (baseprecv(ilev)%iprcparm(coarse_mat_) /= mat_distr_) Then
|
||||
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',&
|
||||
& baseprecv(ilev)%iprcparm(coarse_mat_)
|
||||
endif
|
||||
call psb_geaxpby(done,mlprec_wrk(ilev)%x2l,dzero,mlprec_wrk(ilev)%tx,&
|
||||
& baseprecv(ilev)%base_desc,info)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
enddo
|
||||
|
||||
|
||||
call psb_baseprc_aply(done,baseprecv(nlev),mlprec_wrk(nlev)%x2l, &
|
||||
& dzero, mlprec_wrk(nlev)%y2l,baseprecv(nlev)%desc_data,'N',work,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
|
||||
do ilev=nlev-1, 1, -1
|
||||
ismth = baseprecv(ilev+1)%iprcparm(smth_kind_)
|
||||
if (ismth /= no_smth_) then
|
||||
if (ismth == smth_omg_) &
|
||||
& call psb_halo(mlprec_wrk(ilev+1)%y2l,baseprecv(ilev+1)%desc_data,&
|
||||
& info,work=work)
|
||||
call psb_csmm(done,baseprecv(ilev+1)%av(sm_pr_),mlprec_wrk(ilev+1)%y2l,&
|
||||
& dzero,mlprec_wrk(ilev)%y2l,info)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
else
|
||||
n_row = baseprecv(ilev)%base_desc%matrix_data(psb_n_row_)
|
||||
mlprec_wrk(ilev)%y2l(:) = dzero
|
||||
do i=1, n_row
|
||||
mlprec_wrk(ilev)%y2l(i) = mlprec_wrk(ilev)%y2l(i) + &
|
||||
& mlprec_wrk(ilev+1)%y2l(baseprecv(ilev+1)%mlia(i))
|
||||
enddo
|
||||
|
||||
end if
|
||||
|
||||
call psb_spmm(-done,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
|
||||
& done,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,work=work)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
call psb_baseprc_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
|
||||
& done,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
enddo
|
||||
|
||||
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,baseprecv(1)%base_desc,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
|
||||
case(pre_smooth_)
|
||||
|
||||
|
||||
!
|
||||
! Pre smoothing.
|
||||
! 1. X(1) = Xext
|
||||
! 2. Y(1) = (K(1)**(-1))*X(1)
|
||||
! 3. TX(1) = X(1) - A(1)*Y(1)
|
||||
! 4. DO ILEV=2, NLEV
|
||||
! X(ILEV) = AV(PR_SM_T_,ILEV)*TX(ILEV-1)
|
||||
! Y(ILEV) = (K(ILEV)**(-1))*X(ILEV)
|
||||
! TX(ILEV) = (X(ILEV)-A(ILEV)*Y(ILEV))
|
||||
! 5. DO ILEV=NLEV-1,1,-1
|
||||
! Y(ILEV) = Y(ILEV) + AV(PR_SM_,ILEV+1)*Y(ILEV+1)
|
||||
! 6. Yext = beta*Yext + alpha*Y(1)
|
||||
!
|
||||
! Note: level numbering reversed wrt ref. DD, i.e.
|
||||
! 1..NLEV <=> (j) <-> 0
|
||||
!
|
||||
!
|
||||
|
||||
n_col = desc_data%matrix_data(psb_n_col_)
|
||||
nr2l = baseprecv(1)%desc_data%matrix_data(psb_n_col_)
|
||||
|
||||
allocate(mlprec_wrk(1)%x2l(nr2l),mlprec_wrk(1)%y2l(nr2l), &
|
||||
& mlprec_wrk(1)%tx(nr2l), stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
mlprec_wrk(1)%y2l(:) = dzero
|
||||
mlprec_wrk(1)%x2l(:) = x
|
||||
|
||||
call psb_baseprc_aply(done,baseprecv(1),mlprec_wrk(1)%x2l,&
|
||||
& dzero,mlprec_wrk(1)%y2l,&
|
||||
& baseprecv(1)%base_desc,&
|
||||
& trans,work,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
mlprec_wrk(1)%tx = mlprec_wrk(1)%x2l
|
||||
|
||||
call psb_spmm(-done,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,&
|
||||
& done,mlprec_wrk(1)%tx,baseprecv(1)%base_desc,info,work=work)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
do ilev = 2, nlev
|
||||
n_row = baseprecv(ilev-1)%base_desc%matrix_data(psb_n_row_)
|
||||
n_col = baseprecv(ilev-1)%desc_data%matrix_data(psb_n_col_)
|
||||
nr2l = baseprecv(ilev)%desc_data%matrix_data(psb_n_col_)
|
||||
nrg = baseprecv(ilev)%desc_data%matrix_data(psb_n_row_)
|
||||
ismth = baseprecv(ilev)%iprcparm(smth_kind_)
|
||||
allocate(mlprec_wrk(ilev)%tx(nr2l),mlprec_wrk(ilev)%y2l(nr2l),&
|
||||
& mlprec_wrk(ilev)%x2l(nr2l), stat=info)
|
||||
|
||||
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
mlprec_wrk(ilev)%x2l(:) = dzero
|
||||
mlprec_wrk(ilev)%y2l(:) = dzero
|
||||
mlprec_wrk(ilev)%tx(:) = dzero
|
||||
|
||||
|
||||
if (ismth /= no_smth_) then
|
||||
!
|
||||
!Smoothed Aggregation
|
||||
!
|
||||
if (baseprecv(ilev)%iprcparm(glb_smth_) >0) then
|
||||
|
||||
call psb_halo(mlprec_wrk(ilev-1)%tx,baseprecv(ilev-1)%base_desc,&
|
||||
& info,work=work)
|
||||
if(info /=0) goto 9999
|
||||
else
|
||||
mlprec_wrk(ilev-1)%tx(n_row+1:max(n_row,n_col)) = dzero
|
||||
end if
|
||||
|
||||
call psb_csmm(done,baseprecv(ilev)%av(sm_pr_t_),mlprec_wrk(ilev-1)%tx,dzero,&
|
||||
& mlprec_wrk(ilev)%x2l,info)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
else
|
||||
!
|
||||
! Raw aggregation, may take shortcuts
|
||||
!
|
||||
mlprec_wrk(ilev)%x2l = dzero
|
||||
do i=1,n_row
|
||||
mlprec_wrk(ilev)%x2l(baseprecv(ilev)%mlia(i)) = &
|
||||
& mlprec_wrk(ilev)%x2l(baseprecv(ilev)%mlia(i)) + &
|
||||
& mlprec_wrk(ilev-1)%tx(i)
|
||||
end do
|
||||
end if
|
||||
|
||||
if (baseprecv(ilev)%iprcparm(coarse_mat_)==mat_repl_) then
|
||||
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nrg))
|
||||
else if (baseprecv(ilev)%iprcparm(coarse_mat_) /= mat_distr_) then
|
||||
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',&
|
||||
& baseprecv(ilev)%iprcparm(coarse_mat_)
|
||||
endif
|
||||
|
||||
|
||||
call psb_baseprc_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%x2l,&
|
||||
& dzero,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%desc_data, 'N',work,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
if(ilev < nlev) then
|
||||
mlprec_wrk(ilev)%tx = mlprec_wrk(ilev)%x2l
|
||||
call psb_spmm(-done,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
|
||||
& done,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,work=work)
|
||||
if(info /=0) goto 9999
|
||||
endif
|
||||
|
||||
enddo
|
||||
|
||||
do ilev = nlev-1, 1, -1
|
||||
|
||||
ismth=baseprecv(ilev+1)%iprcparm(smth_kind_)
|
||||
|
||||
if (ismth /= no_smth_) then
|
||||
|
||||
if (ismth == smth_omg_) &
|
||||
& call psb_halo(mlprec_wrk(ilev+1)%y2l,&
|
||||
& baseprecv(ilev+1)%desc_data,info,work=work)
|
||||
call psb_csmm(done,baseprecv(ilev+1)%av(sm_pr_),mlprec_wrk(ilev+1)%y2l,&
|
||||
& done,mlprec_wrk(ilev)%y2l,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
else
|
||||
|
||||
n_row = baseprecv(ilev+1)%base_desc%matrix_data(psb_n_row_)
|
||||
do i=1, n_row
|
||||
mlprec_wrk(ilev)%y2l(i) = mlprec_wrk(ilev)%y2l(i) + &
|
||||
& mlprec_wrk(ilev+1)%y2l(baseprecv(ilev+1)%mlia(i))
|
||||
enddo
|
||||
|
||||
end if
|
||||
|
||||
enddo
|
||||
|
||||
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,&
|
||||
& baseprecv(1)%base_desc,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
|
||||
|
||||
case(smooth_both_)
|
||||
|
||||
!
|
||||
! Symmetrized smoothing.
|
||||
! 1. X(1) = Xext
|
||||
! 2. Y(1) = (K(1)**(-1))*X(1)
|
||||
! 3. TX(1) = X(1) - A(1)*Y(1)
|
||||
! 4. DO ILEV=2, NLEV
|
||||
! X(ILEV) = AV(PR_SM_T_,ILEV)*TX(ILEV-1)
|
||||
! Y(ILEV) = (K(ILEV)**(-1))*X(ILEV)
|
||||
! TX(ILEV) = (X(ILEV)-A(ILEV)*Y(ILEV))
|
||||
! 5. DO ILEV=NLEV-1,1,-1
|
||||
! Y(ILEV) = Y(ILEV) + AV(PR_SM_,ILEV+1)*Y(ILEV+1)
|
||||
! Y(ILEV) = Y(ILEV) + (K(ILEV)**(-1))*(X(ILEV)-A(ILEV)*Y(ILEV))
|
||||
! 6. Yext = beta*Yext + alpha*Y(1)
|
||||
!
|
||||
! Note: level numbering reversed wrt ref. DD, i.e.
|
||||
! 1..NLEV <=> (j) <-> 0
|
||||
!
|
||||
!
|
||||
n_col = desc_data%matrix_data(psb_n_col_)
|
||||
nr2l = baseprecv(1)%desc_data%matrix_data(psb_n_col_)
|
||||
|
||||
allocate(mlprec_wrk(1)%x2l(nr2l),mlprec_wrk(1)%y2l(nr2l), &
|
||||
& mlprec_wrk(1)%ty(nr2l), mlprec_wrk(1)%tx(nr2l), stat=info)
|
||||
|
||||
mlprec_wrk(1)%x2l(:) = dzero
|
||||
mlprec_wrk(1)%y2l(:) = dzero
|
||||
mlprec_wrk(1)%tx(:) = dzero
|
||||
mlprec_wrk(1)%ty(:) = dzero
|
||||
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_geaxpby(done,x,dzero,mlprec_wrk(1)%x2l,&
|
||||
& baseprecv(1)%base_desc,info)
|
||||
call psb_geaxpby(done,x,dzero,mlprec_wrk(1)%tx,&
|
||||
& baseprecv(1)%base_desc,info)
|
||||
|
||||
call psb_baseprc_aply(done,baseprecv(1),mlprec_wrk(1)%x2l,&
|
||||
& dzero,mlprec_wrk(1)%y2l,&
|
||||
& baseprecv(1)%base_desc,&
|
||||
& trans,work,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
mlprec_wrk(1)%ty = mlprec_wrk(1)%x2l
|
||||
|
||||
call psb_spmm(-done,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,&
|
||||
& done,mlprec_wrk(1)%ty,baseprecv(1)%base_desc,info,work=work)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
do ilev = 2, nlev
|
||||
n_row = baseprecv(ilev-1)%base_desc%matrix_data(psb_n_row_)
|
||||
n_col = baseprecv(ilev-1)%desc_data%matrix_data(psb_n_col_)
|
||||
nr2l = baseprecv(ilev)%desc_data%matrix_data(psb_n_col_)
|
||||
nrg = baseprecv(ilev)%desc_data%matrix_data(psb_n_row_)
|
||||
ismth=baseprecv(ilev)%iprcparm(smth_kind_)
|
||||
allocate(mlprec_wrk(ilev)%ty(nr2l),mlprec_wrk(ilev)%y2l(nr2l),&
|
||||
& mlprec_wrk(ilev)%x2l(nr2l), stat=info)
|
||||
|
||||
mlprec_wrk(ilev)%x2l(:) = dzero
|
||||
mlprec_wrk(ilev)%y2l(:) = dzero
|
||||
mlprec_wrk(ilev)%tx(:) = dzero
|
||||
mlprec_wrk(ilev)%ty(:) = dzero
|
||||
|
||||
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
if (ismth /= no_smth_) then
|
||||
!
|
||||
!Smoothed Aggregation
|
||||
!
|
||||
if (baseprecv(ilev)%iprcparm(glb_smth_) >0) then
|
||||
|
||||
call psb_halo(mlprec_wrk(ilev-1)%ty,baseprecv(ilev-1)%base_desc,&
|
||||
& info,work=work)
|
||||
if(info /=0) goto 9999
|
||||
else
|
||||
mlprec_wrk(ilev-1)%ty(n_row+1:max(n_row,n_col)) = dzero
|
||||
end if
|
||||
|
||||
call psb_csmm(done,baseprecv(ilev)%av(sm_pr_t_),mlprec_wrk(ilev-1)%ty,dzero,&
|
||||
& mlprec_wrk(ilev)%x2l,info)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
else
|
||||
!
|
||||
! Raw aggregation, may take shortcuts
|
||||
!
|
||||
mlprec_wrk(ilev)%x2l = dzero
|
||||
do i=1,n_row
|
||||
mlprec_wrk(ilev)%x2l(baseprecv(ilev)%mlia(i)) = &
|
||||
& mlprec_wrk(ilev)%x2l(baseprecv(ilev)%mlia(i)) + &
|
||||
& mlprec_wrk(ilev-1)%ty(i)
|
||||
end do
|
||||
end if
|
||||
|
||||
if (baseprecv(ilev)%iprcparm(coarse_mat_)==mat_repl_) then
|
||||
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nrg))
|
||||
else if (baseprecv(ilev)%iprcparm(coarse_mat_) /= mat_distr_) then
|
||||
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',&
|
||||
& baseprecv(ilev)%iprcparm(coarse_mat_)
|
||||
endif
|
||||
|
||||
call psb_geaxpby(done,mlprec_wrk(ilev)%x2l,dzero,mlprec_wrk(ilev)%tx,&
|
||||
& baseprecv(ilev)%base_desc,info)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
call psb_baseprc_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%x2l,&
|
||||
& dzero,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%desc_data, 'N',work,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
if(ilev < nlev) then
|
||||
mlprec_wrk(ilev)%ty = mlprec_wrk(ilev)%x2l
|
||||
call psb_spmm(-done,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
|
||||
& done,mlprec_wrk(ilev)%ty,baseprecv(ilev)%base_desc,info,work=work)
|
||||
if(info /=0) goto 9999
|
||||
endif
|
||||
|
||||
enddo
|
||||
|
||||
|
||||
do ilev=nlev-1, 1, -1
|
||||
|
||||
ismth=baseprecv(ilev+1)%iprcparm(smth_kind_)
|
||||
if (ismth /= no_smth_) then
|
||||
if (ismth == smth_omg_) &
|
||||
& call psb_halo(mlprec_wrk(ilev+1)%y2l,baseprecv(ilev+1)%desc_data,&
|
||||
& info,work=work)
|
||||
call psb_csmm(done,baseprecv(ilev+1)%av(sm_pr_),mlprec_wrk(ilev+1)%y2l,&
|
||||
& done,mlprec_wrk(ilev)%y2l,info)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
else
|
||||
n_row = baseprecv(ilev)%base_desc%matrix_data(psb_n_row_)
|
||||
do i=1, n_row
|
||||
mlprec_wrk(ilev)%y2l(i) = mlprec_wrk(ilev)%y2l(i) + &
|
||||
& mlprec_wrk(ilev+1)%y2l(baseprecv(ilev+1)%mlia(i))
|
||||
enddo
|
||||
|
||||
end if
|
||||
|
||||
call psb_spmm(-done,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
|
||||
& done,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,work=work)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
call psb_baseprc_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
|
||||
& done,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
enddo
|
||||
|
||||
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,&
|
||||
& baseprecv(1)%base_desc,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
case default
|
||||
|
||||
call psb_errpush(4013,name,a_err='wrong smooth_pos',&
|
||||
& i_Err=(/baseprecv(2)%iprcparm(smth_pos_),0,0,0,0/))
|
||||
goto 9999
|
||||
|
||||
end select
|
||||
|
||||
case default
|
||||
call psb_errpush(4013,name,a_err='wrong mltype',&
|
||||
& i_Err=(/baseprecv(2)%iprcparm(ml_type_),0,0,0,0/))
|
||||
goto 9999
|
||||
|
||||
end select
|
||||
|
||||
deallocate(mlprec_wrk)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_errpush(info,name)
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
!!$contains
|
||||
!!$ subroutine mlprec_wrk_free(wrk)
|
||||
!!$ type(psb_mlprec_wrk_type) :: wrk(:)
|
||||
!!$ ! This will not be needed when we have allocatables, as
|
||||
!!$ ! it is sufficient to deallocate the container, and
|
||||
!!$ ! the compiler is supposed to recursively deallocate the
|
||||
!!$ ! various components.
|
||||
!!$ integer i
|
||||
!!$
|
||||
!!$ do i=1, size(wrk)
|
||||
!!$ if (associated(wrk(i)%tx)) deallocate(wrk(i)%tx)
|
||||
!!$ if (associated(wrk(i)%ty)) deallocate(wrk(i)%ty)
|
||||
!!$ if (associated(wrk(i)%x2l)) deallocate(wrk(i)%x2l)
|
||||
!!$ if (associated(wrk(i)%y2l)) deallocate(wrk(i)%y2l)
|
||||
!!$ if (associated(wrk(i)%b2l)) deallocate(wrk(i)%b2l)
|
||||
!!$ if (associated(wrk(i)%tty)) deallocate(wrk(i)%tty)
|
||||
!!$ end do
|
||||
!!$ end subroutine mlprec_wrk_free
|
||||
|
||||
end subroutine psb_dmlprc_aply
|
||||
|
||||
@ -0,0 +1,198 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_dmlprc_bld(a,desc_a,p,info)
|
||||
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
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
|
||||
|
||||
type(psb_desc_type) :: desc_ac
|
||||
|
||||
integer :: i, nrg, nzg, err_act,k
|
||||
character(len=20) :: name, ch_err
|
||||
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
|
||||
|
||||
name='psb_mlprec_bld'
|
||||
if (psb_get_errstatus().ne.0) return
|
||||
info = 0
|
||||
ictxt = psb_cd_get_context(desc_a)
|
||||
call psb_info(ictxt,me,np)
|
||||
call psb_erractionsave(err_act)
|
||||
call psb_nullify_sp(ac)
|
||||
|
||||
|
||||
if (.not.allocated(p%iprcparm)) then
|
||||
info = 2222
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
call psb_check_def(p%iprcparm(ml_type_),'Multilevel type',&
|
||||
& mult_ml_prec_,is_legal_ml_type)
|
||||
call psb_check_def(p%iprcparm(aggr_alg_),'aggregation',&
|
||||
& loc_aggr_,is_legal_ml_aggr_kind)
|
||||
call psb_check_def(p%iprcparm(smth_kind_),'Smoother kind',&
|
||||
& smth_omg_,is_legal_ml_smth_kind)
|
||||
call psb_check_def(p%iprcparm(coarse_mat_),'Coarse matrix',&
|
||||
& mat_distr_,is_legal_ml_coarse_mat)
|
||||
call psb_check_def(p%iprcparm(smth_pos_),'smooth_pos',&
|
||||
& pre_smooth_,is_legal_ml_smooth_pos)
|
||||
|
||||
|
||||
!!$ nullify(p%desc_data)
|
||||
select case(p%iprcparm(f_type_))
|
||||
case(f_ilu_n_)
|
||||
call psb_check_def(p%iprcparm(ilu_fill_in_),'Level',0,is_legal_ml_lev)
|
||||
case(f_ilu_e_)
|
||||
call psb_check_def(p%dprcparm(fact_eps_),'Eps',dzero,is_legal_ml_eps)
|
||||
end select
|
||||
call psb_check_def(p%dprcparm(smooth_omega_),'omega',dzero,is_legal_omega)
|
||||
call psb_check_def(p%iprcparm(jac_sweeps_),'Jacobi sweeps',&
|
||||
& 1,is_legal_jac_sweeps)
|
||||
|
||||
|
||||
! Currently this is ignored by gen_aggrmap, but it could be
|
||||
! changed in the future. Need to package nlaggr & mlia in a
|
||||
! private data structure?
|
||||
call psb_genaggrmap(p%iprcparm(aggr_alg_),a,desc_a,p%nlaggr,p%mlia,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_gen_aggrmap'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (debug) write(0,*) 'Out from genaggrmap',p%nlaggr
|
||||
|
||||
call psb_nullify_desc(desc_ac)
|
||||
call psb_bldaggrmat(a,desc_a,ac,desc_ac,p,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_bld_aggrmat'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
if (debug) write(0,*) 'Out from bldaggrmat',desc_ac%matrix_data(:)
|
||||
|
||||
|
||||
|
||||
call psb_baseprc_bld(ac,desc_ac,p,info)
|
||||
if (debug) write(0,*) 'Out from baseprcbld',info
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_baseprc_bld'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
!
|
||||
! We have used a separate ac because:
|
||||
! 1. We want to reuse the same routines psb_ilu_bld etc.
|
||||
! 2. We do NOT want to pass an argument twice to them
|
||||
! p%av(ac_) and p, as this would violate the Fortran standard
|
||||
! Hence a separate AC and a TRANSFER function at the end.
|
||||
!
|
||||
call psb_sp_transfer(ac,p%av(ac_),info)
|
||||
p%base_a => p%av(ac_)
|
||||
call psb_cdtransfer(desc_ac,p%desc_ac,info)
|
||||
|
||||
if (info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_cdtransfer'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
p%base_desc => p%desc_ac
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
Return
|
||||
|
||||
end subroutine psb_dmlprc_bld
|
||||
@ -0,0 +1,250 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans, work)
|
||||
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
|
||||
type(psb_desc_type),intent(in) :: desc_data
|
||||
type(psb_dprec_type), intent(in) :: prec
|
||||
real(kind(0.d0)),intent(inout) :: x(:), y(:)
|
||||
integer, intent(out) :: info
|
||||
character(len=1), optional :: trans
|
||||
real(kind(0.d0)), optional, target :: work(:)
|
||||
|
||||
! Local variables
|
||||
character :: trans_
|
||||
real(kind(1.d0)), pointer :: work_(:)
|
||||
integer :: ictxt,np,me,err_act
|
||||
logical,parameter :: debug=.false., debugprt=.false.
|
||||
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)
|
||||
|
||||
ictxt=desc_data%matrix_data(psb_ctxt_)
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
if (present(trans)) then
|
||||
trans_=trans
|
||||
else
|
||||
trans_='N'
|
||||
end if
|
||||
|
||||
if (present(work)) then
|
||||
work_ => work
|
||||
else
|
||||
allocate(work_(4*desc_data%matrix_data(psb_n_col_)),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
end if
|
||||
|
||||
if (.not.(allocated(prec%baseprecv))) then
|
||||
write(0,*) 'Inconsistent preconditioner: neither SMTH nor BASE?'
|
||||
end if
|
||||
if (size(prec%baseprecv) >1) then
|
||||
if (debug) write(0,*) 'Into mlprc_aply',size(x),size(y)
|
||||
call psb_mlprc_aply(done,prec%baseprecv,x,dzero,y,desc_data,trans_,work_,info)
|
||||
if(info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='psb_dmlprc_aply')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
else if (size(prec%baseprecv) == 1) then
|
||||
call psb_baseprc_aply(done,prec%baseprecv(1),x,dzero,y,desc_data,trans_, work_,info)
|
||||
else
|
||||
write(0,*) 'Inconsistent preconditioner: size of baseprecv???'
|
||||
endif
|
||||
|
||||
if (present(work)) then
|
||||
else
|
||||
deallocate(work_)
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine psb_dprc_aply
|
||||
|
||||
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_dprc_aply1(prec,x,desc_data,info,trans)
|
||||
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
|
||||
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_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
|
||||
type(psb_desc_type),intent(in) :: desc_data
|
||||
type(psb_dprec_type), intent(in) :: prec
|
||||
real(kind(0.d0)),intent(inout) :: x(:), y(:)
|
||||
integer, intent(out) :: info
|
||||
character(len=1), optional :: trans
|
||||
real(kind(0.d0)), optional, target :: work(:)
|
||||
end subroutine psb_dprc_aply
|
||||
end interface
|
||||
|
||||
! Local variables
|
||||
character :: trans_
|
||||
integer :: ictxt,np,me,i, err_act
|
||||
real(kind(1.d0)), pointer :: WW(:), w1(:)
|
||||
character(len=20) :: name
|
||||
name='psb_dprec1'
|
||||
info = 0
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
ictxt=desc_data%matrix_data(psb_ctxt_)
|
||||
call psb_info(ictxt, me, np)
|
||||
if (present(trans)) then
|
||||
trans_=trans
|
||||
else
|
||||
trans_='N'
|
||||
end if
|
||||
|
||||
allocate(ww(size(x)),w1(size(x)),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
if (debug) write(0,*) 'Prc_aply1 Size(x) ',size(x), size(ww),size(w1)
|
||||
call psb_dprc_aply(prec,x,ww,desc_data,info,trans_,work=w1)
|
||||
if(info /=0) goto 9999
|
||||
x(:) = ww(:)
|
||||
deallocate(ww,W1)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_errpush(info,name)
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
end subroutine psb_dprc_aply1
|
||||
@ -0,0 +1,170 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_dprecbld(a,desc_a,p,info,upd)
|
||||
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
use psb_prec_mod
|
||||
Implicit None
|
||||
|
||||
type(psb_dspmat_type), target :: a
|
||||
type(psb_desc_type), intent(in), target :: desc_a
|
||||
type(psb_dprec_type),intent(inout) :: p
|
||||
integer, intent(out) :: info
|
||||
character, intent(in), optional :: upd
|
||||
|
||||
! Local scalars
|
||||
Integer :: err,i,j,k,ictxt, me,np,lw, err_act
|
||||
integer :: int_err(5)
|
||||
character :: iupd
|
||||
|
||||
logical, parameter :: debug=.false.
|
||||
integer,parameter :: iroot=0,iout=60,ilout=40
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=0
|
||||
err=0
|
||||
call psb_erractionsave(err_act)
|
||||
name = 'psb_precbld'
|
||||
|
||||
if (debug) write(0,*) 'Entering precbld',P%prec,desc_a%matrix_data(:)
|
||||
info = 0
|
||||
int_err(1) = 0
|
||||
ictxt = psb_cd_get_context(desc_a)
|
||||
|
||||
if (debug) write(0,*) 'Preconditioner psb_info'
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
if (present(upd)) then
|
||||
if (debug) write(0,*) 'UPD ', upd
|
||||
if ((upd.eq.'F').or.(upd.eq.'T')) then
|
||||
iupd=upd
|
||||
else
|
||||
iupd='F'
|
||||
endif
|
||||
else
|
||||
iupd='F'
|
||||
endif
|
||||
|
||||
if (.not.allocated(p%baseprecv)) then
|
||||
!! Error 1: should call precset
|
||||
info=4010
|
||||
ch_err='unallocated bpv'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
!
|
||||
! Should add check to ensure all procs have the same...
|
||||
!
|
||||
! ALso should define symbolic names for the preconditioners.
|
||||
!
|
||||
if (size(p%baseprecv) >= 1) then
|
||||
call init_baseprc_av(p%baseprecv(1),info)
|
||||
if (info /= 0) then
|
||||
info=4010
|
||||
ch_err='allocate'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
call psb_baseprc_bld(a,desc_a,p%baseprecv(1),info,iupd)
|
||||
|
||||
else
|
||||
info=4010
|
||||
ch_err='size bpv'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
|
||||
endif
|
||||
|
||||
if (size(p%baseprecv) > 1) then
|
||||
|
||||
do i=2, size(p%baseprecv)
|
||||
|
||||
call init_baseprc_av(p%baseprecv(i),info)
|
||||
if (info /= 0) then
|
||||
info=4010
|
||||
ch_err='allocate'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
call psb_mlprc_bld(p%baseprecv(i-1)%base_a,p%baseprecv(i-1)%base_desc,&
|
||||
& p%baseprecv(i),info)
|
||||
if (info /= 0) then
|
||||
info=4010
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
if (debug) then
|
||||
write(0,*) 'Return from ',i-1,' call to mlprcbld ',info
|
||||
endif
|
||||
|
||||
end do
|
||||
|
||||
endif
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
contains
|
||||
|
||||
subroutine init_baseprc_av(p,info)
|
||||
type(psb_dbaseprc_type), intent(inout) :: p
|
||||
integer :: info
|
||||
if (allocated(p%av)) then
|
||||
! Have not decided what to do yet
|
||||
end if
|
||||
allocate(p%av(max_avsz),stat=info)
|
||||
!!$ if (info /= 0) return
|
||||
do k=1,size(p%av)
|
||||
call psb_nullify_sp(p%av(k))
|
||||
end do
|
||||
|
||||
end subroutine init_baseprc_av
|
||||
|
||||
end subroutine psb_dprecbld
|
||||
|
||||
@ -0,0 +1,72 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_dprecfree(p,info)
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
type(psb_dprec_type), intent(inout) :: p
|
||||
integer, intent(out) :: info
|
||||
|
||||
!...locals....
|
||||
integer :: ictxt,me,np,err_act,i
|
||||
character(len=20) :: name
|
||||
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=0
|
||||
name = 'psdprecfree'
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
me=-1
|
||||
|
||||
if (allocated(p%baseprecv)) then
|
||||
do i=1,size(p%baseprecv)
|
||||
call psb_base_precfree(p%baseprecv(i),info)
|
||||
end do
|
||||
deallocate(p%baseprecv)
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine psb_dprecfree
|
||||
@ -0,0 +1,187 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_dprecset(p,ptype,info,iv,rs,rv,ilev,nlev)
|
||||
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
type(psb_dprec_type), intent(inout) :: p
|
||||
character(len=*), intent(in) :: ptype
|
||||
integer, intent(out) :: info
|
||||
integer, optional, intent(in) :: iv(:)
|
||||
integer, optional, intent(in) :: nlev,ilev
|
||||
real(kind(1.d0)), optional, intent(in) :: rs
|
||||
real(kind(1.d0)), optional, intent(in) :: rv(:)
|
||||
|
||||
character(len=len(ptype)) :: typeup
|
||||
integer :: isz, err, nlev_, ilev_, i
|
||||
|
||||
info = 0
|
||||
|
||||
if (present(ilev)) then
|
||||
ilev_ = max(1, ilev)
|
||||
else
|
||||
ilev_ = 1
|
||||
end if
|
||||
if (present(nlev)) then
|
||||
if (allocated(p%baseprecv)) then
|
||||
write(0,*) 'Warning: NLEV is ignored when P is already allocated'
|
||||
end if
|
||||
nlev_ = max(1, nlev)
|
||||
else
|
||||
nlev_ = 1
|
||||
end if
|
||||
|
||||
if (.not.allocated(p%baseprecv)) then
|
||||
allocate(p%baseprecv(nlev_),stat=err)
|
||||
else
|
||||
nlev_ = size(p%baseprecv)
|
||||
endif
|
||||
|
||||
if ((ilev_<1).or.(ilev_ > nlev_)) then
|
||||
write(0,*) 'PRECSET ERRROR: ilev out of bounds'
|
||||
info = -1
|
||||
return
|
||||
endif
|
||||
|
||||
call psb_realloc(ifpsz,p%baseprecv(ilev_)%iprcparm,info)
|
||||
if (info == 0) call psb_realloc(dfpsz,p%baseprecv(ilev_)%dprcparm,info)
|
||||
if (info /= 0) return
|
||||
p%baseprecv(ilev_)%iprcparm(:) = 0
|
||||
|
||||
select case(toupper(ptype(1:len_trim(ptype))))
|
||||
case ('NONE','NOPREC')
|
||||
p%baseprecv(ilev_)%iprcparm(:) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(p_type_) = noprec_
|
||||
p%baseprecv(ilev_)%iprcparm(f_type_) = f_none_
|
||||
p%baseprecv(ilev_)%iprcparm(restr_) = psb_none_
|
||||
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
|
||||
p%baseprecv(ilev_)%iprcparm(iren_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
|
||||
|
||||
case ('DIAG','DIAGSC')
|
||||
p%baseprecv(ilev_)%iprcparm(:) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(p_type_) = diagsc_
|
||||
p%baseprecv(ilev_)%iprcparm(f_type_) = f_none_
|
||||
p%baseprecv(ilev_)%iprcparm(restr_) = psb_none_
|
||||
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
|
||||
p%baseprecv(ilev_)%iprcparm(iren_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
|
||||
|
||||
case ('BJA','ILU')
|
||||
p%baseprecv(ilev_)%iprcparm(:) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(p_type_) = bja_
|
||||
p%baseprecv(ilev_)%iprcparm(f_type_) = f_ilu_n_
|
||||
p%baseprecv(ilev_)%iprcparm(restr_) = psb_none_
|
||||
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
|
||||
p%baseprecv(ilev_)%iprcparm(iren_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(ilu_fill_in_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
|
||||
|
||||
case ('ASM','AS')
|
||||
p%baseprecv(ilev_)%iprcparm(:) = 0
|
||||
! Defaults first
|
||||
p%baseprecv(ilev_)%iprcparm(p_type_) = asm_
|
||||
p%baseprecv(ilev_)%iprcparm(f_type_) = f_ilu_n_
|
||||
p%baseprecv(ilev_)%iprcparm(restr_) = psb_halo_
|
||||
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
|
||||
p%baseprecv(ilev_)%iprcparm(iren_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 1
|
||||
p%baseprecv(ilev_)%iprcparm(ilu_fill_in_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
|
||||
|
||||
if (present(iv)) then
|
||||
isz = size(iv)
|
||||
if (isz >= 1) p%baseprecv(ilev_)%iprcparm(n_ovr_) = iv(1)
|
||||
if (isz >= 2) p%baseprecv(ilev_)%iprcparm(restr_) = iv(2)
|
||||
if (isz >= 3) p%baseprecv(ilev_)%iprcparm(prol_) = iv(3)
|
||||
if (isz >= 4) p%baseprecv(ilev_)%iprcparm(f_type_) = iv(4)
|
||||
! Do not consider renum for the time being.
|
||||
!!$ if (isz >= 5) p%baseprecv(ilev_)%iprcparm(iren_) = iv(5)
|
||||
end if
|
||||
|
||||
|
||||
case ('ML', '2L', '2LEV')
|
||||
|
||||
|
||||
p%baseprecv(ilev_)%iprcparm(:) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(p_type_) = bja_
|
||||
p%baseprecv(ilev_)%iprcparm(restr_) = psb_none_
|
||||
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
|
||||
p%baseprecv(ilev_)%iprcparm(iren_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(ml_type_) = mult_ml_prec_
|
||||
p%baseprecv(ilev_)%iprcparm(aggr_alg_) = loc_aggr_
|
||||
p%baseprecv(ilev_)%iprcparm(smth_kind_) = smth_omg_
|
||||
p%baseprecv(ilev_)%iprcparm(coarse_mat_) = mat_distr_
|
||||
p%baseprecv(ilev_)%iprcparm(smth_pos_) = post_smooth_
|
||||
p%baseprecv(ilev_)%iprcparm(glb_smth_) = 1
|
||||
p%baseprecv(ilev_)%iprcparm(om_choice_) = lib_choice_
|
||||
p%baseprecv(ilev_)%iprcparm(f_type_) = f_ilu_n_
|
||||
p%baseprecv(ilev_)%iprcparm(ilu_fill_in_) = 0
|
||||
p%baseprecv(ilev_)%dprcparm(smooth_omega_) = 4.d0/3.d0
|
||||
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
|
||||
|
||||
if (present(iv)) then
|
||||
isz = size(iv)
|
||||
if (isz >= 1) p%baseprecv(ilev_)%iprcparm(ml_type_) = iv(1)
|
||||
if (isz >= 2) p%baseprecv(ilev_)%iprcparm(aggr_alg_) = iv(2)
|
||||
if (isz >= 3) p%baseprecv(ilev_)%iprcparm(coarse_mat_) = iv(3)
|
||||
if (isz >= 4) p%baseprecv(ilev_)%iprcparm(smth_pos_) = iv(4)
|
||||
if (isz >= 5) p%baseprecv(ilev_)%iprcparm(f_type_) = iv(5)
|
||||
if (isz >= 6) p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = iv(6)
|
||||
if (isz >= 7) p%baseprecv(ilev_)%iprcparm(smth_kind_) = iv(7)
|
||||
end if
|
||||
|
||||
if (present(rs)) then
|
||||
p%baseprecv(ilev_)%iprcparm(om_choice_) = user_choice_
|
||||
p%baseprecv(ilev_)%dprcparm(smooth_omega_) = rs
|
||||
end if
|
||||
|
||||
|
||||
case default
|
||||
write(0,*) 'Unknown preconditioner type request "',ptype,'"'
|
||||
err = 2
|
||||
|
||||
end select
|
||||
|
||||
info = err
|
||||
|
||||
end subroutine psb_dprecset
|
||||
@ -0,0 +1,206 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
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
|
||||
|
||||
|
||||
type(psb_dspmat_type) :: blck, atmp
|
||||
character(len=5) :: fmt
|
||||
character :: upd='F'
|
||||
integer :: i,j,nza,nzb,nzt,ictxt,me,np,err_act
|
||||
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_)
|
||||
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
fmt = 'COO'
|
||||
call psb_nullify_sp(blck)
|
||||
call psb_nullify_sp(atmp)
|
||||
|
||||
atmp%fida='COO'
|
||||
if (Debug) then
|
||||
write(0,*) me, 'SPLUBLD: Calling csdp'
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
|
||||
call psb_csdp(a,atmp,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_csdp'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
nza = atmp%infoa(psb_nnz_)
|
||||
if (Debug) then
|
||||
write(0,*) me, 'SPLUBLD: Done csdp',info,nza,atmp%m,atmp%k
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
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_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 asmatbld',info,nzb,blck%fida
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
if (nzb > 0 ) then
|
||||
if (size(atmp%aspk)<nza+nzb) then
|
||||
call psb_sp_reall(atmp,nza+nzb,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
|
||||
endif
|
||||
if (Debug) then
|
||||
write(0,*) me, 'SPLUBLD: Done realloc',info,nza+nzb,atmp%fida
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
|
||||
do j=1,nzb
|
||||
atmp%aspk(nza+j) = blck%aspk(j)
|
||||
atmp%ia1(nza+j) = blck%ia1(j)
|
||||
atmp%ia2(nza+j) = blck%ia2(j)
|
||||
end do
|
||||
atmp%infoa(psb_nnz_) = nza+nzb
|
||||
atmp%m = atmp%m + blck%m
|
||||
atmp%k = max(a%k,blck%k)
|
||||
else
|
||||
atmp%infoa(psb_nnz_) = nza
|
||||
atmp%m = a%m
|
||||
atmp%k = a%k
|
||||
endif
|
||||
|
||||
i=0
|
||||
do j=1, atmp%infoa(psb_nnz_)
|
||||
if (atmp%ia2(j) <= atmp%m) then
|
||||
i = i + 1
|
||||
atmp%aspk(i) = atmp%aspk(j)
|
||||
atmp%ia1(i) = atmp%ia1(j)
|
||||
atmp%ia2(i) = atmp%ia2(j)
|
||||
endif
|
||||
enddo
|
||||
atmp%infoa(psb_nnz_) = i
|
||||
|
||||
|
||||
call psb_ipcoo2csr(atmp,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_ipcoo2csr'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
nzt = psb_sp_get_nnzeros(atmp)
|
||||
|
||||
if (Debug) then
|
||||
write(0,*) me,'Calling psb_slu_factor ',nzt,atmp%m,&
|
||||
& atmp%k,p%desc_data%matrix_data(psb_n_row_)
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
|
||||
call psb_dslu_factor(atmp%m,nzt,&
|
||||
& atmp%aspk,atmp%ia2,atmp%ia1,p%iprcparm(slu_ptr_),info)
|
||||
if(info /= 0) then
|
||||
ch_err='psb_slu_fact'
|
||||
call psb_errpush(4110,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (Debug) then
|
||||
write(0,*) me, 'SPLUBLD: Done slu_Factor',info,p%iprcparm(slu_ptr_)
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
|
||||
call psb_sp_free(blck,info)
|
||||
call psb_sp_free(atmp,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_sp_free'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine psb_dslu_bld
|
||||
|
||||
@ -0,0 +1,459 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_dsp_renum(a,desc_a,blck,p,atmp,info)
|
||||
use psb_base_mod
|
||||
use psb_prec_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
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer, intent(out) :: info
|
||||
|
||||
|
||||
character(len=20) :: name, ch_err
|
||||
integer nztota, nztotb, nztmp, nzl, nnr, ir, mglob, mtype, n_row, &
|
||||
& nrow_a,n_col, nhalo,lovr, ind, iind, pi,nr,ns,i,j,jj,k,kk
|
||||
integer ::ictxt,np,me, err_act
|
||||
integer, allocatable :: itmp(:), itmp2(:)
|
||||
real(kind(1.d0)), allocatable :: rtmp(:)
|
||||
real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6,mpi_wtime, t7, t8
|
||||
external mpi_wtime
|
||||
|
||||
if (psb_get_errstatus().ne.0) return
|
||||
info=0
|
||||
name='apply_renum'
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
ictxt=psb_cd_get_context(desc_a)
|
||||
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
!!!!!!!!!!!!!!!! CHANGE FOR NON-CSR A
|
||||
!
|
||||
! Renumbering type:
|
||||
! 1. Global column indices
|
||||
! (2. GPS band reduction disabled for the time being)
|
||||
|
||||
if (p%iprcparm(iren_)==renum_glb_) then
|
||||
atmp%m = a%m + blck%m
|
||||
atmp%k = a%k
|
||||
atmp%fida='CSR'
|
||||
atmp%descra = 'GUN'
|
||||
|
||||
! This is the renumbering coherent with global indices..
|
||||
mglob = psb_cd_get_global_rows(desc_a)
|
||||
|
||||
!
|
||||
! Remember: we have switched IA1=COLS and IA2=ROWS
|
||||
! Now identify the set of distinct local column indices
|
||||
!
|
||||
|
||||
nnr = p%desc_data%matrix_data(psb_n_row_)
|
||||
allocate(p%perm(nnr),p%invperm(nnr),itmp2(nnr),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
do k=1,nnr
|
||||
itmp2(k) = p%desc_data%loc_to_glob(k)
|
||||
enddo
|
||||
!
|
||||
! We want: NEW(I) = OLD(PERM(I))
|
||||
!
|
||||
call isrx(nnr,itmp2,p%perm)
|
||||
|
||||
do k=1, nnr
|
||||
p%invperm(p%perm(k)) = k
|
||||
enddo
|
||||
t3 = mpi_wtime()
|
||||
|
||||
! Build ATMP with new numbering.
|
||||
nztmp=size(atmp%aspk)
|
||||
allocate(itmp(max(8,atmp%m+2,nztmp+2)),rtmp(atmp%m),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
j = 1
|
||||
atmp%ia2(1) = 1
|
||||
do i=1, atmp%m
|
||||
ir = p%perm(i)
|
||||
|
||||
if (ir <= a%m ) then
|
||||
|
||||
nzl = a%ia2(ir+1) - a%ia2(ir)
|
||||
if (nzl > size(rtmp)) then
|
||||
call psb_realloc(nzl,rtmp,info)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
jj = a%ia2(ir)
|
||||
k=0
|
||||
do kk=1, nzl
|
||||
if (a%ia1(jj+kk-1)<=atmp%m) then
|
||||
k = k + 1
|
||||
rtmp(k) = a%aspk(jj+kk-1)
|
||||
atmp%ia1(j+k-1) = p%invperm(a%ia1(jj+kk-1))
|
||||
endif
|
||||
enddo
|
||||
call isrx(k,atmp%ia1(j:j+k-1),itmp2)
|
||||
do kk=1,k
|
||||
atmp%aspk(j+kk-1) = rtmp(itmp2(kk))
|
||||
enddo
|
||||
|
||||
else if (ir <= atmp%m ) then
|
||||
|
||||
ir = ir - a%m
|
||||
nzl = blck%ia2(ir+1) - blck%ia2(ir)
|
||||
if (nzl > size(rtmp)) then
|
||||
call psb_realloc(nzl,rtmp,info)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
jj = blck%ia2(ir)
|
||||
k=0
|
||||
do kk=1, nzl
|
||||
if (blck%ia1(jj+kk-1)<=atmp%m) then
|
||||
k = k + 1
|
||||
rtmp(k) = blck%aspk(jj+kk-1)
|
||||
atmp%ia1(j+k-1) = p%invperm(blck%ia1(jj+kk-1))
|
||||
endif
|
||||
enddo
|
||||
call isrx(k,atmp%ia1(j:j+k-1),itmp2)
|
||||
do kk=1,k
|
||||
atmp%aspk(j+kk-1) = rtmp(itmp2(kk))
|
||||
enddo
|
||||
|
||||
else
|
||||
write(0,*) 'Row index error 1 :',i,ir
|
||||
endif
|
||||
|
||||
j = j + k
|
||||
atmp%ia2(i+1) = j
|
||||
|
||||
enddo
|
||||
|
||||
t4 = mpi_wtime()
|
||||
|
||||
|
||||
deallocate(itmp,itmp2,rtmp)
|
||||
|
||||
else if (p%iprcparm(iren_)==renum_gps_) then
|
||||
|
||||
atmp%m = a%m + blck%m
|
||||
atmp%k = a%k
|
||||
atmp%fida='CSR'
|
||||
atmp%descra = 'GUN'
|
||||
do i=1, a%m
|
||||
atmp%ia2(i) = a%ia2(i)
|
||||
do j= a%ia2(i), a%ia2(i+1)-1
|
||||
atmp%ia1(j) = a%ia1(j)
|
||||
enddo
|
||||
enddo
|
||||
atmp%ia2(a%m+1) = a%ia2(a%m+1)
|
||||
nztota = atmp%ia2(a%m+1) -1
|
||||
if (blck%m>0) then
|
||||
do i=1, blck%m
|
||||
atmp%ia2(a%m+i) = nztota+blck%ia2(i)
|
||||
do j= blck%ia2(i), blck%ia2(i+1)-1
|
||||
atmp%ia1(nztota+j) = blck%ia1(j)
|
||||
enddo
|
||||
enddo
|
||||
atmp%ia2(atmp%m+1) = nztota+blck%ia2(blck%m+1)
|
||||
endif
|
||||
nztmp = atmp%ia2(atmp%m+1) - 1
|
||||
|
||||
|
||||
! This is a renumbering with Gibbs-Poole-Stockmeyer
|
||||
! band reduction. Switched off for now. To be fixed,
|
||||
! gps_reduction should get p%perm.
|
||||
|
||||
! write(0,*) me,' Renumbering: realloc perms',atmp%m
|
||||
call psb_realloc(atmp%m,p%perm,info)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_realloc(atmp%m,p%invperm,info)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
allocate(itmp(max(8,atmp%m+2,nztmp+2)),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
itmp(1:8) = 0
|
||||
! write(0,*) me,' Renumbering: Calling Metis'
|
||||
|
||||
! write(0,*) size(p%av(u_pr_)%pl),size(p%av(l_pr_)%pr)
|
||||
call gps_reduction(atmp%m,atmp%ia2,atmp%ia1,p%perm,p%invperm,info)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='gps_reduction'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
! write(0,*) me,' Renumbering: Done GPS'
|
||||
! call psb_barrier(ictxt)
|
||||
do i=1, atmp%m
|
||||
if (p%perm(i) /= i) then
|
||||
write(0,*) me,' permutation is not identity '
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
|
||||
|
||||
do k=1, nnr
|
||||
p%invperm(p%perm(k)) = k
|
||||
enddo
|
||||
t3 = mpi_wtime()
|
||||
|
||||
! Build ATMP with new numbering.
|
||||
|
||||
allocate(itmp2(max(8,atmp%m+2,nztmp+2)),rtmp(atmp%m),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
j = 1
|
||||
atmp%ia2(1) = 1
|
||||
do i=1, atmp%m
|
||||
ir = p%perm(i)
|
||||
|
||||
if (ir <= a%m ) then
|
||||
|
||||
nzl = a%ia2(ir+1) - a%ia2(ir)
|
||||
if (nzl > size(rtmp)) then
|
||||
call psb_realloc(nzl,rtmp,info)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
jj = a%ia2(ir)
|
||||
k=0
|
||||
do kk=1, nzl
|
||||
if (a%ia1(jj+kk-1)<=atmp%m) then
|
||||
k = k + 1
|
||||
rtmp(k) = a%aspk(jj+kk-1)
|
||||
atmp%ia1(j+k-1) = p%invperm(a%ia1(jj+kk-1))
|
||||
endif
|
||||
enddo
|
||||
call isrx(k,atmp%ia1(j:j+k-1),itmp2)
|
||||
do kk=1,k
|
||||
atmp%aspk(j+kk-1) = rtmp(itmp2(kk))
|
||||
enddo
|
||||
|
||||
else if (ir <= atmp%m ) then
|
||||
|
||||
ir = ir - a%m
|
||||
nzl = blck%ia2(ir+1) - blck%ia2(ir)
|
||||
if (nzl > size(rtmp)) then
|
||||
call psb_realloc(nzl,rtmp,info)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
jj = blck%ia2(ir)
|
||||
k=0
|
||||
do kk=1, nzl
|
||||
if (blck%ia1(jj+kk-1)<=atmp%m) then
|
||||
k = k + 1
|
||||
rtmp(k) = blck%aspk(jj+kk-1)
|
||||
atmp%ia1(j+k-1) = p%invperm(blck%ia1(jj+kk-1))
|
||||
endif
|
||||
enddo
|
||||
call isrx(k,atmp%ia1(j:j+k-1),itmp2)
|
||||
do kk=1,k
|
||||
atmp%aspk(j+kk-1) = rtmp(itmp2(kk))
|
||||
enddo
|
||||
|
||||
else
|
||||
write(0,*) 'Row index error 1 :',i,ir
|
||||
endif
|
||||
|
||||
j = j + k
|
||||
atmp%ia2(i+1) = j
|
||||
|
||||
enddo
|
||||
|
||||
t4 = mpi_wtime()
|
||||
|
||||
|
||||
|
||||
deallocate(itmp,itmp2,rtmp)
|
||||
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
contains
|
||||
|
||||
|
||||
subroutine gps_reduction(m,ia,ja,perm,iperm,info)
|
||||
integer i,j,dgConn,Npnt,m
|
||||
integer n,idpth,ideg,ibw2,ipf2
|
||||
integer,dimension(:) :: perm,iperm,ia,ja
|
||||
integer, intent(out) :: info
|
||||
|
||||
integer,dimension(:,:),allocatable::NDstk
|
||||
integer,dimension(:),allocatable::iOld,renum,ndeg,lvl,lvls1,lvls2,ccstor
|
||||
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=0
|
||||
name='gps_reduction'
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
!--- Calcolo il massimo grado di connettivita'.
|
||||
npnt = m
|
||||
write(6,*) ' GPS su ',npnt
|
||||
dgConn=0
|
||||
do i=1,m
|
||||
dgconn = max(dgconn,(ia(i+1)-ia(i)))
|
||||
enddo
|
||||
!--- Il max valore di connettivita' e "dgConn"
|
||||
|
||||
!--- Valori della common
|
||||
n=Npnt !--- Numero di righe
|
||||
iDeg=dgConn !--- Massima connettivita'
|
||||
! iDpth= !--- Numero di livelli non serve settarlo
|
||||
|
||||
allocate(NDstk(Npnt,dgConn),stat=info)
|
||||
if (info/=0) then
|
||||
info=4000
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
else
|
||||
write(0,*) 'gps_reduction first alloc OK'
|
||||
endif
|
||||
allocate(iOld(Npnt),renum(Npnt+1),ndeg(Npnt),lvl(Npnt),lvls1(Npnt),&
|
||||
&lvls2(Npnt),ccstor(Npnt),stat=info)
|
||||
if (info/=0) then
|
||||
info=4000
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
else
|
||||
write(0,*) 'gps_reduction 2nd alloc OK'
|
||||
endif
|
||||
|
||||
!--- Prepariamo il grafo della matrice
|
||||
Ndstk(:,:)=0
|
||||
do i=1,Npnt
|
||||
k=0
|
||||
do j = ia(i),ia(i+1) - 1
|
||||
if ((1<=ja(j)).and.( ja( j ) /= i ).and.(ja(j)<=npnt)) then
|
||||
k = k+1
|
||||
Ndstk(i,k)=ja(j)
|
||||
endif
|
||||
enddo
|
||||
ndeg(i)=k
|
||||
enddo
|
||||
|
||||
!--- Numerazione.
|
||||
do i=1,Npnt
|
||||
iOld(i)=i
|
||||
enddo
|
||||
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'
|
||||
!--- Permutazione
|
||||
perm(1:Npnt)=renum(1:Npnt)
|
||||
!--- Inversa permutazione
|
||||
do i=1,Npnt
|
||||
iperm(perm(i))=i
|
||||
enddo
|
||||
!--- Puliamo tutto.
|
||||
deallocate(NDstk,iOld,renum,ndeg,lvl,lvls1,lvls2,ccstor)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine gps_reduction
|
||||
|
||||
end subroutine psb_dsp_renum
|
||||
@ -0,0 +1,212 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
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
|
||||
|
||||
|
||||
type(psb_dspmat_type) :: blck, atmp
|
||||
character(len=5) :: fmt
|
||||
character :: upd='F'
|
||||
integer :: i,j,nza,nzb,nzt,ictxt,me,np,err_act
|
||||
integer :: i_err(5)
|
||||
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)
|
||||
|
||||
ictxt = desc_A%matrix_data(psb_ctxt_)
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
fmt = 'COO'
|
||||
call psb_nullify_sp(blck)
|
||||
call psb_nullify_sp(atmp)
|
||||
|
||||
atmp%fida='COO'
|
||||
if (Debug) then
|
||||
write(0,*) me, 'UMFBLD: Calling csdp'
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
|
||||
call psb_dcsdp(a,atmp,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_dcsdp'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
nza = psb_sp_get_nnzeros(atmp)
|
||||
nzb = psb_sp_get_nnzeros(a)
|
||||
|
||||
if (Debug) then
|
||||
write(0,*) me, 'UMFBLD: Done csdp',info,nza,atmp%m,atmp%k,nzb
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
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_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 asmatbld',info,nzb,blck%fida
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
if (nzb > 0 ) then
|
||||
if (size(atmp%aspk)<nza+nzb) then
|
||||
call psb_sp_reall(atmp,nza+nzb,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
|
||||
endif
|
||||
if (Debug) then
|
||||
write(0,*) me, 'UMFBLD: Done realloc',info,nza+nzb,atmp%fida
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
|
||||
do j=1,nzb
|
||||
atmp%aspk(nza+j) = blck%aspk(j)
|
||||
atmp%ia1(nza+j) = blck%ia1(j)
|
||||
atmp%ia2(nza+j) = blck%ia2(j)
|
||||
end do
|
||||
atmp%infoa(psb_nnz_) = nza+nzb
|
||||
atmp%m = atmp%m + blck%m
|
||||
atmp%k = max(a%k,blck%k)
|
||||
else
|
||||
atmp%infoa(psb_nnz_) = nza
|
||||
atmp%m = a%m
|
||||
atmp%k = a%k
|
||||
endif
|
||||
|
||||
i=0
|
||||
do j=1, atmp%infoa(psb_nnz_)
|
||||
if (atmp%ia2(j) <= atmp%m) then
|
||||
i = i + 1
|
||||
atmp%aspk(i) = atmp%aspk(j)
|
||||
atmp%ia1(i) = atmp%ia1(j)
|
||||
atmp%ia2(i) = atmp%ia2(j)
|
||||
endif
|
||||
enddo
|
||||
atmp%infoa(psb_nnz_) = i
|
||||
|
||||
|
||||
call psb_ipcoo2csc(atmp,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_ipcoo2csc'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
nzt = psb_sp_get_nnzeros(atmp)
|
||||
if (Debug) then
|
||||
write(0,*) me,'Calling psb_umf_factor ',nzt,atmp%m,&
|
||||
& atmp%k,p%desc_data%matrix_data(psb_n_row_)
|
||||
open(80+me)
|
||||
call psb_csprt(80+me,atmp)
|
||||
close(80+me)
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
|
||||
call psb_dumf_factor(atmp%m,nzt,&
|
||||
& atmp%aspk,atmp%ia1,atmp%ia2,&
|
||||
& p%iprcparm(umf_symptr_),p%iprcparm(umf_numptr_),info)
|
||||
if (info /= 0) then
|
||||
i_err(1) = info
|
||||
info=4110
|
||||
ch_err='psb_umf_fact'
|
||||
call psb_errpush(info,name,a_err=ch_err,i_err=i_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (Debug) then
|
||||
write(0,*) me, 'UMFBLD: Done umf_Factor',info,p%iprcparm(umf_numptr_)
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
call psb_sp_free(blck,info)
|
||||
call psb_sp_free(atmp,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_sp_free'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine psb_dumf_bld
|
||||
|
||||
|
||||
|
||||
@ -0,0 +1,460 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
module psb_prec_mod
|
||||
use psb_prec_type
|
||||
|
||||
|
||||
interface psb_precbld
|
||||
subroutine psb_dprecbld(a,desc_a,prec,info,upd)
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
type(psb_dspmat_type), intent(in), target :: a
|
||||
type(psb_desc_type), intent(in), target :: desc_a
|
||||
type(psb_dprec_type), intent(inout) :: prec
|
||||
integer, intent(out) :: info
|
||||
character, intent(in),optional :: upd
|
||||
end subroutine psb_dprecbld
|
||||
subroutine psb_zprecbld(a,desc_a,prec,info,upd)
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
type(psb_zspmat_type), intent(in), target :: a
|
||||
type(psb_desc_type), intent(in), target :: desc_a
|
||||
type(psb_zprec_type), intent(inout) :: prec
|
||||
integer, intent(out) :: info
|
||||
character, intent(in),optional :: upd
|
||||
end subroutine psb_zprecbld
|
||||
end interface
|
||||
|
||||
interface psb_precset
|
||||
subroutine psb_dprecset(prec,ptype,info,iv,rs,rv,ilev,nlev)
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
type(psb_dprec_type), intent(inout) :: prec
|
||||
character(len=*), intent(in) :: ptype
|
||||
integer, intent(out) :: info
|
||||
integer, optional, intent(in) :: iv(:)
|
||||
integer, optional, intent(in) :: nlev,ilev
|
||||
real(kind(1.d0)), optional, intent(in) :: rs
|
||||
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_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
type(psb_zprec_type), intent(inout) :: prec
|
||||
character(len=*), intent(in) :: ptype
|
||||
integer, intent(out) :: info
|
||||
integer, optional, intent(in) :: iv(:)
|
||||
real(kind(1.d0)), optional, intent(in) :: rs
|
||||
real(kind(1.d0)), optional, intent(in) :: rv(:)
|
||||
integer, optional, intent(in) :: nlev,ilev
|
||||
end subroutine psb_zprecset
|
||||
end interface
|
||||
|
||||
|
||||
interface psb_precfree
|
||||
subroutine psb_dprecfree(p,info)
|
||||
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_base_mod
|
||||
use psb_prec_type
|
||||
type(psb_zprec_type), intent(inout) :: p
|
||||
integer, intent(out) :: info
|
||||
end subroutine psb_zprecfree
|
||||
end interface
|
||||
|
||||
interface psb_prc_aply
|
||||
subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans,work)
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
type(psb_desc_type),intent(in) :: desc_data
|
||||
type(psb_dprec_type), intent(in) :: prec
|
||||
real(kind(0.d0)),intent(inout) :: x(:), y(:)
|
||||
integer, intent(out) :: info
|
||||
character(len=1), optional :: trans
|
||||
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_base_mod
|
||||
use psb_prec_type
|
||||
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
|
||||
end subroutine psb_dprc_aply1
|
||||
subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans,work)
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
type(psb_desc_type),intent(in) :: desc_data
|
||||
type(psb_zprec_type), intent(in) :: prec
|
||||
complex(kind(0.d0)),intent(inout) :: x(:), y(:)
|
||||
integer, intent(out) :: info
|
||||
character(len=1), optional :: trans
|
||||
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_base_mod
|
||||
use psb_prec_type
|
||||
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
|
||||
end subroutine psb_zprc_aply1
|
||||
end interface
|
||||
|
||||
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), target :: desc_a
|
||||
type(psb_dbaseprc_type),intent(inout) :: p
|
||||
integer, intent(out) :: info
|
||||
character, intent(in), optional :: upd
|
||||
end subroutine psb_dbaseprc_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), target :: 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_mlprc_bld
|
||||
subroutine psb_dmlprc_bld(a,desc_a,p,info)
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
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_base_mod
|
||||
use psb_prec_type
|
||||
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
|
||||
integer, intent(out) :: info
|
||||
end subroutine psb_zmlprc_bld
|
||||
end interface
|
||||
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
|
||||
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
|
||||
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_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
|
||||
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_dslu_bld(a,desc_a,p,info)
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
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_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_dumf_bld(a,desc_a,p,info)
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
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_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
|
||||
|
||||
|
||||
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
|
||||
subroutine psb_zilu_fct(a,l,u,d,info,blck)
|
||||
use psb_base_mod
|
||||
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_as_matbld
|
||||
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
|
||||
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_dsp_renum(a,desc_a,blck,p,atmp,info)
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
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
|
||||
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
|
||||
|
||||
|
||||
interface psb_genaggrmap
|
||||
subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
|
||||
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
|
||||
integer, allocatable :: ilaggr(:),nlaggr(:)
|
||||
integer, intent(out) :: info
|
||||
end subroutine psb_dgenaggrmap
|
||||
subroutine psb_zgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
|
||||
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
|
||||
integer, allocatable :: ilaggr(:),nlaggr(:)
|
||||
integer, intent(out) :: info
|
||||
end subroutine psb_zgenaggrmap
|
||||
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(inout),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
|
||||
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(inout),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
|
||||
|
||||
end module psb_prec_mod
|
||||
@ -0,0 +1,847 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
module psb_prec_type
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
!! Module to define PREC_DATA, !!
|
||||
!! structure for preconditioning. !!
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
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,&
|
||||
& lv2mras_=9, lv2smth_=10, lv2lsm_=11, sl2sm_=12, superlu_=13,&
|
||||
& new_loc_smth_=14, new_glb_smth_=15, ag2lsm_=16,&
|
||||
& msy2l_=18, msy2g_=19, max_prec_=19
|
||||
|
||||
! Multilevel stuff.
|
||||
integer, parameter :: no_ml_=0, add_ml_prec_=1, mult_ml_prec_=2
|
||||
integer, parameter :: new_ml_prec_=3, max_ml_=new_ml_prec_
|
||||
integer, parameter :: pre_smooth_=1, post_smooth_=2, smooth_both_=3,&
|
||||
& max_smooth_=smooth_both_
|
||||
integer, parameter :: loc_aggr_=0, glb_aggr_=1, new_loc_aggr_=2
|
||||
integer, parameter :: new_glb_aggr_=3, max_aggr_=new_glb_aggr_
|
||||
integer, parameter :: no_smth_=0, smth_omg_=1, smth_biz_=2
|
||||
integer, parameter :: lib_choice_=0, user_choice_=1
|
||||
integer, parameter :: mat_distr_=0, mat_repl_=1
|
||||
! Entries in iprcparm: preconditioner type, factorization type,
|
||||
! prolongation type, restriction type, renumbering algorithm,
|
||||
! number of overlap layers, pointer to SuperLU factors,
|
||||
! levels of fill in for ILU(N),
|
||||
integer, parameter :: p_type_=1, f_type_=2, restr_=3, prol_=4
|
||||
integer, parameter :: iren_=5, n_ovr_=6
|
||||
integer, parameter :: ilu_fill_in_=8, jac_sweeps_=9, ml_type_=10
|
||||
integer, parameter :: smth_pos_=11, aggr_alg_=12, smth_kind_=13
|
||||
integer, parameter :: om_choice_=14, glb_smth_=15, coarse_mat_=16
|
||||
!Renumbering. SEE BELOW
|
||||
integer, parameter :: renum_none_=0, renum_glb_=1, renum_gps_=2
|
||||
!! 2 ints for 64 bit versions
|
||||
integer, parameter :: slu_ptr_=17, umf_symptr_=17, umf_numptr_=19
|
||||
integer, parameter :: ifpsz=20
|
||||
! Entries in dprcparm: ILU(E) epsilon, smoother omega
|
||||
integer, parameter :: fact_eps_=1, smooth_omega_=2
|
||||
integer, parameter :: dfpsz=4
|
||||
! Factorization types: none, ILU(N), ILU(E), SuperLU, UMFPACK
|
||||
integer, parameter :: f_none_=0,f_ilu_n_=1,f_ilu_e_=2,f_slu_=3,f_umf_=4
|
||||
! Fields for sparse matrices ensembles:
|
||||
integer, parameter :: l_pr_=1, u_pr_=2, bp_ilu_avsz=2
|
||||
integer, parameter :: ap_nd_=3, ac_=4, sm_pr_t_=5, sm_pr_=6
|
||||
integer, parameter :: smth_avsz=6, max_avsz=smth_avsz
|
||||
|
||||
|
||||
type psb_dbaseprc_type
|
||||
|
||||
type(psb_dspmat_type), allocatable :: av(:)
|
||||
real(kind(1.d0)), allocatable :: d(:)
|
||||
type(psb_desc_type) :: desc_data , desc_ac
|
||||
integer, allocatable :: iprcparm(:)
|
||||
real(kind(1.d0)), allocatable :: dprcparm(:)
|
||||
integer, allocatable :: perm(:), invperm(:)
|
||||
integer, allocatable :: mlia(:), nlaggr(:)
|
||||
type(psb_dspmat_type), pointer :: base_a => null() !
|
||||
type(psb_desc_type), pointer :: base_desc=> null() !
|
||||
real(kind(1.d0)), allocatable :: dorig(:)
|
||||
|
||||
end type psb_dbaseprc_type
|
||||
|
||||
|
||||
!
|
||||
! Multilevel preconditioning
|
||||
!
|
||||
! To each level I there corresponds a matrix A(I) and a preconditioner K(I)
|
||||
!
|
||||
! A notational difference: in the DD reference above the preconditioner for
|
||||
! a given level K(I) is written out as a sum over the subdomains
|
||||
!
|
||||
! SUM_k(R_k^T A_k R_k)
|
||||
!
|
||||
! whereas in this code the sum is implicit in the parallelization,
|
||||
! i.e. each process takes care of one subdomain, and for each level we have
|
||||
! as many subdomains as there are processes (except for the coarsest level where
|
||||
! we might have a replicated index space). Thus the sum apparently disappears
|
||||
! from our code, but only apparently, because it is implicit in the call
|
||||
! to psb_baseprc_aply.
|
||||
!
|
||||
! A bit of description of the baseprecv(:) data structure:
|
||||
! 1. Number of levels = NLEV = size(baseprecv(:))
|
||||
! 2. baseprecv(ilev)%av(:) sparse matrices needed for the current level.
|
||||
! Includes:
|
||||
! 2.1.: baseprecv(ilev)%av(l_pr_) L factor of ILU preconditioners
|
||||
! 2.2.: baseprecv(ilev)%av(u_pr_) U factor of ILU preconditioners
|
||||
! 2.3.: baseprecv(ilev)%av(ap_nd_) Off-diagonal part of A for Jacobi sweeps
|
||||
! 2.4.: baseprecv(ilev)%av(ac_) Aggregated matrix of level ILEV
|
||||
! 2.5.: baseprecv(ilev)%av(sm_pr_t_) Smoother prolongator transpose; maps vectors
|
||||
! (ilev-1) ---> (ilev)
|
||||
! 2.6.: baseprecv(ilev)%av(sm_pr_) Smoother prolongator; maps vectors
|
||||
! (ilev) ---> (ilev-1)
|
||||
! Shouldn't we keep just one of them and handle transpose in the sparse BLAS? maybe
|
||||
!
|
||||
! 3. baseprecv(ilev)%desc_data comm descriptor for level ILEV
|
||||
! 4. baseprecv(ilev)%base_a Pointer (really a pointer!) to the base matrix
|
||||
! of the current level, i.e.: if ILEV=1 then A
|
||||
! else the aggregated matrix av(ac_); so we have
|
||||
! a unified treatment of residuals. Need this to
|
||||
! avoid passing explicitly matrix A to the
|
||||
! outer prec. routine
|
||||
! 5. baseprecv(ilev)%mlia The aggregation map from (ilev-1)-->(ilev)
|
||||
! if no smoother, it is used instead of sm_pr_
|
||||
! 6. baseprecv(ilev)%nlaggr Number of aggregates on the various procs.
|
||||
!
|
||||
type psb_dprec_type
|
||||
type(psb_dbaseprc_type), allocatable :: baseprecv(:)
|
||||
! contain type of preconditioning to be performed
|
||||
integer :: prec, base_prec
|
||||
end type psb_dprec_type
|
||||
|
||||
type psb_zbaseprc_type
|
||||
|
||||
type(psb_zspmat_type), allocatable :: av(:)
|
||||
complex(kind(1.d0)), allocatable :: d(:)
|
||||
type(psb_desc_type) :: desc_data , desc_ac
|
||||
integer, allocatable :: iprcparm(:)
|
||||
real(kind(1.d0)), allocatable :: dprcparm(:)
|
||||
integer, allocatable :: perm(:), invperm(:)
|
||||
integer, allocatable :: mlia(:), nlaggr(:)
|
||||
type(psb_zspmat_type), pointer :: base_a => null() !
|
||||
type(psb_desc_type), pointer :: base_desc => null() !
|
||||
complex(kind(1.d0)), allocatable :: dorig(:)
|
||||
|
||||
end type psb_zbaseprc_type
|
||||
|
||||
type psb_zprec_type
|
||||
type(psb_zbaseprc_type), allocatable :: baseprecv(:)
|
||||
! contain type of preconditioning to be performed
|
||||
integer :: prec, base_prec
|
||||
end type psb_zprec_type
|
||||
|
||||
|
||||
character(len=15), parameter, private :: &
|
||||
& smooth_names(1:3)=(/'Pre-smoothing ','Post-smoothing',&
|
||||
& 'Smooth both '/)
|
||||
character(len=15), parameter, private :: &
|
||||
& smooth_kinds(0:2)=(/'No smoother ','Omega smoother',&
|
||||
& 'Bizr. smoother'/)
|
||||
character(len=15), parameter, private :: &
|
||||
& matrix_names(0:1)=(/'Distributed ','Replicated '/)
|
||||
character(len=18), parameter, private :: &
|
||||
& aggr_names(0:3)=(/'Local aggregation ','Global aggregation',&
|
||||
& 'New local aggr. ','New global aggr. '/)
|
||||
character(len=6), parameter, private :: &
|
||||
& restrict_names(0:4)=(/'None ',' ',' ',' ','Halo '/)
|
||||
character(len=12), parameter, private :: &
|
||||
& prolong_names(0:3)=(/'None ','Sum ','Average ','Square root'/)
|
||||
character(len=15), parameter, private :: &
|
||||
& ml_names(0:3)=(/'None ','Additive ','Multiplicative',&
|
||||
& 'New ML '/)
|
||||
character(len=15), parameter, private :: &
|
||||
& fact_names(0:4)=(/'None ','ILU(n) ',&
|
||||
& 'ILU(eps) ','Sparse SuperLU','UMFPACK Sp. LU'/)
|
||||
|
||||
interface psb_base_precfree
|
||||
module procedure psb_dbase_precfree, psb_zbase_precfree
|
||||
end interface
|
||||
|
||||
interface psb_nullify_baseprec
|
||||
module procedure psb_nullify_dbaseprec, psb_nullify_zbaseprec
|
||||
end interface
|
||||
|
||||
interface psb_check_def
|
||||
module procedure psb_icheck_def, psb_dcheck_def
|
||||
end interface
|
||||
|
||||
interface psb_prec_descr
|
||||
module procedure psb_out_prec_descr, psb_file_prec_descr, &
|
||||
& psb_zout_prec_descr, psb_zfile_prec_descr
|
||||
end interface
|
||||
|
||||
interface psb_prec_short_descr
|
||||
module procedure psb_prec_short_descr, psb_zprec_short_descr
|
||||
end interface
|
||||
|
||||
contains
|
||||
|
||||
subroutine psb_out_prec_descr(p)
|
||||
type(psb_dprec_type), intent(in) :: p
|
||||
call psb_file_prec_descr(6,p)
|
||||
end subroutine psb_out_prec_descr
|
||||
|
||||
subroutine psb_zout_prec_descr(p)
|
||||
type(psb_zprec_type), intent(in) :: p
|
||||
call psb_zfile_prec_descr(6,p)
|
||||
end subroutine psb_zout_prec_descr
|
||||
|
||||
subroutine psb_file_prec_descr(iout,p)
|
||||
integer, intent(in) :: iout
|
||||
type(psb_dprec_type), intent(in) :: p
|
||||
integer :: ilev
|
||||
|
||||
write(iout,*) 'Preconditioner description'
|
||||
if (allocated(p%baseprecv)) then
|
||||
if (size(p%baseprecv)>=1) then
|
||||
write(iout,*) 'Base preconditioner'
|
||||
select case(p%baseprecv(1)%iprcparm(p_type_))
|
||||
case(noprec_)
|
||||
write(iout,*) 'No preconditioning'
|
||||
case(diagsc_)
|
||||
write(iout,*) 'Diagonal scaling'
|
||||
case(bja_)
|
||||
write(iout,*) 'Block Jacobi with: ',&
|
||||
& fact_names(p%baseprecv(1)%iprcparm(f_type_))
|
||||
case(asm_,ras_,ash_,rash_)
|
||||
write(iout,*) 'Additive Schwarz with: ',&
|
||||
& fact_names(p%baseprecv(1)%iprcparm(f_type_))
|
||||
write(iout,*) 'Overlap:',&
|
||||
& p%baseprecv(1)%iprcparm(n_ovr_)
|
||||
write(iout,*) 'Restriction: ',&
|
||||
& restrict_names(p%baseprecv(1)%iprcparm(restr_))
|
||||
write(iout,*) 'Prolongation: ',&
|
||||
& prolong_names(p%baseprecv(1)%iprcparm(prol_))
|
||||
end select
|
||||
end if
|
||||
if (size(p%baseprecv)>=2) then
|
||||
do ilev = 2, size(p%baseprecv)
|
||||
if (.not.allocated(p%baseprecv(ilev)%iprcparm)) then
|
||||
write(iout,*) 'Inconsistent MLPREC part!'
|
||||
return
|
||||
endif
|
||||
|
||||
write(iout,*) 'Multilevel: Level No', ilev
|
||||
write(iout,*) 'Multilevel type: ',&
|
||||
& ml_names(p%baseprecv(ilev)%iprcparm(ml_type_))
|
||||
if (p%baseprecv(ilev)%iprcparm(ml_type_)>no_ml_) then
|
||||
write(iout,*) 'Multilevel aggregation: ', &
|
||||
& aggr_names(p%baseprecv(ilev)%iprcparm(aggr_alg_))
|
||||
write(iout,*) 'Smoother: ', &
|
||||
& smooth_kinds(p%baseprecv(ilev)%iprcparm(smth_kind_))
|
||||
if (p%baseprecv(ilev)%iprcparm(smth_kind_) /= no_smth_) then
|
||||
write(iout,*) 'Smoothing omega: ', &
|
||||
& p%baseprecv(ilev)%dprcparm(smooth_omega_)
|
||||
write(iout,*) 'Smoothing position: ',&
|
||||
& smooth_names(p%baseprecv(ilev)%iprcparm(smth_pos_))
|
||||
end if
|
||||
write(iout,*) 'Coarse matrix: ',&
|
||||
& matrix_names(p%baseprecv(ilev)%iprcparm(coarse_mat_))
|
||||
if (allocated(p%baseprecv(ilev)%nlaggr)) then
|
||||
write(iout,*) 'Aggregation sizes: ', &
|
||||
& sum( p%baseprecv(ilev)%nlaggr(:)),' : ',p%baseprecv(ilev)%nlaggr(:)
|
||||
end if
|
||||
write(iout,*) 'Factorization type: ',&
|
||||
& fact_names(p%baseprecv(ilev)%iprcparm(f_type_))
|
||||
select case(p%baseprecv(ilev)%iprcparm(f_type_))
|
||||
case(f_ilu_n_)
|
||||
write(iout,*) 'Fill level :',p%baseprecv(ilev)%iprcparm(ilu_fill_in_)
|
||||
case(f_ilu_e_)
|
||||
write(iout,*) 'Fill threshold :',p%baseprecv(ilev)%dprcparm(fact_eps_)
|
||||
case(f_slu_,f_umf_)
|
||||
case default
|
||||
write(iout,*) 'Should never get here!'
|
||||
end select
|
||||
write(iout,*) 'Number of Jacobi sweeps: ', &
|
||||
& (p%baseprecv(ilev)%iprcparm(jac_sweeps_))
|
||||
end if
|
||||
end do
|
||||
end if
|
||||
|
||||
else
|
||||
write(iout,*) 'No Base preconditioner available, something is wrong!'
|
||||
return
|
||||
endif
|
||||
|
||||
end subroutine psb_file_prec_descr
|
||||
|
||||
function psb_prec_short_descr(p)
|
||||
type(psb_dprec_type), intent(in) :: p
|
||||
character(len=20) :: psb_prec_short_descr
|
||||
psb_prec_short_descr = ' '
|
||||
!!$ write(iout,*) 'Preconditioner description'
|
||||
!!$ if (associated(p%baseprecv)) then
|
||||
!!$ if (size(p%baseprecv)>=1) then
|
||||
!!$ write(iout,*) 'Base preconditioner'
|
||||
!!$ select case(p%baseprecv(1)%iprcparm(p_type_))
|
||||
!!$ case(noprec_)
|
||||
!!$ write(iout,*) 'No preconditioning'
|
||||
!!$ case(diagsc_)
|
||||
!!$ write(iout,*) 'Diagonal scaling'
|
||||
!!$ case(bja_)
|
||||
!!$ write(iout,*) 'Block Jacobi with: ',&
|
||||
!!$ & fact_names(p%baseprecv(1)%iprcparm(f_type_))
|
||||
!!$ case(asm_,ras_,ash_,rash_)
|
||||
!!$ write(iout,*) 'Additive Schwarz with: ',&
|
||||
!!$ & fact_names(p%baseprecv(1)%iprcparm(f_type_))
|
||||
!!$ write(iout,*) 'Overlap:',&
|
||||
!!$ & p%baseprecv(1)%iprcparm(n_ovr_)
|
||||
!!$ write(iout,*) 'Restriction: ',&
|
||||
!!$ & restrict_names(p%baseprecv(1)%iprcparm(restr_))
|
||||
!!$ write(iout,*) 'Prolongation: ',&
|
||||
!!$ & prolong_names(p%baseprecv(1)%iprcparm(prol_))
|
||||
!!$ end select
|
||||
!!$ end if
|
||||
!!$ if (size(p%baseprecv)>=2) then
|
||||
!!$ if (.not.associated(p%baseprecv(2)%iprcparm)) then
|
||||
!!$ write(iout,*) 'Inconsistent MLPREC part!'
|
||||
!!$ return
|
||||
!!$ endif
|
||||
!!$ write(iout,*) 'Multilevel: ',ml_names(p%baseprecv(2)%iprcparm(ml_type_))
|
||||
!!$ if (p%baseprecv(2)%iprcparm(ml_type_)>no_ml_) then
|
||||
!!$ write(iout,*) 'Multilevel aggregation: ', &
|
||||
!!$ & aggr_names(p%baseprecv(2)%iprcparm(aggr_alg_))
|
||||
!!$ write(iout,*) 'Smoother: ', &
|
||||
!!$ & smooth_kinds(p%baseprecv(2)%iprcparm(smth_kind_))
|
||||
!!$ write(iout,*) 'Smoothing omega: ', p%baseprecv(2)%dprcparm(smooth_omega_)
|
||||
!!$ write(iout,*) 'Smoothing position: ',&
|
||||
!!$ & smooth_names(p%baseprecv(2)%iprcparm(smth_pos_))
|
||||
!!$ write(iout,*) 'Coarse matrix: ',&
|
||||
!!$ & matrix_names(p%baseprecv(2)%iprcparm(coarse_mat_))
|
||||
!!$ write(iout,*) 'Factorization type: ',&
|
||||
!!$ & fact_names(p%baseprecv(2)%iprcparm(f_type_))
|
||||
!!$ select case(p%baseprecv(2)%iprcparm(f_type_))
|
||||
!!$ case(f_ilu_n_)
|
||||
!!$ write(iout,*) 'Fill level :',p%baseprecv(2)%iprcparm(ilu_fill_in_)
|
||||
!!$ case(f_ilu_e_)
|
||||
!!$ write(iout,*) 'Fill threshold :',p%baseprecv(2)%dprcparm(fact_eps_)
|
||||
!!$ case(f_slu_,f_umf_)
|
||||
!!$ case default
|
||||
!!$ write(iout,*) 'Should never get here!'
|
||||
!!$ end select
|
||||
!!$ write(iout,*) 'Number of Jacobi sweeps: ', &
|
||||
!!$ & (p%baseprecv(2)%iprcparm(jac_sweeps_))
|
||||
!!$
|
||||
!!$ end if
|
||||
!!$ end if
|
||||
!!$
|
||||
!!$ else
|
||||
!!$ write(iout,*) 'No Base preconditioner available, something is wrong!'
|
||||
!!$ return
|
||||
!!$ endif
|
||||
|
||||
end function psb_prec_short_descr
|
||||
|
||||
|
||||
subroutine psb_zfile_prec_descr(iout,p)
|
||||
integer, intent(in) :: iout
|
||||
type(psb_zprec_type), intent(in) :: p
|
||||
|
||||
write(iout,*) 'Preconditioner description'
|
||||
if (allocated(p%baseprecv)) then
|
||||
if (size(p%baseprecv)>=1) then
|
||||
write(iout,*) 'Base preconditioner'
|
||||
select case(p%baseprecv(1)%iprcparm(p_type_))
|
||||
case(noprec_)
|
||||
write(iout,*) 'No preconditioning'
|
||||
case(diagsc_)
|
||||
write(iout,*) 'Diagonal scaling'
|
||||
case(bja_)
|
||||
write(iout,*) 'Block Jacobi with: ',&
|
||||
& fact_names(p%baseprecv(1)%iprcparm(f_type_))
|
||||
case(asm_,ras_,ash_,rash_)
|
||||
write(iout,*) 'Additive Schwarz with: ',&
|
||||
& fact_names(p%baseprecv(1)%iprcparm(f_type_))
|
||||
write(iout,*) 'Overlap:',&
|
||||
& p%baseprecv(1)%iprcparm(n_ovr_)
|
||||
write(iout,*) 'Restriction: ',&
|
||||
& restrict_names(p%baseprecv(1)%iprcparm(restr_))
|
||||
write(iout,*) 'Prolongation: ',&
|
||||
& prolong_names(p%baseprecv(1)%iprcparm(prol_))
|
||||
end select
|
||||
end if
|
||||
if (size(p%baseprecv)>=2) then
|
||||
if (.not.allocated(p%baseprecv(2)%iprcparm)) then
|
||||
write(iout,*) 'Inconsistent MLPREC part!'
|
||||
return
|
||||
endif
|
||||
write(iout,*) 'Multilevel: ',ml_names(p%baseprecv(2)%iprcparm(ml_type_))
|
||||
if (p%baseprecv(2)%iprcparm(ml_type_)>no_ml_) then
|
||||
write(iout,*) 'Multilevel aggregation: ', &
|
||||
& aggr_names(p%baseprecv(2)%iprcparm(aggr_alg_))
|
||||
write(iout,*) 'Smoother: ', &
|
||||
& smooth_kinds(p%baseprecv(2)%iprcparm(smth_kind_))
|
||||
if (p%baseprecv(2)%iprcparm(smth_kind_) /= no_smth_) then
|
||||
write(iout,*) 'Smoothing omega: ', p%baseprecv(2)%dprcparm(smooth_omega_)
|
||||
write(iout,*) 'Smoothing position: ',&
|
||||
& smooth_names(p%baseprecv(2)%iprcparm(smth_pos_))
|
||||
end if
|
||||
|
||||
write(iout,*) 'Coarse matrix: ',&
|
||||
& matrix_names(p%baseprecv(2)%iprcparm(coarse_mat_))
|
||||
if (allocated(p%baseprecv(ilev)%nlaggr)) then
|
||||
write(iout,*) 'Aggregation sizes: ', &
|
||||
& sum( p%baseprecv(2)%nlaggr(:)),' : ',p%baseprecv(2)%nlaggr(:)
|
||||
endif
|
||||
write(iout,*) 'Factorization type: ',&
|
||||
& fact_names(p%baseprecv(2)%iprcparm(f_type_))
|
||||
select case(p%baseprecv(2)%iprcparm(f_type_))
|
||||
case(f_ilu_n_)
|
||||
write(iout,*) 'Fill level :',p%baseprecv(2)%iprcparm(ilu_fill_in_)
|
||||
case(f_ilu_e_)
|
||||
write(iout,*) 'Fill threshold :',p%baseprecv(2)%dprcparm(fact_eps_)
|
||||
case(f_slu_,f_umf_)
|
||||
case default
|
||||
write(iout,*) 'Should never get here!'
|
||||
end select
|
||||
write(iout,*) 'Number of Jacobi sweeps: ', &
|
||||
& (p%baseprecv(2)%iprcparm(jac_sweeps_))
|
||||
|
||||
end if
|
||||
end if
|
||||
|
||||
else
|
||||
write(iout,*) 'No Base preconditioner available, something is wrong!'
|
||||
return
|
||||
endif
|
||||
|
||||
end subroutine psb_zfile_prec_descr
|
||||
|
||||
function psb_zprec_short_descr(p)
|
||||
type(psb_zprec_type), intent(in) :: p
|
||||
character(len=20) :: psb_zprec_short_descr
|
||||
psb_zprec_short_descr = ' '
|
||||
!!$ write(iout,*) 'Preconditioner description'
|
||||
!!$ if (associated(p%baseprecv)) then
|
||||
!!$ if (size(p%baseprecv)>=1) then
|
||||
!!$ write(iout,*) 'Base preconditioner'
|
||||
!!$ select case(p%baseprecv(1)%iprcparm(p_type_))
|
||||
!!$ case(noprec_)
|
||||
!!$ write(iout,*) 'No preconditioning'
|
||||
!!$ case(diagsc_)
|
||||
!!$ write(iout,*) 'Diagonal scaling'
|
||||
!!$ case(bja_)
|
||||
!!$ write(iout,*) 'Block Jacobi with: ',&
|
||||
!!$ & fact_names(p%baseprecv(1)%iprcparm(f_type_))
|
||||
!!$ case(asm_,ras_,ash_,rash_)
|
||||
!!$ write(iout,*) 'Additive Schwarz with: ',&
|
||||
!!$ & fact_names(p%baseprecv(1)%iprcparm(f_type_))
|
||||
!!$ write(iout,*) 'Overlap:',&
|
||||
!!$ & p%baseprecv(1)%iprcparm(n_ovr_)
|
||||
!!$ write(iout,*) 'Restriction: ',&
|
||||
!!$ & restrict_names(p%baseprecv(1)%iprcparm(restr_))
|
||||
!!$ write(iout,*) 'Prolongation: ',&
|
||||
!!$ & prolong_names(p%baseprecv(1)%iprcparm(prol_))
|
||||
!!$ end select
|
||||
!!$ end if
|
||||
!!$ if (size(p%baseprecv)>=2) then
|
||||
!!$ if (.not.associated(p%baseprecv(2)%iprcparm)) then
|
||||
!!$ write(iout,*) 'Inconsistent MLPREC part!'
|
||||
!!$ return
|
||||
!!$ endif
|
||||
!!$ write(iout,*) 'Multilevel: ',ml_names(p%baseprecv(2)%iprcparm(ml_type_))
|
||||
!!$ if (p%baseprecv(2)%iprcparm(ml_type_)>no_ml_) then
|
||||
!!$ write(iout,*) 'Multilevel aggregation: ', &
|
||||
!!$ & aggr_names(p%baseprecv(2)%iprcparm(aggr_alg_))
|
||||
!!$ write(iout,*) 'Smoother: ', &
|
||||
!!$ & smooth_kinds(p%baseprecv(2)%iprcparm(smth_kind_))
|
||||
!!$ write(iout,*) 'Smoothing omega: ', p%baseprecv(2)%dprcparm(smooth_omega_)
|
||||
!!$ write(iout,*) 'Smoothing position: ',&
|
||||
!!$ & smooth_names(p%baseprecv(2)%iprcparm(smth_pos_))
|
||||
!!$ write(iout,*) 'Coarse matrix: ',&
|
||||
!!$ & matrix_names(p%baseprecv(2)%iprcparm(coarse_mat_))
|
||||
!!$ write(iout,*) 'Factorization type: ',&
|
||||
!!$ & fact_names(p%baseprecv(2)%iprcparm(f_type_))
|
||||
!!$ select case(p%baseprecv(2)%iprcparm(f_type_))
|
||||
!!$ case(f_ilu_n_)
|
||||
!!$ write(iout,*) 'Fill level :',p%baseprecv(2)%iprcparm(ilu_fill_in_)
|
||||
!!$ case(f_ilu_e_)
|
||||
!!$ write(iout,*) 'Fill threshold :',p%baseprecv(2)%dprcparm(fact_eps_)
|
||||
!!$ case(f_slu_,f_umf_)
|
||||
!!$ case default
|
||||
!!$ write(iout,*) 'Should never get here!'
|
||||
!!$ end select
|
||||
!!$ write(iout,*) 'Number of Jacobi sweeps: ', &
|
||||
!!$ & (p%baseprecv(2)%iprcparm(jac_sweeps_))
|
||||
!!$
|
||||
!!$ end if
|
||||
!!$ end if
|
||||
!!$
|
||||
!!$ else
|
||||
!!$ write(iout,*) 'No Base preconditioner available, something is wrong!'
|
||||
!!$ return
|
||||
!!$ endif
|
||||
|
||||
end function psb_zprec_short_descr
|
||||
|
||||
|
||||
|
||||
|
||||
function is_legal_base_prec(ip)
|
||||
integer, intent(in) :: ip
|
||||
logical :: is_legal_base_prec
|
||||
|
||||
is_legal_base_prec = ((ip>=noprec_).and.(ip<=rash_))
|
||||
return
|
||||
end function is_legal_base_prec
|
||||
function is_legal_n_ovr(ip)
|
||||
integer, intent(in) :: ip
|
||||
logical :: is_legal_n_ovr
|
||||
|
||||
is_legal_n_ovr = (ip >=0)
|
||||
return
|
||||
end function is_legal_n_ovr
|
||||
function is_legal_renum(ip)
|
||||
integer, intent(in) :: ip
|
||||
logical :: is_legal_renum
|
||||
! For the time being we are disabling renumbering options.
|
||||
is_legal_renum = (ip ==0)
|
||||
return
|
||||
end function is_legal_renum
|
||||
function is_legal_jac_sweeps(ip)
|
||||
integer, intent(in) :: ip
|
||||
logical :: is_legal_jac_sweeps
|
||||
|
||||
is_legal_jac_sweeps = (ip >= 1)
|
||||
return
|
||||
end function is_legal_jac_sweeps
|
||||
function is_legal_prolong(ip)
|
||||
integer, intent(in) :: ip
|
||||
logical :: is_legal_prolong
|
||||
|
||||
is_legal_prolong = ((ip>=psb_none_).and.(ip<=psb_square_root_))
|
||||
return
|
||||
end function is_legal_prolong
|
||||
function is_legal_restrict(ip)
|
||||
integer, intent(in) :: ip
|
||||
logical :: is_legal_restrict
|
||||
is_legal_restrict = ((ip==psb_nohalo_).or.(ip==psb_halo_))
|
||||
return
|
||||
end function is_legal_restrict
|
||||
function is_legal_ml_type(ip)
|
||||
integer, intent(in) :: ip
|
||||
logical :: is_legal_ml_type
|
||||
|
||||
is_legal_ml_type = ((ip>=no_ml_).and.(ip<=max_ml_))
|
||||
return
|
||||
end function is_legal_ml_type
|
||||
function is_legal_ml_aggr_kind(ip)
|
||||
integer, intent(in) :: ip
|
||||
logical :: is_legal_ml_aggr_kind
|
||||
|
||||
is_legal_ml_aggr_kind = ((ip>=loc_aggr_).and.(ip<=max_aggr_))
|
||||
return
|
||||
end function is_legal_ml_aggr_kind
|
||||
function is_legal_ml_smooth_pos(ip)
|
||||
integer, intent(in) :: ip
|
||||
logical :: is_legal_ml_smooth_pos
|
||||
|
||||
is_legal_ml_smooth_pos = ((ip>=pre_smooth_).and.(ip<=max_smooth_))
|
||||
return
|
||||
end function is_legal_ml_smooth_pos
|
||||
function is_legal_ml_smth_kind(ip)
|
||||
integer, intent(in) :: ip
|
||||
logical :: is_legal_ml_smth_kind
|
||||
|
||||
is_legal_ml_smth_kind = ((ip>=no_smth_).and.(ip<=smth_biz_))
|
||||
return
|
||||
end function is_legal_ml_smth_kind
|
||||
function is_legal_ml_coarse_mat(ip)
|
||||
integer, intent(in) :: ip
|
||||
logical :: is_legal_ml_coarse_mat
|
||||
|
||||
is_legal_ml_coarse_mat = ((ip>=mat_distr_).and.(ip<=mat_repl_))
|
||||
return
|
||||
end function is_legal_ml_coarse_mat
|
||||
function is_legal_ml_fact(ip)
|
||||
integer, intent(in) :: ip
|
||||
logical :: is_legal_ml_fact
|
||||
|
||||
is_legal_ml_fact = ((ip>=f_ilu_n_).and.(ip<=f_umf_))
|
||||
return
|
||||
end function is_legal_ml_fact
|
||||
function is_legal_ml_lev(ip)
|
||||
integer, intent(in) :: ip
|
||||
logical :: is_legal_ml_lev
|
||||
|
||||
is_legal_ml_lev = (ip>=0)
|
||||
return
|
||||
end function is_legal_ml_lev
|
||||
function is_legal_omega(ip)
|
||||
real(kind(1.d0)), intent(in) :: ip
|
||||
logical :: is_legal_omega
|
||||
|
||||
is_legal_omega = ((ip>=0.0d0).and.(ip<=2.0d0))
|
||||
return
|
||||
end function is_legal_omega
|
||||
function is_legal_ml_eps(ip)
|
||||
real(kind(1.d0)), intent(in) :: ip
|
||||
logical :: is_legal_ml_eps
|
||||
|
||||
is_legal_ml_eps = (ip>=0.0d0)
|
||||
return
|
||||
end function is_legal_ml_eps
|
||||
|
||||
|
||||
subroutine psb_icheck_def(ip,name,id,is_legal)
|
||||
integer, intent(inout) :: ip
|
||||
integer, intent(in) :: id
|
||||
character(len=*), intent(in) :: name
|
||||
interface
|
||||
function is_legal(i)
|
||||
integer, intent(in) :: i
|
||||
logical :: is_legal
|
||||
end function is_legal
|
||||
end interface
|
||||
|
||||
if (.not.is_legal(ip)) then
|
||||
write(0,*) 'Illegal value for ',name,' :',ip, '. defaulting to ',id
|
||||
ip = id
|
||||
end if
|
||||
end subroutine psb_icheck_def
|
||||
|
||||
subroutine psb_dcheck_def(ip,name,id,is_legal)
|
||||
real(kind(1.d0)), intent(inout) :: ip
|
||||
real(kind(1.d0)), intent(in) :: id
|
||||
character(len=*), intent(in) :: name
|
||||
interface
|
||||
function is_legal(i)
|
||||
real(kind(1.d0)), intent(in) :: i
|
||||
logical :: is_legal
|
||||
end function is_legal
|
||||
end interface
|
||||
|
||||
if (.not.is_legal(ip)) then
|
||||
write(0,*) 'Illegal value for ',name,' :',ip, '. defaulting to ',id
|
||||
ip = id
|
||||
end if
|
||||
end subroutine psb_dcheck_def
|
||||
|
||||
subroutine psb_dbase_precfree(p,info)
|
||||
use psb_base_mod
|
||||
|
||||
type(psb_dbaseprc_type), intent(inout) :: p
|
||||
integer, intent(out) :: info
|
||||
integer :: i
|
||||
|
||||
info = 0
|
||||
|
||||
! Actually we migh just deallocate the top level array, except
|
||||
! for the inner UMFPACK or SLU stuff
|
||||
|
||||
if (allocated(p%d)) then
|
||||
deallocate(p%d,stat=info)
|
||||
end if
|
||||
|
||||
if (allocated(p%av)) then
|
||||
do i=1,size(p%av)
|
||||
call psb_sp_free(p%av(i),info)
|
||||
if (info /= 0) then
|
||||
! Actually, we don't care here about this.
|
||||
! Just let it go.
|
||||
! return
|
||||
end if
|
||||
enddo
|
||||
deallocate(p%av,stat=info)
|
||||
end if
|
||||
|
||||
if (allocated(p%desc_data%matrix_data)) &
|
||||
& call psb_cdfree(p%desc_data,info)
|
||||
if (allocated(p%desc_ac%matrix_data)) &
|
||||
& call psb_cdfree(p%desc_ac,info)
|
||||
|
||||
if (allocated(p%dprcparm)) then
|
||||
deallocate(p%dprcparm,stat=info)
|
||||
end if
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(p%base_a)
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(p%base_desc)
|
||||
|
||||
if (allocated(p%dorig)) then
|
||||
deallocate(p%dorig,stat=info)
|
||||
endif
|
||||
|
||||
if (allocated(p%mlia)) then
|
||||
deallocate(p%mlia,stat=info)
|
||||
endif
|
||||
|
||||
if (allocated(p%nlaggr)) then
|
||||
deallocate(p%nlaggr,stat=info)
|
||||
endif
|
||||
|
||||
if (allocated(p%perm)) then
|
||||
deallocate(p%perm,stat=info)
|
||||
endif
|
||||
|
||||
if (allocated(p%invperm)) then
|
||||
deallocate(p%invperm,stat=info)
|
||||
endif
|
||||
|
||||
if (allocated(p%iprcparm)) then
|
||||
if (p%iprcparm(f_type_)==f_slu_) then
|
||||
call psb_dslu_free(p%iprcparm(slu_ptr_),info)
|
||||
end if
|
||||
if (p%iprcparm(f_type_)==f_umf_) then
|
||||
call psb_dumf_free(p%iprcparm(umf_symptr_),&
|
||||
& p%iprcparm(umf_numptr_),info)
|
||||
end if
|
||||
deallocate(p%iprcparm,stat=info)
|
||||
end if
|
||||
call psb_nullify_baseprec(p)
|
||||
end subroutine psb_dbase_precfree
|
||||
|
||||
subroutine psb_nullify_dbaseprec(p)
|
||||
use psb_base_mod
|
||||
|
||||
type(psb_dbaseprc_type), intent(inout) :: p
|
||||
|
||||
nullify(p%base_a)
|
||||
nullify(p%base_desc)
|
||||
!!$ nullify(p%av,p%d,p%iprcparm,p%dprcparm,p%perm,p%invperm,p%mlia,&
|
||||
!!$ & p%nlaggr,p%base_a,p%base_desc,p%dorig,p%desc_data, p%desc_ac)
|
||||
|
||||
end subroutine psb_nullify_dbaseprec
|
||||
|
||||
subroutine psb_zbase_precfree(p,info)
|
||||
use psb_base_mod
|
||||
type(psb_zbaseprc_type), intent(inout) :: p
|
||||
integer, intent(out) :: info
|
||||
integer :: i
|
||||
|
||||
info = 0
|
||||
|
||||
if (allocated(p%d)) then
|
||||
deallocate(p%d,stat=info)
|
||||
end if
|
||||
|
||||
if (allocated(p%av)) then
|
||||
do i=1,size(p%av)
|
||||
call psb_sp_free(p%av(i),info)
|
||||
if (info /= 0) then
|
||||
! Actually, we don't care here about this.
|
||||
! Just let it go.
|
||||
! return
|
||||
end if
|
||||
enddo
|
||||
deallocate(p%av,stat=info)
|
||||
|
||||
end if
|
||||
! call psb_cdfree(p%desc_data,info)
|
||||
! call psb_cdfree(p%desc_ac,info)
|
||||
|
||||
if (allocated(p%dprcparm)) then
|
||||
deallocate(p%dprcparm,stat=info)
|
||||
end if
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(p%base_a)
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(p%base_desc)
|
||||
|
||||
if (allocated(p%dorig)) then
|
||||
deallocate(p%dorig,stat=info)
|
||||
endif
|
||||
|
||||
if (allocated(p%mlia)) then
|
||||
deallocate(p%mlia,stat=info)
|
||||
endif
|
||||
|
||||
if (allocated(p%nlaggr)) then
|
||||
deallocate(p%nlaggr,stat=info)
|
||||
endif
|
||||
|
||||
if (allocated(p%perm)) then
|
||||
deallocate(p%perm,stat=info)
|
||||
endif
|
||||
|
||||
if (allocated(p%invperm)) then
|
||||
deallocate(p%invperm,stat=info)
|
||||
endif
|
||||
|
||||
if (allocated(p%iprcparm)) then
|
||||
if (p%iprcparm(f_type_)==f_slu_) then
|
||||
call psb_zslu_free(p%iprcparm(slu_ptr_),info)
|
||||
end if
|
||||
if (p%iprcparm(f_type_)==f_umf_) then
|
||||
call psb_zumf_free(p%iprcparm(umf_symptr_),&
|
||||
& p%iprcparm(umf_numptr_),info)
|
||||
end if
|
||||
deallocate(p%iprcparm,stat=info)
|
||||
end if
|
||||
call psb_nullify_baseprec(p)
|
||||
end subroutine psb_zbase_precfree
|
||||
|
||||
subroutine psb_nullify_zbaseprec(p)
|
||||
use psb_base_mod
|
||||
|
||||
type(psb_zbaseprc_type), intent(inout) :: p
|
||||
|
||||
|
||||
nullify(p%base_a)
|
||||
nullify(p%base_desc)
|
||||
|
||||
end subroutine psb_nullify_zbaseprec
|
||||
|
||||
|
||||
function pr_to_str(iprec)
|
||||
|
||||
integer, intent(in) :: iprec
|
||||
character(len=10) :: pr_to_str
|
||||
|
||||
select case(iprec)
|
||||
case(noprec_)
|
||||
pr_to_str='NOPREC'
|
||||
case(diagsc_)
|
||||
pr_to_str='DIAGSC'
|
||||
case(bja_)
|
||||
pr_to_str='BJA'
|
||||
case(asm_)
|
||||
pr_to_str='ASM'
|
||||
case(ash_)
|
||||
pr_to_str='ASM'
|
||||
case(ras_)
|
||||
pr_to_str='ASM'
|
||||
case(rash_)
|
||||
pr_to_str='ASM'
|
||||
end select
|
||||
|
||||
end function pr_to_str
|
||||
|
||||
end module psb_prec_type
|
||||
@ -0,0 +1,373 @@
|
||||
/*
|
||||
* 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
|
||||
* 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.
|
||||
*
|
||||
*/
|
||||
/* This file is an interface to the SuperLU routines for sparse
|
||||
factorization. It was obtaned by modifying the
|
||||
c_fortran_dgssv.c file from the SuperLU source distribution;
|
||||
original copyright terms reproduced below.
|
||||
|
||||
PSBLAS v 2.0 */
|
||||
|
||||
|
||||
/* =====================
|
||||
|
||||
Copyright (c) 2003, The Regents of the University of California, through
|
||||
Lawrence Berkeley National Laboratory (subject to receipt of any required
|
||||
approvals from U.S. Dept. of Energy)
|
||||
|
||||
All rights reserved.
|
||||
|
||||
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) Neither the name of Lawrence Berkeley National Laboratory, U.S. Dept. of
|
||||
Energy nor the names of its contributors may be used to endorse or promote
|
||||
products derived from this software without specific prior 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 COPYRIGHT OWNER OR
|
||||
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.
|
||||
|
||||
*/
|
||||
|
||||
/*
|
||||
* -- SuperLU routine (version 3.0) --
|
||||
* Univ. of California Berkeley, Xerox Palo Alto Research Center,
|
||||
* and Lawrence Berkeley National Lab.
|
||||
* October 15, 2003
|
||||
*
|
||||
*/
|
||||
|
||||
#ifdef Have_SLU_
|
||||
#include "dsp_defs.h"
|
||||
|
||||
#define HANDLE_SIZE 8
|
||||
/* kind of integer to hold a pointer. Use int.
|
||||
This might need to be changed on 64-bit systems. */
|
||||
#ifdef LargeFptr
|
||||
typedef long long fptr; /* 32-bit by default */
|
||||
#else
|
||||
typedef int fptr; /* 32-bit by default */
|
||||
#endif
|
||||
|
||||
typedef struct {
|
||||
SuperMatrix *L;
|
||||
SuperMatrix *U;
|
||||
int *perm_c;
|
||||
int *perm_r;
|
||||
} factors_t;
|
||||
|
||||
|
||||
#else
|
||||
|
||||
#include <stdio.h>
|
||||
|
||||
#endif
|
||||
|
||||
|
||||
#ifdef Add_
|
||||
#define psb_dslu_factor_ psb_dslu_factor_
|
||||
#define psb_dslu_solve_ psb_dslu_solve_
|
||||
#define psb_dslu_free_ psb_dslu_free_
|
||||
#endif
|
||||
#ifdef AddDouble_
|
||||
#define psb_dslu_factor_ psb_dslu_factor__
|
||||
#define psb_dslu_solve_ psb_dslu_solve__
|
||||
#define psb_dslu_free_ psb_dslu_free__
|
||||
#endif
|
||||
#ifdef NoChange
|
||||
#define psb_dslu_factor_ psb_dslu_factor
|
||||
#define psb_dslu_solve_ psb_dslu_solve
|
||||
#define psb_dslu_free_ psb_dslu_free
|
||||
#endif
|
||||
|
||||
|
||||
|
||||
|
||||
void
|
||||
psb_dslu_factor_(int *n, int *nnz,
|
||||
double *values, int *rowptr, int *colind,
|
||||
#ifdef Have_SLU_
|
||||
fptr *f_factors, /* a handle containing the address
|
||||
pointing to the factored matrices */
|
||||
#else
|
||||
void *f_factors,
|
||||
#endif
|
||||
int *info)
|
||||
|
||||
{
|
||||
/*
|
||||
* This routine can be called from Fortran.
|
||||
* performs LU decomposition.
|
||||
*
|
||||
* f_factors (input/output) fptr*
|
||||
* On output contains the pointer pointing to
|
||||
* the structure of the factored matrices.
|
||||
*
|
||||
*/
|
||||
|
||||
#ifdef Have_SLU_
|
||||
SuperMatrix A, AC, B;
|
||||
SuperMatrix *L, *U;
|
||||
int *perm_r; /* row permutations from partial pivoting */
|
||||
int *perm_c; /* column permutation vector */
|
||||
int *etree; /* column elimination tree */
|
||||
SCformat *Lstore;
|
||||
NCformat *Ustore;
|
||||
int i, panel_size, permc_spec, relax;
|
||||
trans_t trans;
|
||||
double drop_tol = 0.0;
|
||||
mem_usage_t mem_usage;
|
||||
superlu_options_t options;
|
||||
SuperLUStat_t stat;
|
||||
factors_t *LUfactors;
|
||||
|
||||
trans = NOTRANS;
|
||||
|
||||
|
||||
/* Set the default input options. */
|
||||
set_default_options(&options);
|
||||
|
||||
/* Initialize the statistics variables. */
|
||||
StatInit(&stat);
|
||||
|
||||
/* Adjust to 0-based indexing */
|
||||
for (i = 0; i < *nnz; ++i) --colind[i];
|
||||
for (i = 0; i <= *n; ++i) --rowptr[i];
|
||||
|
||||
dCreate_CompRow_Matrix(&A, *n, *n, *nnz, values, colind, rowptr,
|
||||
SLU_NR, SLU_D, SLU_GE);
|
||||
L = (SuperMatrix *) SUPERLU_MALLOC( sizeof(SuperMatrix) );
|
||||
U = (SuperMatrix *) SUPERLU_MALLOC( sizeof(SuperMatrix) );
|
||||
if ( !(perm_r = intMalloc(*n)) ) ABORT("Malloc fails for perm_r[].");
|
||||
if ( !(perm_c = intMalloc(*n)) ) ABORT("Malloc fails for perm_c[].");
|
||||
if ( !(etree = intMalloc(*n)) ) ABORT("Malloc fails for etree[].");
|
||||
|
||||
/*
|
||||
* Get column permutation vector perm_c[], according to permc_spec:
|
||||
* permc_spec = 0: natural ordering
|
||||
* permc_spec = 1: minimum degree on structure of A'*A
|
||||
* permc_spec = 2: minimum degree on structure of A'+A
|
||||
* permc_spec = 3: approximate minimum degree for unsymmetric matrices
|
||||
*/
|
||||
options.ColPerm=2;
|
||||
permc_spec = options.ColPerm;
|
||||
get_perm_c(permc_spec, &A, perm_c);
|
||||
|
||||
sp_preorder(&options, &A, perm_c, etree, &AC);
|
||||
|
||||
panel_size = sp_ienv(1);
|
||||
relax = sp_ienv(2);
|
||||
|
||||
dgstrf(&options, &AC, drop_tol, relax, panel_size,
|
||||
etree, NULL, 0, perm_c, perm_r, L, U, &stat, info);
|
||||
|
||||
if ( *info == 0 ) {
|
||||
Lstore = (SCformat *) L->Store;
|
||||
Ustore = (NCformat *) U->Store;
|
||||
dQuerySpace(L, U, &mem_usage);
|
||||
#if 0
|
||||
printf("No of nonzeros in factor L = %d\n", Lstore->nnz);
|
||||
printf("No of nonzeros in factor U = %d\n", Ustore->nnz);
|
||||
printf("No of nonzeros in L+U = %d\n", Lstore->nnz + Ustore->nnz);
|
||||
printf("L\\U MB %.3f\ttotal MB needed %.3f\texpansions %d\n",
|
||||
mem_usage.for_lu/1e6, mem_usage.total_needed/1e6,
|
||||
mem_usage.expansions);
|
||||
#endif
|
||||
} else {
|
||||
printf("dgstrf() error returns INFO= %d\n", *info);
|
||||
if ( *info <= *n ) { /* factorization completes */
|
||||
dQuerySpace(L, U, &mem_usage);
|
||||
printf("L\\U MB %.3f\ttotal MB needed %.3f\texpansions %d\n",
|
||||
mem_usage.for_lu/1e6, mem_usage.total_needed/1e6,
|
||||
mem_usage.expansions);
|
||||
}
|
||||
}
|
||||
|
||||
/* Restore to 1-based indexing */
|
||||
for (i = 0; i < *nnz; ++i) ++colind[i];
|
||||
for (i = 0; i <= *n; ++i) ++rowptr[i];
|
||||
|
||||
/* Save the LU factors in the factors handle */
|
||||
LUfactors = (factors_t*) SUPERLU_MALLOC(sizeof(factors_t));
|
||||
LUfactors->L = L;
|
||||
LUfactors->U = U;
|
||||
LUfactors->perm_c = perm_c;
|
||||
LUfactors->perm_r = perm_r;
|
||||
*f_factors = (fptr) LUfactors;
|
||||
|
||||
/* Free un-wanted storage */
|
||||
SUPERLU_FREE(etree);
|
||||
Destroy_SuperMatrix_Store(&A);
|
||||
Destroy_CompCol_Permuted(&AC);
|
||||
StatFree(&stat);
|
||||
#else
|
||||
fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n");
|
||||
*info=-1;
|
||||
#endif
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
psb_dslu_solve_(int *itrans, int *n, int *nrhs,
|
||||
double *b, int *ldb,
|
||||
#ifdef Have_SLU_
|
||||
fptr *f_factors, /* a handle containing the address
|
||||
pointing to the factored matrices */
|
||||
#else
|
||||
void *f_factors,
|
||||
#endif
|
||||
int *info)
|
||||
|
||||
{
|
||||
/*
|
||||
* This routine can be called from Fortran.
|
||||
* performs triangular solve
|
||||
*
|
||||
*/
|
||||
#ifdef Have_SLU_
|
||||
SuperMatrix A, AC, B;
|
||||
SuperMatrix *L, *U;
|
||||
int *perm_r; /* row permutations from partial pivoting */
|
||||
int *perm_c; /* column permutation vector */
|
||||
int *etree; /* column elimination tree */
|
||||
SCformat *Lstore;
|
||||
NCformat *Ustore;
|
||||
int i, panel_size, permc_spec, relax;
|
||||
trans_t trans;
|
||||
double drop_tol = 0.0;
|
||||
mem_usage_t mem_usage;
|
||||
superlu_options_t options;
|
||||
SuperLUStat_t stat;
|
||||
factors_t *LUfactors;
|
||||
|
||||
if (*itrans == 0) {
|
||||
trans = NOTRANS;
|
||||
} else if (*itrans ==1) {
|
||||
trans = TRANS;
|
||||
} else if (*itrans ==2) {
|
||||
trans = CONJ;
|
||||
} else {
|
||||
trans = NOTRANS;
|
||||
}
|
||||
/* Initialize the statistics variables. */
|
||||
StatInit(&stat);
|
||||
|
||||
/* Extract the LU factors in the factors handle */
|
||||
LUfactors = (factors_t*) *f_factors;
|
||||
L = LUfactors->L;
|
||||
U = LUfactors->U;
|
||||
perm_c = LUfactors->perm_c;
|
||||
perm_r = LUfactors->perm_r;
|
||||
|
||||
dCreate_Dense_Matrix(&B, *n, *nrhs, b, *ldb, SLU_DN, SLU_D, SLU_GE);
|
||||
/* Solve the system A*X=B, overwriting B with X. */
|
||||
dgstrs (trans, L, U, perm_c, perm_r, &B, &stat, info);
|
||||
|
||||
Destroy_SuperMatrix_Store(&B);
|
||||
StatFree(&stat);
|
||||
#else
|
||||
fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n");
|
||||
*info=-1;
|
||||
#endif
|
||||
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
psb_dslu_free_(
|
||||
#ifdef Have_SLU_
|
||||
fptr *f_factors, /* a handle containing the address
|
||||
pointing to the factored matrices */
|
||||
#else
|
||||
void *f_factors,
|
||||
#endif
|
||||
int *info)
|
||||
|
||||
{
|
||||
/*
|
||||
* This routine can be called from Fortran.
|
||||
*
|
||||
* free all storage in the end
|
||||
*
|
||||
*/
|
||||
#ifdef Have_SLU_
|
||||
SuperMatrix A, AC, B;
|
||||
SuperMatrix *L, *U;
|
||||
int *perm_r; /* row permutations from partial pivoting */
|
||||
int *perm_c; /* column permutation vector */
|
||||
int *etree; /* column elimination tree */
|
||||
SCformat *Lstore;
|
||||
NCformat *Ustore;
|
||||
int i, panel_size, permc_spec, relax;
|
||||
trans_t trans;
|
||||
double drop_tol = 0.0;
|
||||
mem_usage_t mem_usage;
|
||||
superlu_options_t options;
|
||||
SuperLUStat_t stat;
|
||||
factors_t *LUfactors;
|
||||
|
||||
trans = NOTRANS;
|
||||
/* Free the LU factors in the factors handle */
|
||||
LUfactors = (factors_t*) *f_factors;
|
||||
SUPERLU_FREE (LUfactors->perm_r);
|
||||
SUPERLU_FREE (LUfactors->perm_c);
|
||||
Destroy_SuperNode_Matrix(LUfactors->L);
|
||||
Destroy_CompCol_Matrix(LUfactors->U);
|
||||
SUPERLU_FREE (LUfactors->L);
|
||||
SUPERLU_FREE (LUfactors->U);
|
||||
SUPERLU_FREE (LUfactors);
|
||||
*info = 0;
|
||||
#else
|
||||
fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n");
|
||||
*info=-1;
|
||||
#endif
|
||||
}
|
||||
|
||||
|
||||
@ -0,0 +1,233 @@
|
||||
/*
|
||||
* 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
|
||||
* 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.
|
||||
*
|
||||
*/
|
||||
/* This file is an interface to the UMFPACK routines for sparse
|
||||
factorization. It was obtained by adapting umfpack_di_demo
|
||||
under the original copyright terms reproduced below.
|
||||
|
||||
PSBLAS v 2.0 */
|
||||
|
||||
|
||||
/* =====================
|
||||
UMFPACK Version 4.4 (Jan. 28, 2005), Copyright (c) 2005 by Timothy A.
|
||||
Davis. All Rights Reserved.
|
||||
|
||||
UMFPACK License:
|
||||
|
||||
Your use or distribution of UMFPACK or any modified version of
|
||||
UMFPACK implies that you agree to this License.
|
||||
|
||||
THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY
|
||||
EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK.
|
||||
|
||||
Permission is hereby granted to use or copy this program, provided
|
||||
that the Copyright, this License, and the Availability of the original
|
||||
version is retained on all copies. User documentation of any code that
|
||||
uses UMFPACK or any modified version of UMFPACK code must cite the
|
||||
Copyright, this License, the Availability note, and "Used by permission."
|
||||
Permission to modify the code and to distribute modified code is granted,
|
||||
provided the Copyright, this License, and the Availability note are
|
||||
retained, and a notice that the code was modified is included. This
|
||||
software was developed with support from the National Science Foundation,
|
||||
and is provided to you free of charge.
|
||||
|
||||
Availability:
|
||||
|
||||
http://www.cise.ufl.edu/research/sparse/umfpack
|
||||
|
||||
*/
|
||||
|
||||
|
||||
|
||||
#ifdef Add_
|
||||
#define psb_dumf_factor_ psb_dumf_factor_
|
||||
#define psb_dumf_solve_ psb_dumf_solve_
|
||||
#define psb_dumf_free_ psb_dumf_free_
|
||||
#endif
|
||||
#ifdef AddDouble_
|
||||
#define psb_dumf_factor_ psb_dumf_factor__
|
||||
#define psb_dumf_solve_ psb_dumf_solve__
|
||||
#define psb_dumf_free_ psb_dumf_free__
|
||||
#endif
|
||||
#ifdef NoChange
|
||||
#define psb_dumf_factor_ psb_dumf_factor
|
||||
#define psb_dumf_solve_ psb_dumf_solve
|
||||
#define psb_dumf_free_ psb_dumf_free
|
||||
#endif
|
||||
|
||||
|
||||
#include <stdio.h>
|
||||
#ifdef Have_UMF_
|
||||
#include "umfpack.h"
|
||||
#endif
|
||||
|
||||
#ifdef LargeFptr
|
||||
typedef long long fptr; /* 64-bit*/
|
||||
#else
|
||||
typedef int fptr; /* 32-bit by default */
|
||||
#endif
|
||||
|
||||
void
|
||||
psb_dumf_factor_(int *n, int *nnz,
|
||||
double *values, int *rowind, int *colptr,
|
||||
#ifdef Have_UMF_
|
||||
fptr *symptr,
|
||||
fptr *numptr,
|
||||
|
||||
#else
|
||||
void *symptr,
|
||||
void *numptr,
|
||||
#endif
|
||||
int *info)
|
||||
|
||||
{
|
||||
|
||||
#ifdef Have_UMF_
|
||||
double Info [UMFPACK_INFO], Control [UMFPACK_CONTROL];
|
||||
void *Symbolic, *Numeric ;
|
||||
int i;
|
||||
|
||||
|
||||
umfpack_di_defaults(Control);
|
||||
|
||||
for (i = 0; i <= *n; ++i) --colptr[i];
|
||||
for (i = 0; i < *nnz; ++i) --rowind[i];
|
||||
*info = umfpack_di_symbolic (*n, *n, colptr, rowind, values, &Symbolic,
|
||||
Control, Info);
|
||||
|
||||
|
||||
if ( *info == UMFPACK_OK ) {
|
||||
*info = 0;
|
||||
} else {
|
||||
printf("umfpack_di_symbolic() error returns INFO= %d\n", *info);
|
||||
*info = -11;
|
||||
*numptr = (fptr) NULL;
|
||||
return;
|
||||
}
|
||||
|
||||
*symptr = (fptr) Symbolic;
|
||||
|
||||
*info = umfpack_di_numeric (colptr, rowind, values, Symbolic, &Numeric,
|
||||
Control, Info) ;
|
||||
|
||||
|
||||
if ( *info == UMFPACK_OK ) {
|
||||
*info = 0;
|
||||
*numptr = (fptr) Numeric;
|
||||
} else {
|
||||
printf("umfpack_di_numeric() error returns INFO= %d\n", *info);
|
||||
*info = -12;
|
||||
*numptr = (fptr) NULL;
|
||||
}
|
||||
|
||||
for (i = 0; i <= *n; ++i) ++colptr[i];
|
||||
for (i = 0; i < *nnz; ++i) ++rowind[i];
|
||||
#else
|
||||
fprintf(stderr," UMF Not Configured, fix make.inc and recompile\n");
|
||||
*info=-1;
|
||||
#endif
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
psb_dumf_solve_(int *itrans, int *n,
|
||||
double *x, double *b, int *ldb,
|
||||
#ifdef Have_UMF_
|
||||
fptr *numptr,
|
||||
|
||||
#else
|
||||
void *numptr,
|
||||
#endif
|
||||
int *info)
|
||||
|
||||
{
|
||||
#ifdef Have_UMF_
|
||||
double Info [UMFPACK_INFO], Control [UMFPACK_CONTROL];
|
||||
void *Symbolic, *Numeric ;
|
||||
int i,trans;
|
||||
|
||||
|
||||
umfpack_di_defaults(Control);
|
||||
Control[UMFPACK_IRSTEP]=0;
|
||||
|
||||
|
||||
if (*itrans == 0) {
|
||||
trans = UMFPACK_A;
|
||||
} else if (*itrans ==1) {
|
||||
trans = UMFPACK_At;
|
||||
} else {
|
||||
trans = UMFPACK_A;
|
||||
}
|
||||
|
||||
*info = umfpack_di_solve(trans,NULL,NULL,NULL,
|
||||
x,b,(void *) *numptr,Control,Info);
|
||||
|
||||
#else
|
||||
fprintf(stderr," UMF Not Configured, fix make.inc and recompile\n");
|
||||
*info=-1;
|
||||
#endif
|
||||
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
psb_dumf_free_(
|
||||
#ifdef Have_UMF_
|
||||
fptr *symptr,
|
||||
fptr *numptr,
|
||||
|
||||
#else
|
||||
void *symptr,
|
||||
void *numptr,
|
||||
#endif
|
||||
int *info)
|
||||
|
||||
{
|
||||
#ifdef Have_UMF_
|
||||
void *Symbolic, *Numeric ;
|
||||
Symbolic = (void *) *symptr;
|
||||
Numeric = (void *) *numptr;
|
||||
|
||||
umfpack_di_free_numeric(&Numeric);
|
||||
umfpack_di_free_symbolic(&Symbolic);
|
||||
*info=0;
|
||||
#else
|
||||
fprintf(stderr," UMF Not Configured, fix make.inc and recompile\n");
|
||||
*info=-1;
|
||||
#endif
|
||||
}
|
||||
|
||||
|
||||
@ -0,0 +1,236 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
!*****************************************************************************
|
||||
!* *
|
||||
!* This routine does two things: *
|
||||
!* 1. Builds the auxiliary descriptor. This is always done even for *
|
||||
!* Block Jacobi. *
|
||||
!* 2. Retrieves the remote matrix pieces. *
|
||||
!* *
|
||||
!* All of 1. is done under psb_cdovr, which is independent of CSR, and *
|
||||
!* has been placed in the TOOLS directory because it might be used for *
|
||||
!* building a descriptor for an extended stencil in a PDE solver without *
|
||||
!* necessarily applying AS precond. *
|
||||
!* *
|
||||
!* *
|
||||
!* *
|
||||
!* *
|
||||
!* *
|
||||
!*****************************************************************************
|
||||
Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
|
||||
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
Implicit None
|
||||
|
||||
! .. Array Arguments ..
|
||||
integer, intent(in) :: ptype,novr
|
||||
Type(psb_zspmat_type), Intent(in) :: a
|
||||
Type(psb_zspmat_type), Intent(inout) :: blk
|
||||
integer, intent(out) :: info
|
||||
Type(psb_desc_type), Intent(inout) :: desc_p
|
||||
Type(psb_desc_type), Intent(in) :: desc_data
|
||||
Character, Intent(in) :: upd
|
||||
character(len=5), optional :: outfmt
|
||||
|
||||
|
||||
real(kind(1.d0)) :: t1,t2,t3,mpi_wtime
|
||||
external mpi_wtime
|
||||
integer icomm
|
||||
|
||||
! .. Local Scalars ..
|
||||
Integer :: k, np,me,m,nnzero,&
|
||||
& ictxt, n_col,ier,n,int_err(5),&
|
||||
& tot_recv, ircode, n_row,nhalo, nrow_a,err_act
|
||||
Logical,Parameter :: debug=.false., debugprt=.false.
|
||||
character(len=20) :: name, ch_err
|
||||
name='psb_zasmatbld'
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=0
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
If(debug) Write(0,*)'IN DASMATBLD ', upd
|
||||
ictxt=desc_data%matrix_data(psb_ctxt_)
|
||||
tot_recv=0
|
||||
|
||||
nrow_a = desc_data%matrix_data(psb_n_row_)
|
||||
nnzero = Size(a%aspk)
|
||||
n_col = desc_data%matrix_data(psb_n_col_)
|
||||
nhalo = n_col-nrow_a
|
||||
|
||||
|
||||
If (ptype == bja_) Then
|
||||
!
|
||||
! Block Jacobi. Copy the descriptor, just in case we want to
|
||||
! do the renumbering.
|
||||
!
|
||||
If(debug) Write(0,*)' asmatbld calling allocate '
|
||||
call psb_sp_all(0,0,blk,1,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'
|
||||
blk%infoa(psb_nnz_) = 0
|
||||
If(debug) Write(0,*)' asmatbld done spallocate'
|
||||
If (upd == 'F') Then
|
||||
call psb_cdcpy(desc_data,desc_p,info)
|
||||
If(debug) Write(0,*)' asmatbld done cdcpy'
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_cdcpy'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
|
||||
Else If (ptype == asm_) Then
|
||||
|
||||
|
||||
!
|
||||
! Additive Schwarz variant.
|
||||
!
|
||||
!
|
||||
|
||||
ictxt=desc_data%matrix_data(psb_ctxt_)
|
||||
|
||||
if (novr < 0) then
|
||||
info=3
|
||||
int_err(1)=novr
|
||||
call psb_errpush(info,name,i_err=int_err)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
if (novr == 0) then
|
||||
!
|
||||
! This is really just Block Jacobi.....
|
||||
!
|
||||
If(debug) Write(0,*)' asmatbld calling allocate novr=0'
|
||||
call psb_sp_all(0,0,blk,1,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'
|
||||
blk%infoa(psb_nnz_)=0
|
||||
if (debug) write(0,*) 'Calling desccpy'
|
||||
if (upd == 'F') then
|
||||
call psb_cdcpy(desc_data,desc_p,info)
|
||||
If(debug) Write(0,*)' asmatbld done cdcpy'
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_cdcpy'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
if (debug) write(0,*) 'Early return from asmatbld: P>=3 N_OVR=0'
|
||||
endif
|
||||
return
|
||||
endif
|
||||
|
||||
call psb_get_mpicomm(ictxt,icomm)
|
||||
|
||||
Call psb_info(ictxt, me, np)
|
||||
If(debug)Write(0,*)'BEGIN dasmatbld',me,upd,novr
|
||||
t1 = mpi_wtime()
|
||||
|
||||
If (upd == 'F') Then
|
||||
!
|
||||
! Build the auiliary descriptor',desc_p%matrix_data(psb_n_row_)
|
||||
!
|
||||
call psb_cdbldovr(a,desc_data,novr,desc_p,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_cdbldovr'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
Endif
|
||||
|
||||
if(debug) write(0,*) me,' From cdovr _:',desc_p%matrix_data(psb_n_row_),desc_p%matrix_data(psb_n_col_)
|
||||
|
||||
|
||||
n_row = desc_p%matrix_data(psb_n_row_)
|
||||
t2 = mpi_wtime()
|
||||
|
||||
if (debug) write(0,*) 'Before sphalo ',blk%fida,blk%m,psb_nnz_,blk%infoa(psb_nnz_)
|
||||
|
||||
if (present(outfmt)) then
|
||||
if(debug) write(0,*) me,': Calling SPHALO with ',size(blk%ia2)
|
||||
Call psb_sphalo(a,desc_p,blk,info,outfmt=outfmt)
|
||||
else
|
||||
if(debug) write(0,*) me,': Calling SPHALO with ',size(blk%ia2)
|
||||
Call psb_sphalo(a,desc_p,blk,info)
|
||||
end if
|
||||
|
||||
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_sphalo'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (debug) write(0,*) 'After psb_sphalo ',blk%fida,blk%m,psb_nnz_,blk%infoa(psb_nnz_)
|
||||
|
||||
t3 = mpi_wtime()
|
||||
if (debugprt) then
|
||||
open(40+me)
|
||||
call psb_csprt(40+me,blk,head='% Ovrlap rows')
|
||||
close(40+me)
|
||||
endif
|
||||
|
||||
|
||||
End If
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
Return
|
||||
|
||||
End Subroutine psb_zasmatbld
|
||||
|
||||
@ -0,0 +1,280 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
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_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
|
||||
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
|
||||
|
||||
! Local variables
|
||||
integer :: n_row,n_col, int_err(5)
|
||||
complex(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:)
|
||||
character ::diagl, diagu
|
||||
integer :: ictxt,np,me,i, isz, nrg, err_act
|
||||
real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime
|
||||
logical,parameter :: debug=.false., debugprt=.false.
|
||||
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)
|
||||
|
||||
ictxt=desc_data%matrix_data(psb_ctxt_)
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
diagl='U'
|
||||
diagu='U'
|
||||
|
||||
select case(trans)
|
||||
case('N','n')
|
||||
case('T','t','C','c')
|
||||
case default
|
||||
info=40
|
||||
int_err(1)=6
|
||||
ch_err(2:2)=trans
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
select case(prec%iprcparm(p_type_))
|
||||
|
||||
case(noprec_)
|
||||
|
||||
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
|
||||
|
||||
case(diagsc_)
|
||||
|
||||
if (size(work) >= size(x)) then
|
||||
ww => work
|
||||
else
|
||||
allocate(ww(size(x)),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
|
||||
n_row=desc_data%matrix_data(psb_n_row_)
|
||||
ww(1:n_row) = x(1:n_row)*prec%d(1:n_row)
|
||||
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
|
||||
|
||||
if (size(work) < size(x)) then
|
||||
deallocate(ww,stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Deallocate')
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
|
||||
case(bja_)
|
||||
|
||||
call psb_bjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
|
||||
if(info.ne.0) then
|
||||
info=4010
|
||||
ch_err='psb_bjac_aply'
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
case(asm_,ras_,ash_,rash_)
|
||||
|
||||
if (prec%iprcparm(n_ovr_)==0) then
|
||||
! shortcut: this fixes performance for RAS(0) == BJA
|
||||
call psb_bjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
|
||||
if(info.ne.0) then
|
||||
info=4010
|
||||
ch_err='psb_bjacaply'
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
else
|
||||
! Note: currently trans is unused.
|
||||
n_row=prec%desc_data%matrix_data(psb_n_row_)
|
||||
n_col=prec%desc_data%matrix_data(psb_n_col_)
|
||||
|
||||
isz=max(n_row,N_COL)
|
||||
if ((6*isz) <= size(work)) then
|
||||
ww => work(1:isz)
|
||||
tx => work(isz+1:2*isz)
|
||||
ty => work(2*isz+1:3*isz)
|
||||
aux => work(3*isz+1:)
|
||||
else if ((4*isz) <= size(work)) then
|
||||
aux => work(1:)
|
||||
allocate(ww(isz),tx(isz),ty(isz),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
else if ((3*isz) <= size(work)) then
|
||||
ww => work(1:isz)
|
||||
tx => work(isz+1:2*isz)
|
||||
ty => work(2*isz+1:3*isz)
|
||||
allocate(aux(4*isz),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
else
|
||||
allocate(ww(isz),tx(isz),ty(isz),&
|
||||
&aux(4*isz),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
endif
|
||||
|
||||
if (debugprt) write(0,*)' vdiag: ',prec%d(:)
|
||||
if (debug) write(0,*) 'Bi-CGSTAB with Additive Schwarz prec'
|
||||
|
||||
tx(1:desc_data%matrix_data(psb_n_row_)) = x(1:desc_data%matrix_data(psb_n_row_))
|
||||
tx(desc_data%matrix_data(psb_n_row_)+1:isz) = zzero
|
||||
|
||||
if (prec%iprcparm(restr_)==psb_halo_) then
|
||||
call psb_halo(tx,prec%desc_data,info,work=aux)
|
||||
if(info /=0) then
|
||||
info=4010
|
||||
ch_err='psb_halo'
|
||||
goto 9999
|
||||
end if
|
||||
else if (prec%iprcparm(restr_) /= psb_none_) then
|
||||
write(0,*) 'Problem in PRC_APLY: Unknown value for restriction ',&
|
||||
&prec%iprcparm(restr_)
|
||||
end if
|
||||
|
||||
if (prec%iprcparm(iren_)>0) then
|
||||
call zgelp('N',n_row,1,prec%perm,tx,isz,ww,isz,info)
|
||||
if(info /=0) then
|
||||
info=4010
|
||||
ch_err='psb_zgelp'
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
|
||||
call psb_bjac_aply(zone,prec,tx,zzero,ty,prec%desc_data,trans,aux,info)
|
||||
if(info.ne.0) then
|
||||
info=4010
|
||||
ch_err='psb_bjac_aply'
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (prec%iprcparm(iren_)>0) then
|
||||
call zgelp('N',n_row,1,prec%invperm,ty,isz,ww,isz,info)
|
||||
if(info /=0) then
|
||||
info=4010
|
||||
ch_err='psb_zgelp'
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
|
||||
select case (prec%iprcparm(prol_))
|
||||
|
||||
case(psb_none_)
|
||||
! Would work anyway, but since it's supposed to do nothing...
|
||||
! call f90_psovrl(ty,prec%desc_data,update=prec%a_restrict)
|
||||
|
||||
case(psb_sum_,psb_avg_)
|
||||
call psb_ovrl(ty,prec%desc_data,info,&
|
||||
& update=prec%iprcparm(prol_),work=aux)
|
||||
if(info /=0) then
|
||||
info=4010
|
||||
ch_err='psb_ovrl'
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
case default
|
||||
write(0,*) 'Problem in PRC_APLY: Unknown value for prolongation ',&
|
||||
& prec%iprcparm(prol_)
|
||||
end select
|
||||
|
||||
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
|
||||
if ((6*isz) <= size(work)) then
|
||||
else if ((4*isz) <= size(work)) then
|
||||
deallocate(ww,tx,ty)
|
||||
else if ((3*isz) <= size(work)) then
|
||||
deallocate(aux)
|
||||
else
|
||||
deallocate(ww,aux,tx,ty)
|
||||
endif
|
||||
end if
|
||||
case default
|
||||
write(0,*) 'Invalid PRE%PREC ',prec%iprcparm(p_type_),':',&
|
||||
& min_prec_,noprec_,diagsc_,bja_,&
|
||||
& asm_,ras_,ash_,rash_
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine psb_zbaseprc_aply
|
||||
|
||||
@ -0,0 +1,262 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_zbaseprc_bld(a,desc_a,p,info,upd)
|
||||
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
Implicit None
|
||||
|
||||
type(psb_zspmat_type), target :: a
|
||||
type(psb_desc_type), intent(in), target :: desc_a
|
||||
type(psb_zbaseprc_type),intent(inout) :: p
|
||||
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,&
|
||||
& me,mycol,np,npcol,mglob,lw, mtype, nrg, nzg, err_act
|
||||
real(kind(1.d0)) :: temp, real_err(5)
|
||||
real(kind(1.d0)),pointer :: gd(:), work(:)
|
||||
integer :: int_err(5)
|
||||
character :: iupd
|
||||
|
||||
logical, parameter :: debug=.false.
|
||||
integer,parameter :: iroot=0,iout=60,ilout=40
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=0
|
||||
err=0
|
||||
call psb_erractionsave(err_act)
|
||||
name = 'psb_baseprc_bld'
|
||||
|
||||
if (debug) write(0,*) 'Entering baseprc_bld'
|
||||
info = 0
|
||||
int_err(1) = 0
|
||||
ictxt = psb_cd_get_context(desc_a)
|
||||
n_row = psb_cd_get_local_rows(desc_a)
|
||||
n_col = psb_cd_get_local_cols(desc_a)
|
||||
mglob = psb_cd_get_global_rows(desc_a)
|
||||
if (debug) write(0,*) 'Preconditioner Blacs_gridinfo'
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
if (present(upd)) then
|
||||
if (debug) write(0,*) 'UPD ', upd
|
||||
if ((UPD.eq.'F').or.(UPD.eq.'T')) then
|
||||
IUPD=UPD
|
||||
else
|
||||
IUPD='F'
|
||||
endif
|
||||
else
|
||||
IUPD='F'
|
||||
endif
|
||||
|
||||
!
|
||||
! Should add check to ensure all procs have the same...
|
||||
!
|
||||
! ALso should define symbolic names for the preconditioners.
|
||||
!
|
||||
|
||||
call psb_check_def(p%iprcparm(p_type_),'base_prec',&
|
||||
& diagsc_,is_legal_base_prec)
|
||||
|
||||
!!$ allocate(p%desc_data,stat=info)
|
||||
!!$ if (info /= 0) then
|
||||
!!$ call psb_errpush(4010,name,a_err='Allocate')
|
||||
!!$ goto 9999
|
||||
!!$ end if
|
||||
!!$
|
||||
!!$ call psb_nullify_desc(p%desc_data)
|
||||
|
||||
select case(p%iprcparm(p_type_))
|
||||
case (noprec_)
|
||||
! Do nothing.
|
||||
call psb_cdcpy(desc_a,p%desc_data,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_cdcpy'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
case (diagsc_)
|
||||
|
||||
call psb_diagsc_bld(a,desc_a,p,iupd,info)
|
||||
if(debug) write(0,*)me,': out of psb_diagsc_bld'
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_diagsc_bld'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
case (bja_,asm_)
|
||||
|
||||
call psb_check_def(p%iprcparm(n_ovr_),'overlap',&
|
||||
& 0,is_legal_n_ovr)
|
||||
call psb_check_def(p%iprcparm(restr_),'restriction',&
|
||||
& psb_halo_,is_legal_restrict)
|
||||
call psb_check_def(p%iprcparm(prol_),'prolongator',&
|
||||
& psb_none_,is_legal_prolong)
|
||||
call psb_check_def(p%iprcparm(iren_),'renumbering',&
|
||||
& renum_none_,is_legal_renum)
|
||||
call psb_check_def(p%iprcparm(f_type_),'fact',&
|
||||
& f_ilu_n_,is_legal_ml_fact)
|
||||
|
||||
if (debug) write(0,*)me, ': Calling PSB_ILU_BLD'
|
||||
if (debug) call psb_barrier(ictxt)
|
||||
|
||||
select case(p%iprcparm(f_type_))
|
||||
|
||||
case(f_ilu_n_,f_ilu_e_)
|
||||
call psb_ilu_bld(a,desc_a,p,iupd,info)
|
||||
if(debug) write(0,*)me,': out of psb_ilu_bld'
|
||||
if (debug) call psb_barrier(ictxt)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_ilu_bld'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
case(f_slu_)
|
||||
|
||||
if(debug) write(0,*)me,': calling slu_bld'
|
||||
call psb_slu_bld(a,desc_a,p,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='slu_bld'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
case(f_umf_)
|
||||
if(debug) write(0,*)me,': calling umf_bld'
|
||||
call psb_umf_bld(a,desc_a,p,info)
|
||||
if(debug) write(0,*)me,': Done umf_bld ',info
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='umf_bld'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
case(f_none_)
|
||||
write(0,*) 'Fact=None in BASEPRC_BLD Bja/ASM??'
|
||||
info=4010
|
||||
ch_err='Inconsistent prec f_none_'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
|
||||
case default
|
||||
write(0,*) 'Unknown factor type in baseprc_bld bja/asm: ',&
|
||||
&p%iprcparm(f_type_)
|
||||
info=4010
|
||||
ch_err='Unknown f_type_'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end select
|
||||
case default
|
||||
info=4010
|
||||
ch_err='Unknown p_type_'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
|
||||
end select
|
||||
|
||||
p%base_a => a
|
||||
p%base_desc => desc_a
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine psb_zbaseprc_bld
|
||||
|
||||
@ -0,0 +1,270 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
|
||||
!
|
||||
! Compute Y <- beta*Y + alpha*K^-1 X
|
||||
! where K is a a Block Jacobi preconditioner stored in prec
|
||||
! Note that desc_data may or may not be the same as prec%desc_data,
|
||||
! but since both are INTENT(IN) this should be legal.
|
||||
!
|
||||
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
|
||||
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
|
||||
|
||||
! Local variables
|
||||
integer :: n_row,n_col
|
||||
complex(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:),tb(:)
|
||||
character ::diagl, diagu
|
||||
integer :: ictxt,np,me,i, isz, nrg, err_act, int_err(5)
|
||||
real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime
|
||||
logical,parameter :: debug=.false., debugprt=.false.
|
||||
external mpi_wtime
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name='psb_bjac_aply'
|
||||
info = 0
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
ictxt=desc_data%matrix_data(psb_ctxt_)
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
diagl='U'
|
||||
diagu='U'
|
||||
|
||||
select case(trans)
|
||||
case('N','n')
|
||||
case('T','t','C','c')
|
||||
case default
|
||||
call psb_errpush(40,name)
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
|
||||
n_row=desc_data%matrix_data(psb_n_row_)
|
||||
n_col=desc_data%matrix_data(psb_n_col_)
|
||||
|
||||
if (n_col <= size(work)) then
|
||||
ww => work(1:n_col)
|
||||
if ((4*n_col+n_col) <= size(work)) then
|
||||
aux => work(n_col+1:)
|
||||
else
|
||||
allocate(aux(4*n_col),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
endif
|
||||
else
|
||||
allocate(ww(n_col),aux(4*n_col),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
|
||||
|
||||
if (prec%iprcparm(jac_sweeps_) == 1) then
|
||||
|
||||
|
||||
select case(prec%iprcparm(f_type_))
|
||||
case(f_ilu_n_,f_ilu_e_)
|
||||
|
||||
select case(trans)
|
||||
case('N','n')
|
||||
|
||||
call psb_spsm(zone,prec%av(l_pr_),x,zzero,ww,desc_data,info,&
|
||||
& trans='N',unit=diagl,choice=psb_none_,work=aux)
|
||||
if(info /=0) goto 9999
|
||||
ww(1:n_row) = ww(1:n_row)*prec%d(1:n_row)
|
||||
call psb_spsm(alpha,prec%av(u_pr_),ww,beta,y,desc_data,info,&
|
||||
& trans='N',unit=diagu,choice=psb_none_, work=aux)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
case('T','t','C','c')
|
||||
call psb_spsm(zone,prec%av(u_pr_),x,zzero,ww,desc_data,info,&
|
||||
& trans=trans,unit=diagu,choice=psb_none_, work=aux)
|
||||
if(info /=0) goto 9999
|
||||
ww(1:n_row) = ww(1:n_row)*prec%d(1:n_row)
|
||||
call psb_spsm(alpha,prec%av(l_pr_),ww,beta,y,desc_data,info,&
|
||||
& trans=trans,unit=diagl,choice=psb_none_,work=aux)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
end select
|
||||
|
||||
case(f_slu_)
|
||||
|
||||
ww(1:n_row) = x(1:n_row)
|
||||
|
||||
select case(trans)
|
||||
case('N','n')
|
||||
call psb_zslu_solve(0,n_row,1,ww,n_row,prec%iprcparm(slu_ptr_),info)
|
||||
case('T','t','C','c')
|
||||
call psb_zslu_solve(1,n_row,1,ww,n_row,prec%iprcparm(slu_ptr_),info)
|
||||
end select
|
||||
|
||||
if(info /=0) goto 9999
|
||||
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
|
||||
|
||||
case (f_umf_)
|
||||
|
||||
|
||||
select case(trans)
|
||||
case('N','n')
|
||||
call psb_zumf_solve(0,n_row,ww,x,n_row,prec%iprcparm(umf_numptr_),info)
|
||||
case('T','t','C','c')
|
||||
call psb_zumf_solve(1,n_row,ww,x,n_row,prec%iprcparm(umf_numptr_),info)
|
||||
end select
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
|
||||
|
||||
case default
|
||||
write(0,*) 'Unknown factorization type in bjac_aply',prec%iprcparm(f_type_)
|
||||
end select
|
||||
if (debugprt) write(0,*)' Y: ',y(:)
|
||||
|
||||
else if (prec%iprcparm(jac_sweeps_) > 1) then
|
||||
|
||||
! Note: we have to add TRANS to this one !!!!!!!!!
|
||||
|
||||
if (size(prec%av) < ap_nd_) then
|
||||
info = 4011
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
allocate(tx(n_col),ty(n_col),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
tx = zzero
|
||||
ty = zzero
|
||||
select case(prec%iprcparm(f_type_))
|
||||
case(f_ilu_n_,f_ilu_e_)
|
||||
do i=1, prec%iprcparm(jac_sweeps_)
|
||||
! X(k+1) = M^-1*(b-N*X(k))
|
||||
ty(1:n_row) = x(1:n_row)
|
||||
call psb_spmm(-zone,prec%av(ap_nd_),tx,zone,ty,&
|
||||
& prec%desc_data,info,work=aux)
|
||||
if(info /=0) goto 9999
|
||||
call psb_spsm(zone,prec%av(l_pr_),ty,zzero,ww,&
|
||||
& prec%desc_data,info,&
|
||||
& trans='N',unit='U',choice=psb_none_,work=aux)
|
||||
if(info /=0) goto 9999
|
||||
ww(1:n_row) = ww(1:n_row)*prec%d(1:n_row)
|
||||
call psb_spsm(zone,prec%av(u_pr_),ww,zzero,tx,&
|
||||
& prec%desc_data,info,&
|
||||
& trans='N',unit='U',choice=psb_none_,work=aux)
|
||||
if(info /=0) goto 9999
|
||||
end do
|
||||
|
||||
case(f_slu_)
|
||||
do i=1, prec%iprcparm(jac_sweeps_)
|
||||
! X(k+1) = M^-1*(b-N*X(k))
|
||||
ty(1:n_row) = x(1:n_row)
|
||||
call psb_spmm(-zone,prec%av(ap_nd_),tx,zone,ty,&
|
||||
& prec%desc_data,info,work=aux)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
call psb_zslu_solve(0,n_row,1,ty,n_row,prec%iprcparm(slu_ptr_),info)
|
||||
if(info /=0) goto 9999
|
||||
tx(1:n_row) = ty(1:n_row)
|
||||
end do
|
||||
case(f_umf_)
|
||||
do i=1, prec%iprcparm(jac_sweeps_)
|
||||
! X(k+1) = M^-1*(b-N*X(k))
|
||||
ty(1:n_row) = x(1:n_row)
|
||||
call psb_spmm(-zone,prec%av(ap_nd_),tx,zone,ty,&
|
||||
& prec%desc_data,info,work=aux)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
call psb_zumf_solve(0,n_row,ww,ty,n_row,&
|
||||
& prec%iprcparm(umf_numptr_),info)
|
||||
if(info /=0) goto 9999
|
||||
tx(1:n_row) = ww(1:n_row)
|
||||
end do
|
||||
|
||||
end select
|
||||
|
||||
call psb_geaxpby(alpha,tx,beta,y,desc_data,info)
|
||||
|
||||
|
||||
deallocate(tx,ty)
|
||||
|
||||
|
||||
else
|
||||
|
||||
goto 9999
|
||||
|
||||
endif
|
||||
|
||||
if (n_col <= size(work)) then
|
||||
if ((4*n_col+n_col) <= size(work)) then
|
||||
else
|
||||
deallocate(aux)
|
||||
endif
|
||||
else
|
||||
deallocate(ww,aux)
|
||||
endif
|
||||
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine psb_zbjac_aply
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,164 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_zdiagsc_bld(a,desc_a,p,upd,info)
|
||||
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
Implicit None
|
||||
|
||||
type(psb_zspmat_type), target :: a
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
type(psb_zbaseprc_type),intent(inout) :: p
|
||||
character, intent(in) :: upd
|
||||
integer, intent(out) :: info
|
||||
|
||||
|
||||
! Local scalars
|
||||
Integer :: err, n_row, n_col,I,j,k,ictxt,&
|
||||
& me,np,mglob,lw, err_act
|
||||
complex(kind(1.d0)),pointer :: gd(:), work(:)
|
||||
integer :: int_err(5)
|
||||
character :: iupd
|
||||
|
||||
logical, parameter :: debug=.false.
|
||||
integer,parameter :: iroot=0,iout=60,ilout=40
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=0
|
||||
err=0
|
||||
call psb_erractionsave(err_act)
|
||||
name = 'psb_diagsc_bld'
|
||||
|
||||
if (debug) write(0,*) 'Entering diagsc_bld'
|
||||
info = 0
|
||||
int_err(1) = 0
|
||||
ictxt = psb_cd_get_context(desc_a)
|
||||
n_row = psb_cd_get_local_rows(desc_a)
|
||||
n_col = psb_cd_get_local_cols(desc_a)
|
||||
mglob = psb_cd_get_global_rows(desc_a)
|
||||
|
||||
if (debug) write(0,*) 'Preconditioner Blacs_gridinfo'
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
if (debug) write(0,*) 'Precond: Diagonal scaling'
|
||||
! diagonal scaling
|
||||
|
||||
call psb_realloc(n_col,p%d,info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='psb_realloc')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_csrws(p%d,a,info,trans='N')
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_csrws'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (debug) write(ilout+me,*) 'VDIAG ',n_row
|
||||
do i=1,n_row
|
||||
if (p%d(i) == zzero) then
|
||||
p%d(i) = zone
|
||||
else
|
||||
p%d(i) = zone/p%d(i)
|
||||
endif
|
||||
|
||||
if (debug) write(ilout+me,*) i,desc_a%loc_to_glob(i), p%d(i)
|
||||
!!$ if (p%d(i).lt.0.d0) then
|
||||
!!$ write(0,*) me,'Negative RWS? ',i,p%d(i)
|
||||
!!$ endif
|
||||
end do
|
||||
if (a%pl(1) /= 0) then
|
||||
allocate(work(n_row),stat=info)
|
||||
if (info /= 0) then
|
||||
info=4000
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
call psb_gelp('n',a%pl,p%d,desc_a,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_zgelp'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
deallocate(work)
|
||||
endif
|
||||
|
||||
if (debug) then
|
||||
allocate(gd(mglob),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_gather(gd, p%d, desc_a, info, iroot=iroot)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_zgatherm'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (me.eq.iroot) then
|
||||
write(iout+np,*) 'VDIAG CHECK ',mglob
|
||||
do i=1,mglob
|
||||
write(iout+np,*) i,gd(i)
|
||||
enddo
|
||||
endif
|
||||
deallocate(gd)
|
||||
endif
|
||||
if (debug) write(*,*) 'Preconditioner DIAG computed OK'
|
||||
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine psb_zdiagsc_bld
|
||||
|
||||
@ -0,0 +1,292 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
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
|
||||
! Locals
|
||||
integer, allocatable :: ils(:), neigh(:)
|
||||
integer :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m
|
||||
|
||||
logical :: recovery
|
||||
logical, parameter :: debug=.false.
|
||||
integer ::ictxt,np,me,err_act
|
||||
integer :: nrow, ncol, n_ne
|
||||
integer, parameter :: one=1, two=2
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=0
|
||||
name = 'psb_bldaggrmat'
|
||||
call psb_erractionsave(err_act)
|
||||
!
|
||||
! Note. At the time being we are ignoring aggr_type
|
||||
! so that we only have local decoupled aggregation. This might
|
||||
! change in the future.
|
||||
!
|
||||
ictxt=psb_cd_get_context(desc_a)
|
||||
call psb_info(ictxt,me,np)
|
||||
nrow = psb_cd_get_local_rows(desc_a)
|
||||
ncol = psb_cd_get_local_cols(desc_a)
|
||||
|
||||
nr = a%m
|
||||
allocate(ilaggr(nr),neigh(nr),stat=info)
|
||||
if(info.ne.0) then
|
||||
info=4000
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
do i=1, nr
|
||||
ilaggr(i) = -(nr+1)
|
||||
end do
|
||||
! Note: -(nr+1) Untouched as yet
|
||||
! -i 1<=i<=nr Adjacent to aggregate i
|
||||
! i 1<=i<=nr Belonging to aggregate i
|
||||
|
||||
!
|
||||
! Phase one: group nodes together.
|
||||
! Very simple minded strategy.
|
||||
!
|
||||
naggr = 0
|
||||
nlp = 0
|
||||
do
|
||||
icnt = 0
|
||||
do i=1, nr
|
||||
if (ilaggr(i) == -(nr+1)) then
|
||||
!
|
||||
! 1. Untouched nodes are marked >0 together
|
||||
! with their neighbours
|
||||
!
|
||||
icnt = icnt + 1
|
||||
naggr = naggr + 1
|
||||
ilaggr(i) = naggr
|
||||
|
||||
call psb_neigh(a,i,neigh,n_ne,info,lev=one)
|
||||
if (info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_neigh'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
do k=1, n_ne
|
||||
j = neigh(k)
|
||||
if ((1<=j).and.(j<=nr)) then
|
||||
ilaggr(j) = naggr
|
||||
!!$ if (ilaggr(j) < 0) ilaggr(j) = naggr
|
||||
!!$ if (ilaggr(j) == -(nr+1)) ilaggr(j) = naggr
|
||||
endif
|
||||
enddo
|
||||
!
|
||||
! 2. Untouched neighbours of these nodes are marked <0.
|
||||
!
|
||||
call psb_neigh(a,i,neigh,n_ne,info,lev=two)
|
||||
if (info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_neigh'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
do n = 1, n_ne
|
||||
m = neigh(n)
|
||||
if ((1<=m).and.(m<=nr)) then
|
||||
if (ilaggr(m) == -(nr+1)) ilaggr(m) = -naggr
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
nlp = nlp + 1
|
||||
if (icnt == 0) exit
|
||||
enddo
|
||||
if (debug) then
|
||||
write(0,*) 'Check 1:',count(ilaggr == -(nr+1)),(a%ia1(i),i=a%ia2(1),a%ia2(2)-1)
|
||||
end if
|
||||
|
||||
!
|
||||
! Phase two: sweep over leftovers.
|
||||
!
|
||||
allocate(ils(naggr+10),stat=info)
|
||||
if(info.ne.0) then
|
||||
info=4000
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
do i=1, size(ils)
|
||||
ils(i) = 0
|
||||
end do
|
||||
do i=1, nr
|
||||
n = ilaggr(i)
|
||||
if (n>0) then
|
||||
if (n>naggr) then
|
||||
write(0,*) 'loc_Aggregate: n > naggr 1 ? ',n,naggr
|
||||
else
|
||||
ils(n) = ils(n) + 1
|
||||
end if
|
||||
|
||||
end if
|
||||
end do
|
||||
if (debug) then
|
||||
write(0,*) 'Phase 1: number of aggregates ',naggr
|
||||
write(0,*) 'Phase 1: nodes aggregated ',sum(ils)
|
||||
end if
|
||||
|
||||
recovery=.false.
|
||||
do i=1, nr
|
||||
if (ilaggr(i) < 0) then
|
||||
!
|
||||
! Now some silly rule to break ties:
|
||||
! Group with smallest adjacent aggregate.
|
||||
!
|
||||
isz = nr+1
|
||||
ia = -1
|
||||
|
||||
call psb_neigh(a,i,neigh,n_ne,info,lev=one)
|
||||
if (info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_neigh'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
do j=1, n_ne
|
||||
k = neigh(j)
|
||||
if ((1<=k).and.(k<=nr)) then
|
||||
n = ilaggr(k)
|
||||
if (n>0) then
|
||||
if (n>naggr) then
|
||||
write(0,*) 'loc_Aggregate: n > naggr 2? ',n,naggr
|
||||
end if
|
||||
|
||||
if (ils(n) < isz) then
|
||||
ia = n
|
||||
isz = ils(n)
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
if (ia == -1) then
|
||||
if (ilaggr(i) > -(nr+1)) then
|
||||
ilaggr(i) = abs(ilaggr(i))
|
||||
if (ilaggr(I)>naggr) then
|
||||
write(0,*) 'loc_Aggregate: n > naggr 3? ',ilaggr(i),naggr
|
||||
end if
|
||||
ils(ilaggr(i)) = ils(ilaggr(i)) + 1
|
||||
!
|
||||
! This might happen if the pattern is non symmetric.
|
||||
! Need a better handling.
|
||||
!
|
||||
recovery = .true.
|
||||
else
|
||||
write(0,*) 'Unrecoverable error !!',ilaggr(i), nr
|
||||
endif
|
||||
else
|
||||
ilaggr(i) = ia
|
||||
if (ia>naggr) then
|
||||
write(0,*) 'loc_Aggregate: n > naggr 4? ',ia,naggr
|
||||
end if
|
||||
|
||||
ils(ia) = ils(ia) + 1
|
||||
endif
|
||||
end if
|
||||
enddo
|
||||
if (recovery) then
|
||||
write(0,*) 'Had to recover from strange situation in loc_aggregate.'
|
||||
write(0,*) 'Perhaps an unsymmetric pattern?'
|
||||
endif
|
||||
if (debug) then
|
||||
write(0,*) 'Phase 2: number of aggregates ',naggr
|
||||
write(0,*) 'Phase 2: nodes aggregated ',sum(ils)
|
||||
do i=1, naggr
|
||||
write(*,*) 'Size of aggregate ',i,' :',count(ilaggr==i), ils(i)
|
||||
enddo
|
||||
write(*,*) maxval(ils(1:naggr))
|
||||
write(*,*) 'Leftovers ',count(ilaggr<0), ' in ',nlp,' loops'
|
||||
end if
|
||||
|
||||
!!$ write(0,*) 'desc_a loc_aggr 4 : ', desc_a%matrix_data(m_)
|
||||
if (count(ilaggr<0) >0) then
|
||||
write(0,*) 'Fatal error: some leftovers!!!'
|
||||
endif
|
||||
|
||||
deallocate(ils,neigh,stat=info)
|
||||
if (info/=0) then
|
||||
info=4000
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (nrow /= size(ilaggr)) then
|
||||
write(0,*) 'SOmething wrong ilaggr ',nrow,size(ilaggr)
|
||||
endif
|
||||
call psb_realloc(ncol,ilaggr,info)
|
||||
if (info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
allocate(nlaggr(np),stat=info)
|
||||
if (info/=0) then
|
||||
info=4000
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
nlaggr(:) = 0
|
||||
nlaggr(me+1) = naggr
|
||||
call psb_sum(ictxt,nlaggr(1:np))
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine psb_zgenaggrmap
|
||||
@ -0,0 +1,364 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
!*****************************************************************************
|
||||
!* *
|
||||
!* This is where the action takes place. *
|
||||
!* ASMATBLD does the setup: building the prec descriptor plus retrieving *
|
||||
!* matrix rows if needed *
|
||||
!* *
|
||||
!* *
|
||||
!* *
|
||||
!* *
|
||||
!* some open code does the renumbering *
|
||||
!* *
|
||||
!* *
|
||||
!* *
|
||||
!* *
|
||||
!*****************************************************************************
|
||||
subroutine psb_zilu_bld(a,desc_a,p,upd,info)
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
!
|
||||
! .. Scalar Arguments ..
|
||||
integer, intent(out) :: info
|
||||
! .. array Arguments ..
|
||||
type(psb_zspmat_type), intent(in), target :: a
|
||||
type(psb_zbaseprc_type), intent(inout) :: p
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
character, intent(in) :: upd
|
||||
|
||||
! .. Local Scalars ..
|
||||
integer :: i, j, jj, k, kk, m
|
||||
integer :: int_err(5)
|
||||
character :: trans, unitd
|
||||
type(psb_zspmat_type) :: blck, atmp
|
||||
real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6,mpi_wtime, t7, t8
|
||||
external mpi_wtime
|
||||
logical, parameter :: debugprt=.false., debug=.false., aggr_dump=.false.
|
||||
integer nztota, nztotb, nztmp, nzl, nnr, ir, err_act,&
|
||||
& n_row, nrow_a,n_col, nhalo, ind, iind, i1,i2,ia
|
||||
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
|
||||
name='psb_ilu_bld'
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
ictxt=psb_cd_get_context(desc_a)
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
m = a%m
|
||||
if (m < 0) then
|
||||
info = 10
|
||||
int_err(1) = 1
|
||||
int_err(2) = m
|
||||
call psb_errpush(info,name,i_err=int_err)
|
||||
goto 9999
|
||||
endif
|
||||
trans = 'N'
|
||||
unitd = 'U'
|
||||
if (p%iprcparm(n_ovr_) < 0) then
|
||||
info = 11
|
||||
int_err(1) = 1
|
||||
int_err(2) = p%iprcparm(n_ovr_)
|
||||
call psb_errpush(info,name,i_err=int_err)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
call psb_nullify_sp(blck)
|
||||
call psb_nullify_sp(atmp)
|
||||
|
||||
t1= mpi_wtime()
|
||||
|
||||
if(debug) write(0,*)me,': calling psb_asmatbld',p%iprcparm(p_type_),p%iprcparm(n_ovr_)
|
||||
if (debug) call psb_barrier(ictxt)
|
||||
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_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_asmatbld'
|
||||
if (debug) call psb_barrier(ictxt)
|
||||
|
||||
if (allocated(p%av)) then
|
||||
if (size(p%av) < bp_ilu_avsz) then
|
||||
call psb_errpush(4010,name,a_err='Insufficient av size')
|
||||
goto 9999
|
||||
endif
|
||||
else
|
||||
call psb_errpush(4010,name,a_err='AV not associated')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
nrow_a = psb_cd_get_local_rows(desc_a)
|
||||
nztota = psb_sp_get_nnzeros(a)
|
||||
nztotb = psb_sp_get_nnzeros(blck)
|
||||
if (debug) write(0,*)me,': out get_nnzeros',nztota
|
||||
if (debug) call psb_barrier(ictxt)
|
||||
|
||||
n_col = psb_cd_get_local_cols(desc_a)
|
||||
nhalo = n_col-nrow_a
|
||||
n_row = p%desc_data%matrix_data(psb_n_row_)
|
||||
p%av(l_pr_)%m = n_row
|
||||
p%av(l_pr_)%k = n_row
|
||||
p%av(u_pr_)%m = n_row
|
||||
p%av(u_pr_)%k = n_row
|
||||
call psb_sp_all(n_row,n_row,p%av(l_pr_),nztota+nztotb,info)
|
||||
if (info == 0) call psb_sp_all(n_row,n_row,p%av(u_pr_),nztota+nztotb,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 (allocated(p%d)) then
|
||||
if (size(p%d) < n_row) then
|
||||
deallocate(p%d)
|
||||
endif
|
||||
endif
|
||||
if (.not.allocated(p%d)) then
|
||||
allocate(p%d(n_row),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
endif
|
||||
|
||||
|
||||
if (debug) then
|
||||
write(0,*) me,'Done psb_asmatbld'
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
|
||||
|
||||
if (p%iprcparm(iren_) > 0) then
|
||||
|
||||
!
|
||||
! Here we allocate a full copy to hold local A and received BLK
|
||||
!
|
||||
|
||||
nztota = psb_sp_get_nnzeros(a)
|
||||
nztotb = psb_sp_get_nnzeros(blck)
|
||||
|
||||
call psb_sp_all(atmp,nztota+nztotb,info)
|
||||
if(info/=0) then
|
||||
info=4011
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
! write(0,*) 'ILU_BLD ',nztota,nztotb,a%m
|
||||
|
||||
call psb_sp_renum(a,desc_a,blck,p,atmp,info)
|
||||
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_sp_renum'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
t3 = mpi_wtime()
|
||||
if (debugprt) then
|
||||
call psb_barrier(ictxt)
|
||||
open(40+me)
|
||||
call psb_csprt(40+me,atmp,head='% Local matrix')
|
||||
close(40+me)
|
||||
endif
|
||||
if (debug) write(0,*) me,' Factoring rows ',&
|
||||
&atmp%m,a%m,blck%m,atmp%ia2(atmp%m+1)-1
|
||||
|
||||
!
|
||||
! Ok, factor the matrix.
|
||||
!
|
||||
t5 = mpi_wtime()
|
||||
blck%m=0
|
||||
call psb_ilu_fct(atmp,p%av(l_pr_),p%av(u_pr_),p%d,info,blck=blck)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_ilu_fct'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_sp_free(atmp,info)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_sp_free'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
else if (p%iprcparm(iren_) == 0) then
|
||||
t3 = mpi_wtime()
|
||||
! This is where we have mo renumbering, thus no need
|
||||
! for ATMP
|
||||
|
||||
if (debugprt) then
|
||||
open(40+me)
|
||||
call psb_barrier(ictxt)
|
||||
call psb_csprt(40+me,a,iv=p%desc_data%loc_to_glob,&
|
||||
& head='% Local matrix')
|
||||
if (p%iprcparm(p_type_)==asm_) then
|
||||
call psb_csprt(40+me,blck,iv=p%desc_data%loc_to_glob,&
|
||||
& irs=a%m,head='% Received rows')
|
||||
endif
|
||||
close(40+me)
|
||||
endif
|
||||
|
||||
t5= mpi_wtime()
|
||||
if (debug) write(0,*) me,' Going for ilu_fct'
|
||||
if (debug) call psb_barrier(ictxt)
|
||||
call psb_ilu_fct(a,p%av(l_pr_),p%av(u_pr_),p%d,info,blck=blck)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_ilu_fct'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
if (debug) write(0,*) me,' Done dilu_fct'
|
||||
endif
|
||||
|
||||
|
||||
if (debugprt) then
|
||||
!
|
||||
! Print out the factors on file.
|
||||
!
|
||||
open(80+me)
|
||||
|
||||
call psb_csprt(80+me,p%av(l_pr_),head='% Local L factor')
|
||||
write(80+me,*) '% Diagonal: ',p%av(l_pr_)%m
|
||||
do i=1,p%av(l_pr_)%m
|
||||
write(80+me,*) i,i,p%d(i)
|
||||
enddo
|
||||
call psb_csprt(80+me,p%av(u_pr_),head='% Local U factor')
|
||||
|
||||
close(80+me)
|
||||
endif
|
||||
|
||||
|
||||
! ierr = MPE_Log_event( ifcte, 0, "st SIMPLE" )
|
||||
t6 = mpi_wtime()
|
||||
!
|
||||
! write(0,'(i3,1x,a,3(1x,g18.9))') me,'renum/factor time',t3-t2,t6-t5
|
||||
! if (me==0) write(0,'(a,3(1x,g18.9))') 'renum/factor time',t3-t2,t6-t5
|
||||
|
||||
call psb_sp_free(blck,info)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_sp_free'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (psb_sp_getifld(psb_upd_,p%av(u_pr_),info) /= psb_upd_perm_) then
|
||||
call psb_sp_trimsize(p%av(u_pr_),i1,i2,ia,info)
|
||||
if (info == 0) call psb_sp_reall(p%av(u_pr_),i1,i2,ia,info)
|
||||
endif
|
||||
|
||||
if (psb_sp_getifld(psb_upd_,p%av(l_pr_),info) /= psb_upd_perm_) then
|
||||
call psb_sp_trimsize(p%av(l_pr_),i1,i2,ia,info)
|
||||
if (info == 0) call psb_sp_reall(p%av(l_pr_),i1,i2,ia,info)
|
||||
endif
|
||||
|
||||
|
||||
if (debug) write(0,*) me,'End of ilu_bld'
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
|
||||
end subroutine psb_zilu_bld
|
||||
|
||||
|
||||
@ -0,0 +1,472 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_zilu_fct(a,l,u,d,info,blck)
|
||||
|
||||
!
|
||||
! This routine copies and factors "on the fly" from A and BLCK
|
||||
! into L/D/U.
|
||||
!
|
||||
!
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
! .. Scalar Arguments ..
|
||||
integer, intent(out) :: info
|
||||
! .. Array Arguments ..
|
||||
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(:)
|
||||
! .. Local Scalars ..
|
||||
integer :: i, j, jj, k, kk, l1, l2, ll, low1, low2,m,ma,err_act
|
||||
type(psb_zspmat_type), pointer :: blck_
|
||||
character(len=20) :: name, ch_err
|
||||
name='psb_zcsrlu'
|
||||
info = 0
|
||||
call psb_erractionsave(err_act)
|
||||
! .. Executable Statements ..
|
||||
!
|
||||
|
||||
if (present(blck)) then
|
||||
blck_ => blck
|
||||
else
|
||||
allocate(blck_,stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_nullify_sp(blck_) ! Why do we need this? Who knows....
|
||||
call psb_sp_all(0,0,blck_,1,info)
|
||||
if(info.ne.0) then
|
||||
info=4010
|
||||
ch_err='psb_sp_all'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
blck_%m=0
|
||||
endif
|
||||
|
||||
call psb_zilu_fctint(m,a%m,a,blck_%m,blck_,&
|
||||
& d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info)
|
||||
if(info.ne.0) then
|
||||
info=4010
|
||||
ch_err='psb_zilu_fctint'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
l%infoa(1) = l1
|
||||
l%fida = 'CSR'
|
||||
l%descra = 'TLU'
|
||||
u%infoa(1) = l2
|
||||
u%fida = 'CSR'
|
||||
u%descra = 'TUU'
|
||||
l%m = m
|
||||
l%k = m
|
||||
u%m = m
|
||||
u%k = m
|
||||
if (present(blck)) then
|
||||
blck_ => null()
|
||||
else
|
||||
call psb_sp_free(blck_,info)
|
||||
if(info.ne.0) then
|
||||
info=4010
|
||||
ch_err='psb_sp_free'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
deallocate(blck_)
|
||||
endif
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
contains
|
||||
subroutine psb_zilu_fctint(m,ma,a,mb,b,&
|
||||
& d,laspk,lia1,lia2,uaspk,uia1,uia2,l1,l2,info)
|
||||
implicit none
|
||||
|
||||
type(psb_zspmat_type) :: a,b
|
||||
integer :: m,ma,mb,l1,l2,info
|
||||
integer, dimension(*) :: lia1,lia2,uia1,uia2
|
||||
complex(kind(1.d0)), dimension(*) :: laspk,uaspk,d
|
||||
|
||||
integer :: i,j,k,l,low1,low2,kk,jj,ll, irb, ktrw,err_act
|
||||
complex(kind(1.d0)) :: dia,temp
|
||||
integer, parameter :: nrb=16
|
||||
logical,parameter :: debug=.false.
|
||||
type(psb_zspmat_type) :: trw
|
||||
integer :: int_err(5)
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name='psb_zilu_fctint'
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=0
|
||||
call psb_erractionsave(err_act)
|
||||
call psb_nullify_sp(trw)
|
||||
trw%m=0
|
||||
trw%k=0
|
||||
if(debug) write(0,*)'LUINT Allocating TRW'
|
||||
call psb_sp_all(trw,1,info)
|
||||
if(info.ne.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,*)'LUINT Done Allocating TRW'
|
||||
lia2(1) = 1
|
||||
uia2(1) = 1
|
||||
l1=0
|
||||
l2=0
|
||||
m = ma+mb
|
||||
if(debug) write(0,*)'In DCSRLU Begin cycle',m,ma,mb
|
||||
|
||||
do i = 1, ma
|
||||
if(debug) write(0,*)'LUINT: Loop index ',i,ma
|
||||
d(i) = zzero
|
||||
|
||||
!
|
||||
! Here we take a fast shortcut if possible, otherwise
|
||||
! use spgtblk, slower but able (in principle) to handle
|
||||
! anything.
|
||||
!
|
||||
if (a%fida=='CSR') then
|
||||
do j = a%ia2(i), a%ia2(i+1) - 1
|
||||
k = a%ia1(j)
|
||||
! write(0,*)'KKKKK',k
|
||||
if ((k < i).and.(k >= 1)) then
|
||||
l1 = l1 + 1
|
||||
laspk(l1) = a%aspk(j)
|
||||
lia1(l1) = k
|
||||
else if (k == i) then
|
||||
d(i) = a%aspk(j)
|
||||
else if ((k > i).and.(k <= m)) then
|
||||
l2 = l2 + 1
|
||||
uaspk(l2) = a%aspk(j)
|
||||
uia1(l2) = k
|
||||
end if
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
if ((mod(i,nrb) == 1).or.(nrb==1)) then
|
||||
irb = min(ma-i+1,nrb)
|
||||
call psb_sp_getblk(i,a,trw,info,lrw=i+irb-1)
|
||||
if(info.ne.0) then
|
||||
info=4010
|
||||
ch_err='psb_sp_getblk'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
ktrw=1
|
||||
end if
|
||||
|
||||
do
|
||||
if (ktrw > trw%infoa(psb_nnz_)) exit
|
||||
if (trw%ia1(ktrw) > i) exit
|
||||
k = trw%ia2(ktrw)
|
||||
if ((k < i).and.(k >= 1)) then
|
||||
l1 = l1 + 1
|
||||
laspk(l1) = trw%aspk(ktrw)
|
||||
lia1(l1) = k
|
||||
else if (k == i) then
|
||||
d(i) = trw%aspk(ktrw)
|
||||
else if ((k > i).and.(k <= m)) then
|
||||
l2 = l2 + 1
|
||||
uaspk(l2) = trw%aspk(ktrw)
|
||||
uia1(l2) = k
|
||||
end if
|
||||
ktrw = ktrw + 1
|
||||
enddo
|
||||
|
||||
end if
|
||||
|
||||
!!$
|
||||
|
||||
lia2(i+1) = l1 + 1
|
||||
uia2(i+1) = l2 + 1
|
||||
|
||||
dia = d(i)
|
||||
do kk = lia2(i), lia2(i+1) - 1
|
||||
!
|
||||
! compute element alo(i,k) of incomplete factorization
|
||||
!
|
||||
temp = laspk(kk)
|
||||
k = lia1(kk)
|
||||
laspk(kk) = temp*d(k)
|
||||
! update the rest of row i using alo(i,k)
|
||||
low1 = kk + 1
|
||||
low2 = uia2(i)
|
||||
updateloop: do jj = uia2(k), uia2(k+1) - 1
|
||||
j = uia1(jj)
|
||||
!
|
||||
if (j < i) then
|
||||
! search alo(i,*) for matching index J
|
||||
do ll = low1, lia2(i+1) - 1
|
||||
l = lia1(ll)
|
||||
if (l > j) then
|
||||
low1 = ll
|
||||
exit
|
||||
else if (l == j) then
|
||||
laspk(ll) = laspk(ll) - temp*uaspk(jj)
|
||||
low1 = ll + 1
|
||||
cycle updateloop
|
||||
end if
|
||||
enddo
|
||||
!
|
||||
else if (j == i) then
|
||||
! j=i update diagonal
|
||||
! write(0,*)'aggiorno dia',dia,'temp',temp,'jj',jj,'u%aspk',uaspk(jj)
|
||||
dia = dia - temp*uaspk(jj)
|
||||
! write(0,*)'dia',dia,'temp',temp,'jj',jj,'aspk',uaspk(jj)
|
||||
cycle updateloop
|
||||
!
|
||||
else if (j > i) then
|
||||
! search aup(i,*) for matching index j
|
||||
do ll = low2, uia2(i+1) - 1
|
||||
l = uia1(ll)
|
||||
if (l > j) then
|
||||
low2 = ll
|
||||
exit
|
||||
else if (l == j) then
|
||||
uaspk(ll) = uaspk(ll) - temp*uaspk(jj)
|
||||
low2 = ll + 1
|
||||
cycle updateloop
|
||||
end if
|
||||
enddo
|
||||
end if
|
||||
!
|
||||
! for milu al=1.; for ilu al=0.
|
||||
! al = 1.d0
|
||||
! dia = dia - al*temp*aup(jj)
|
||||
enddo updateloop
|
||||
enddo
|
||||
!
|
||||
!
|
||||
! Non singularity
|
||||
!
|
||||
if (abs(dia) < epstol) then
|
||||
!
|
||||
! Pivot too small: unstable factorization
|
||||
!
|
||||
info = 2
|
||||
int_err(1) = i
|
||||
write(ch_err,'(g20.10)') abs(dia)
|
||||
call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
|
||||
goto 9999
|
||||
else
|
||||
dia = zone/dia
|
||||
end if
|
||||
d(i) = dia
|
||||
! write(6,*)'diag(',i,')=',d(i)
|
||||
! Scale row i of upper triangle
|
||||
do kk = uia2(i), uia2(i+1) - 1
|
||||
uaspk(kk) = uaspk(kk)*dia
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do i = ma+1, m
|
||||
d(i) = zzero
|
||||
|
||||
|
||||
if (b%fida=='CSR') then
|
||||
|
||||
do j = b%ia2(i-ma), b%ia2(i-ma+1) - 1
|
||||
k = b%ia1(j)
|
||||
! if (me.eq.2) write(0,*)'ecco k=',k
|
||||
if ((k < i).and.(k >= 1)) then
|
||||
l1 = l1 + 1
|
||||
laspk(l1) = b%aspk(j)
|
||||
lia1(l1) = k
|
||||
! if(me.eq.2) write(0,*)'scrivo l'
|
||||
else if (k == i) then
|
||||
d(i) = b%aspk(j)
|
||||
else if ((k > i).and.(k <= m)) then
|
||||
l2 = l2 + 1
|
||||
uaspk(l2) = b%aspk(j)
|
||||
! write(0,*)'KKKKK',k
|
||||
uia1(l2) = k
|
||||
end if
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
if ((mod((i-ma),nrb) == 1).or.(nrb==1)) then
|
||||
irb = min(m-i+1,nrb)
|
||||
call psb_sp_getblk(i-ma,b,trw,info,lrw=i-ma+irb-1)
|
||||
if(info.ne.0) then
|
||||
info=4010
|
||||
ch_err='psb_sp_getblk'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
ktrw=1
|
||||
end if
|
||||
|
||||
do
|
||||
if (ktrw > trw%infoa(psb_nnz_)) exit
|
||||
if (trw%ia1(ktrw) > i) exit
|
||||
k = trw%ia2(ktrw)
|
||||
! write(0,*)'KKKKK',k
|
||||
if ((k < i).and.(k >= 1)) then
|
||||
l1 = l1 + 1
|
||||
laspk(l1) = trw%aspk(ktrw)
|
||||
lia1(l1) = k
|
||||
else if (k == i) then
|
||||
d(i) = trw%aspk(ktrw)
|
||||
else if ((k > i).and.(k <= m)) then
|
||||
l2 = l2 + 1
|
||||
uaspk(l2) = trw%aspk(ktrw)
|
||||
uia1(l2) = k
|
||||
end if
|
||||
ktrw = ktrw + 1
|
||||
enddo
|
||||
|
||||
endif
|
||||
|
||||
|
||||
lia2(i+1) = l1 + 1
|
||||
uia2(i+1) = l2 + 1
|
||||
|
||||
dia = d(i)
|
||||
do kk = lia2(i), lia2(i+1) - 1
|
||||
!
|
||||
! compute element alo(i,k) of incomplete factorization
|
||||
!
|
||||
temp = laspk(kk)
|
||||
k = lia1(kk)
|
||||
laspk(kk) = temp*d(k)
|
||||
! update the rest of row i using alo(i,k)
|
||||
low1 = kk + 1
|
||||
low2 = uia2(i)
|
||||
updateloopb: do jj = uia2(k), uia2(k+1) - 1
|
||||
j = uia1(jj)
|
||||
!
|
||||
if (j < i) then
|
||||
! search alo(i,*) for matching index J
|
||||
do ll = low1, lia2(i+1) - 1
|
||||
l = lia1(ll)
|
||||
if (l > j) then
|
||||
low1 = ll
|
||||
exit
|
||||
else if (l == j) then
|
||||
laspk(ll) = laspk(ll) - temp*uaspk(jj)
|
||||
low1 = ll + 1
|
||||
cycle updateloopb
|
||||
end if
|
||||
enddo
|
||||
!
|
||||
else if (j == i) then
|
||||
! j=i update diagonal
|
||||
dia = dia - temp*uaspk(jj)
|
||||
cycle updateloopb
|
||||
!
|
||||
else if (j > i) then
|
||||
! search aup(i,*) for matching index j
|
||||
do ll = low2, uia2(i+1) - 1
|
||||
l = uia1(ll)
|
||||
if (l > j) then
|
||||
low2 = ll
|
||||
exit
|
||||
else if (l == j) then
|
||||
uaspk(ll) = uaspk(ll) - temp*uaspk(jj)
|
||||
low2 = ll + 1
|
||||
cycle updateloopb
|
||||
end if
|
||||
enddo
|
||||
end if
|
||||
!
|
||||
! for milu al=1.; for ilu al=0.
|
||||
! al = 1.d0
|
||||
! dia = dia - al*temp*aup(jj)
|
||||
enddo updateloopb
|
||||
enddo
|
||||
!
|
||||
!
|
||||
! Non singularity
|
||||
!
|
||||
if (abs(dia) < epstol) then
|
||||
!
|
||||
! Pivot too small: unstable factorization
|
||||
!
|
||||
int_err(1) = i
|
||||
write(ch_err,'(g20.10)') abs(dia)
|
||||
info = 2
|
||||
call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
|
||||
goto 9999
|
||||
else
|
||||
dia = zone/dia
|
||||
end if
|
||||
d(i) = dia
|
||||
! Scale row i of upper triangle
|
||||
do kk = uia2(i), uia2(i+1) - 1
|
||||
uaspk(kk) = uaspk(kk)*dia
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call psb_sp_free(trw,info)
|
||||
if(info.ne.0) then
|
||||
info=4010
|
||||
ch_err='psb_sp_free'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
if(debug) write(0,*)'Leaving ilu_fct'
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
end subroutine psb_zilu_fctint
|
||||
end subroutine psb_zilu_fct
|
||||
@ -0,0 +1,779 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
|
||||
!
|
||||
! Compute Y <- beta*Y + alpha*K^-1 X
|
||||
! where K is a multilevel preconditioner stored in baseprecv
|
||||
!
|
||||
! cfr.: Smith, Biorstad & Gropp
|
||||
! Domain Decomposition
|
||||
! Cambridge Univ. Press
|
||||
!
|
||||
! To each level I there corresponds a matrix A(I) and a preconditioner K(I)
|
||||
!
|
||||
! A notational difference: in the DD reference above the preconditioner for
|
||||
! a given level K(I) is written out as a sum over the subdomains
|
||||
!
|
||||
! SUM_k(R_k^T A_k R_k)
|
||||
!
|
||||
! whereas in this code the sum is implicit in the parallelization,
|
||||
! i.e. each process takes care of one subdomain, and for each level we have
|
||||
! as many subdomains as there are processes (except for the coarsest level where
|
||||
! we might have a replicated index space). Thus the sum apparently disappears
|
||||
! from our code, but only apparently, because it is implicit in the call
|
||||
! to psb_baseprc_aply.
|
||||
!
|
||||
! A bit of description of the baseprecv(:) data structure:
|
||||
! 1. Number of levels = NLEV = size(baseprecv(:))
|
||||
! 2. baseprecv(ilev)%av(:) sparse matrices needed for the current level.
|
||||
! Includes:
|
||||
! 2.1.: baseprecv(ilev)%av(l_pr_) L factor of ILU preconditioners
|
||||
! 2.2.: baseprecv(ilev)%av(u_pr_) U factor of ILU preconditioners
|
||||
! 2.3.: baseprecv(ilev)%av(ap_nd_) Off-diagonal part of A for Jacobi sweeps
|
||||
! 2.4.: baseprecv(ilev)%av(ac_) Aggregated matrix of level ILEV
|
||||
! 2.5.: baseprecv(ilev)%av(sm_pr_t_) Smoother prolongator transpose; maps vectors
|
||||
! (ilev-1) ---> (ilev)
|
||||
! 2.6.: baseprecv(ilev)%av(sm_pr_) Smoother prolongator; maps vectors
|
||||
! (ilev) ---> (ilev-1)
|
||||
! Shouldn't we keep just one of them and handle transpose in the sparse BLAS? maybe
|
||||
!
|
||||
! 3. baseprecv(ilev)%desc_data comm descriptor for level ILEV
|
||||
! 4. baseprecv(ilev)%base_a Pointer (really a pointer!) to the base matrix
|
||||
! of the current level, i.e.: if ILEV=1 then A
|
||||
! else the aggregated matrix av(ac_); so we have
|
||||
! a unified treatment of residuals. Need this to
|
||||
! avoid passing explicitly matrix A to the
|
||||
! outer prec. routine
|
||||
! 5. baseprecv(ilev)%mlia The aggregation map from (ilev-1)-->(ilev)
|
||||
! if no smoother, it is used instead of sm_pr_
|
||||
! 6. baseprecv(ilev)%nlaggr Number of aggregates on the various procs.
|
||||
!
|
||||
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
|
||||
type(psb_desc_type),intent(in) :: desc_data
|
||||
type(psb_zbaseprc_type), intent(in) :: baseprecv(:)
|
||||
complex(kind(1.d0)),intent(in) :: alpha,beta
|
||||
complex(kind(1.d0)),intent(inout) :: x(:), y(:)
|
||||
character :: trans
|
||||
complex(kind(1.d0)),target :: work(:)
|
||||
integer, intent(out) :: info
|
||||
|
||||
|
||||
! Local variables
|
||||
integer :: n_row,n_col
|
||||
character ::diagl, diagu
|
||||
integer :: ictxt,np,me,i, isz, nrg,nr2l,err_act, iptype, int_err(5)
|
||||
real(kind(1.d0)) :: omega
|
||||
real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime
|
||||
logical, parameter :: debug=.false., debugprt=.false.
|
||||
integer :: ismth, nlev, ilev
|
||||
external mpi_wtime
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
type psb_mlprec_wrk_type
|
||||
complex(kind(1.d0)), allocatable :: tx(:),ty(:),x2l(:),y2l(:)
|
||||
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)
|
||||
|
||||
|
||||
ictxt=desc_data%matrix_data(psb_ctxt_)
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
nlev = size(baseprecv)
|
||||
allocate(mlprec_wrk(nlev),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
select case(baseprecv(2)%iprcparm(ml_type_))
|
||||
|
||||
case(no_ml_)
|
||||
! Should not really get here.
|
||||
call psb_errpush(4010,name,a_err='no_ml_ in mlprc_aply?')
|
||||
goto 9999
|
||||
|
||||
|
||||
case(add_ml_prec_)
|
||||
|
||||
|
||||
!
|
||||
! Additive is very simple.
|
||||
! 1. X(1) = Xext
|
||||
! 2. DO ILEV=2,NLEV
|
||||
! X(ILEV) = AV(PR_SM_T_)*X(ILEV-1)
|
||||
! Y(ILEV) = (K(ILEV)**(-1))*X(ILEV)
|
||||
! 3. DO ILEV=NLEV-1,1,-1
|
||||
! Y(ILEV) = AV(PR_SM_)*Y(ILEV+1)
|
||||
! 4. Yext = beta*Yext + alpha*Y(1)
|
||||
!
|
||||
! Note: level numbering reversed wrt ref. DD, i.e.
|
||||
! 1..NLEV <=> (j) <-> 0
|
||||
|
||||
|
||||
call psb_baseprc_aply(alpha,baseprecv(1),x,beta,y,&
|
||||
& baseprecv(1)%base_desc,trans,work,info)
|
||||
if(info /=0) goto 9999
|
||||
allocate(mlprec_wrk(1)%x2l(size(x)),mlprec_wrk(1)%y2l(size(y)))
|
||||
mlprec_wrk(1)%x2l(:) = x(:)
|
||||
|
||||
|
||||
do ilev = 2, nlev
|
||||
n_row = baseprecv(ilev-1)%base_desc%matrix_data(psb_n_row_)
|
||||
n_col = baseprecv(ilev-1)%desc_data%matrix_data(psb_n_col_)
|
||||
nr2l = baseprecv(ilev)%desc_data%matrix_data(psb_n_col_)
|
||||
nrg = baseprecv(ilev)%desc_data%matrix_data(psb_n_row_)
|
||||
allocate(mlprec_wrk(ilev)%x2l(nr2l),mlprec_wrk(ilev)%y2l(nr2l),&
|
||||
& mlprec_wrk(ilev)%tx(max(n_row,n_col)),&
|
||||
& mlprec_wrk(ilev)%ty(max(n_row,n_col)), stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
mlprec_wrk(ilev)%x2l(:) = zzero
|
||||
mlprec_wrk(ilev)%y2l(:) = zzero
|
||||
mlprec_wrk(ilev)%tx(1:n_row) = mlprec_wrk(ilev-1)%x2l(1:n_row)
|
||||
mlprec_wrk(ilev)%tx(n_row+1:max(n_row,n_col)) = zzero
|
||||
mlprec_wrk(ilev)%ty(:) = zzero
|
||||
|
||||
ismth=baseprecv(ilev)%iprcparm(smth_kind_)
|
||||
|
||||
if (ismth /= no_smth_) then
|
||||
!
|
||||
! Smoothed aggregation
|
||||
!
|
||||
|
||||
|
||||
if (baseprecv(ilev)%iprcparm(glb_smth_) >0) then
|
||||
call psb_halo(mlprec_wrk(ilev-1)%x2l,baseprecv(ilev-1)%base_desc,&
|
||||
& info,work=work)
|
||||
if(info /=0) goto 9999
|
||||
else
|
||||
mlprec_wrk(ilev-1)%x2l(n_row+1:max(n_row,n_col)) = zzero
|
||||
end if
|
||||
|
||||
call psb_csmm(zone,baseprecv(ilev)%av(sm_pr_t_),mlprec_wrk(ilev-1)%x2l,&
|
||||
& zzero,mlprec_wrk(ilev)%x2l,info)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
else
|
||||
!
|
||||
! Raw aggregation, may take shortcut
|
||||
!
|
||||
do i=1,n_row
|
||||
mlprec_wrk(ilev)%x2l(baseprecv(ilev)%mlia(i)) = &
|
||||
& mlprec_wrk(ilev)%x2l(baseprecv(ilev)%mlia(i)) + &
|
||||
& mlprec_wrk(ilev-1)%x2l(i)
|
||||
end do
|
||||
|
||||
end if
|
||||
|
||||
if (baseprecv(ilev)%iprcparm(coarse_mat_)==mat_repl_) Then
|
||||
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nrg))
|
||||
else if (baseprecv(ilev)%iprcparm(coarse_mat_) /= mat_distr_) Then
|
||||
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',&
|
||||
& baseprecv(ilev)%iprcparm(coarse_mat_)
|
||||
endif
|
||||
|
||||
call psb_baseprc_aply(zone,baseprecv(ilev),&
|
||||
& mlprec_wrk(ilev)%x2l,zzero,mlprec_wrk(ilev)%y2l,&
|
||||
& baseprecv(ilev)%desc_data, 'N',work,info)
|
||||
|
||||
enddo
|
||||
|
||||
do ilev =nlev,2,-1
|
||||
|
||||
ismth=baseprecv(ilev)%iprcparm(smth_kind_)
|
||||
n_row = baseprecv(ilev-1)%base_desc%matrix_data(psb_n_row_)
|
||||
n_col = baseprecv(ilev-1)%desc_data%matrix_data(psb_n_col_)
|
||||
nr2l = baseprecv(ilev)%desc_data%matrix_data(psb_n_col_)
|
||||
nrg = baseprecv(ilev)%desc_data%matrix_data(psb_n_row_)
|
||||
|
||||
if (ismth /= no_smth_) then
|
||||
|
||||
call psb_csmm(zone,baseprecv(ilev)%av(sm_pr_),mlprec_wrk(ilev)%y2l,&
|
||||
& zone,mlprec_wrk(ilev-1)%y2l,info)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
else
|
||||
|
||||
do i=1, n_row
|
||||
mlprec_wrk(ilev-1)%y2l(i) = mlprec_wrk(ilev-1)%y2l(i) + &
|
||||
& mlprec_wrk(ilev)%y2l(baseprecv(ilev)%mlia(i))
|
||||
enddo
|
||||
|
||||
end if
|
||||
end do
|
||||
|
||||
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,zone,y,baseprecv(1)%base_desc,info)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
|
||||
case(mult_ml_prec_)
|
||||
|
||||
!
|
||||
! Multiplicative multilevel
|
||||
! Pre/post smoothing versions.
|
||||
!
|
||||
|
||||
select case(baseprecv(2)%iprcparm(smth_pos_))
|
||||
|
||||
case(post_smooth_)
|
||||
|
||||
!
|
||||
! Post smoothing.
|
||||
! 1. X(1) = Xext
|
||||
! 2. DO ILEV=2, NLEV :: X(ILEV) = AV(PR_SM_T_,ILEV)*X(ILEV-1)
|
||||
! 3. Y(NLEV) = (K(NLEV)**(-1))*X(NLEV)
|
||||
! 4. DO ILEV=NLEV-1,1,-1
|
||||
! Y(ILEV) = AV(PR_SM_,ILEV+1)*Y(ILEV+1)
|
||||
! Y(ILEV) = Y(ILEV) + (K(ILEV)**(-1))*(X(ILEV)-A(ILEV)*Y(ILEV))
|
||||
!
|
||||
! 5. Yext = beta*Yext + alpha*Y(1)
|
||||
!
|
||||
! Note: level numbering reversed wrt ref. DD, i.e.
|
||||
! 1..NLEV <=> (j) <-> 0
|
||||
!
|
||||
! Also: post smoothing in the ref. DD is only presented for NLEV=2.
|
||||
!
|
||||
!
|
||||
|
||||
n_col = desc_data%matrix_data(psb_n_col_)
|
||||
nr2l = baseprecv(1)%desc_data%matrix_data(psb_n_col_)
|
||||
|
||||
allocate(mlprec_wrk(1)%x2l(nr2l),mlprec_wrk(1)%y2l(nr2l), &
|
||||
& mlprec_wrk(1)%tx(nr2l), stat=info)
|
||||
mlprec_wrk(1)%x2l(:) = zzero
|
||||
mlprec_wrk(1)%y2l(:) = zzero
|
||||
mlprec_wrk(1)%tx(:) = zzero
|
||||
|
||||
call psb_geaxpby(zone,x,zzero,mlprec_wrk(1)%tx,&
|
||||
& baseprecv(1)%base_desc,info)
|
||||
call psb_geaxpby(zone,x,zzero,mlprec_wrk(1)%x2l,&
|
||||
& baseprecv(1)%base_desc,info)
|
||||
|
||||
do ilev=2, nlev
|
||||
n_row = baseprecv(ilev-1)%base_desc%matrix_data(psb_n_row_)
|
||||
n_col = baseprecv(ilev-1)%desc_data%matrix_data(psb_n_col_)
|
||||
nr2l = baseprecv(ilev)%desc_data%matrix_data(psb_n_col_)
|
||||
nrg = baseprecv(ilev)%desc_data%matrix_data(psb_n_row_)
|
||||
ismth = baseprecv(ilev)%iprcparm(smth_kind_)
|
||||
|
||||
allocate(mlprec_wrk(ilev)%tx(nr2l),mlprec_wrk(ilev)%y2l(nr2l),&
|
||||
& mlprec_wrk(ilev)%x2l(nr2l), stat=info)
|
||||
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
mlprec_wrk(ilev)%x2l(:) = zzero
|
||||
mlprec_wrk(ilev)%y2l(:) = zzero
|
||||
mlprec_wrk(ilev)%tx(:) = zzero
|
||||
if (ismth /= no_smth_) then
|
||||
!
|
||||
! Smoothed aggregation
|
||||
!
|
||||
if (baseprecv(ilev)%iprcparm(glb_smth_) >0) then
|
||||
call psb_halo(mlprec_wrk(ilev-1)%x2l,&
|
||||
& baseprecv(ilev-1)%base_desc,info,work=work)
|
||||
if(info /=0) goto 9999
|
||||
else
|
||||
mlprec_wrk(ilev-1)%x2l(n_row+1:max(n_row,n_col)) = zzero
|
||||
end if
|
||||
|
||||
call psb_csmm(zone,baseprecv(ilev)%av(sm_pr_t_),mlprec_wrk(ilev-1)%x2l, &
|
||||
& zzero,mlprec_wrk(ilev)%x2l,info)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
else
|
||||
!
|
||||
! Raw aggregation, may take shortcut
|
||||
!
|
||||
do i=1,n_row
|
||||
mlprec_wrk(ilev)%x2l(baseprecv(ilev)%mlia(i)) = &
|
||||
& mlprec_wrk(ilev)%x2l(baseprecv(ilev)%mlia(i)) + &
|
||||
& mlprec_wrk(ilev-1)%x2l(i)
|
||||
end do
|
||||
end if
|
||||
|
||||
if (baseprecv(ilev)%iprcparm(coarse_mat_)==mat_repl_) Then
|
||||
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nrg))
|
||||
else if (baseprecv(ilev)%iprcparm(coarse_mat_) /= mat_distr_) Then
|
||||
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',&
|
||||
& baseprecv(ilev)%iprcparm(coarse_mat_)
|
||||
endif
|
||||
call psb_geaxpby(zone,mlprec_wrk(ilev)%x2l,zzero,mlprec_wrk(ilev)%tx,&
|
||||
& baseprecv(ilev)%base_desc,info)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
enddo
|
||||
|
||||
|
||||
call psb_baseprc_aply(zone,baseprecv(nlev),mlprec_wrk(nlev)%x2l, &
|
||||
& zzero, mlprec_wrk(nlev)%y2l,baseprecv(nlev)%desc_data,'N',work,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
|
||||
do ilev=nlev-1, 1, -1
|
||||
ismth = baseprecv(ilev+1)%iprcparm(smth_kind_)
|
||||
if (ismth /= no_smth_) then
|
||||
if (ismth == smth_omg_) &
|
||||
& call psb_halo(mlprec_wrk(ilev+1)%y2l,baseprecv(ilev+1)%desc_data,&
|
||||
& info,work=work)
|
||||
call psb_csmm(zone,baseprecv(ilev+1)%av(sm_pr_),mlprec_wrk(ilev+1)%y2l,&
|
||||
& zzero,mlprec_wrk(ilev)%y2l,info)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
else
|
||||
n_row = baseprecv(ilev)%base_desc%matrix_data(psb_n_row_)
|
||||
mlprec_wrk(ilev)%y2l(:) = zzero
|
||||
do i=1, n_row
|
||||
mlprec_wrk(ilev)%y2l(i) = mlprec_wrk(ilev)%y2l(i) + &
|
||||
& mlprec_wrk(ilev+1)%y2l(baseprecv(ilev+1)%mlia(i))
|
||||
enddo
|
||||
|
||||
end if
|
||||
|
||||
call psb_spmm(-zone,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
|
||||
& zone,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,work=work)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
call psb_baseprc_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
|
||||
& zone,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
enddo
|
||||
|
||||
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,baseprecv(1)%base_desc,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
|
||||
case(pre_smooth_)
|
||||
|
||||
!
|
||||
! Pre smoothing.
|
||||
! 1. X(1) = Xext
|
||||
! 2. Y(1) = (K(1)**(-1))*X(1)
|
||||
! 3. TX(1) = X(1) - A(1)*Y(1)
|
||||
! 4. DO ILEV=2, NLEV
|
||||
! X(ILEV) = AV(PR_SM_T_,ILEV)*TX(ILEV-1)
|
||||
! Y(ILEV) = (K(ILEV)**(-1))*X(ILEV)
|
||||
! TX(ILEV) = (X(ILEV)-A(ILEV)*Y(ILEV))
|
||||
! 5. DO ILEV=NLEV-1,1,-1
|
||||
! Y(ILEV) = Y(ILEV) + AV(PR_SM_,ILEV+1)*Y(ILEV+1)
|
||||
! 6. Yext = beta*Yext + alpha*Y(1)
|
||||
!
|
||||
! Note: level numbering reversed wrt ref. DD, i.e.
|
||||
! 1..NLEV <=> (j) <-> 0
|
||||
!
|
||||
!
|
||||
|
||||
n_col = desc_data%matrix_data(psb_n_col_)
|
||||
nr2l = baseprecv(1)%desc_data%matrix_data(psb_n_col_)
|
||||
|
||||
allocate(mlprec_wrk(1)%x2l(nr2l),mlprec_wrk(1)%y2l(nr2l), &
|
||||
& mlprec_wrk(1)%tx(nr2l), stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
mlprec_wrk(1)%y2l(:) = zzero
|
||||
mlprec_wrk(1)%x2l(:) = x
|
||||
|
||||
call psb_baseprc_aply(zone,baseprecv(1),mlprec_wrk(1)%x2l,&
|
||||
& zzero,mlprec_wrk(1)%y2l,&
|
||||
& baseprecv(1)%base_desc,&
|
||||
& trans,work,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
mlprec_wrk(1)%tx = mlprec_wrk(1)%x2l
|
||||
|
||||
call psb_spmm(-zone,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,&
|
||||
& zone,mlprec_wrk(1)%tx,baseprecv(1)%base_desc,info,work=work)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
do ilev = 2, nlev
|
||||
n_row = baseprecv(ilev-1)%base_desc%matrix_data(psb_n_row_)
|
||||
n_col = baseprecv(ilev-1)%desc_data%matrix_data(psb_n_col_)
|
||||
nr2l = baseprecv(ilev)%desc_data%matrix_data(psb_n_col_)
|
||||
nrg = baseprecv(ilev)%desc_data%matrix_data(psb_n_row_)
|
||||
ismth = baseprecv(ilev)%iprcparm(smth_kind_)
|
||||
allocate(mlprec_wrk(ilev)%tx(nr2l),mlprec_wrk(ilev)%y2l(nr2l),&
|
||||
& mlprec_wrk(ilev)%x2l(nr2l), stat=info)
|
||||
|
||||
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
mlprec_wrk(ilev)%x2l(:) = zzero
|
||||
mlprec_wrk(ilev)%y2l(:) = zzero
|
||||
mlprec_wrk(ilev)%tx(:) = zzero
|
||||
|
||||
|
||||
if (ismth /= no_smth_) then
|
||||
!
|
||||
!Smoothed Aggregation
|
||||
!
|
||||
if (baseprecv(ilev)%iprcparm(glb_smth_) >0) then
|
||||
|
||||
call psb_halo(mlprec_wrk(ilev-1)%tx,baseprecv(ilev-1)%base_desc,&
|
||||
& info,work=work)
|
||||
if(info /=0) goto 9999
|
||||
else
|
||||
mlprec_wrk(ilev-1)%tx(n_row+1:max(n_row,n_col)) = zzero
|
||||
end if
|
||||
|
||||
call psb_csmm(zone,baseprecv(ilev)%av(sm_pr_t_),mlprec_wrk(ilev-1)%tx,zzero,&
|
||||
& mlprec_wrk(ilev)%x2l,info)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
else
|
||||
!
|
||||
! Raw aggregation, may take shortcuts
|
||||
!
|
||||
mlprec_wrk(ilev)%x2l = zzero
|
||||
do i=1,n_row
|
||||
mlprec_wrk(ilev)%x2l(baseprecv(ilev)%mlia(i)) = &
|
||||
& mlprec_wrk(ilev)%x2l(baseprecv(ilev)%mlia(i)) + &
|
||||
& mlprec_wrk(ilev-1)%tx(i)
|
||||
end do
|
||||
end if
|
||||
|
||||
if (baseprecv(ilev)%iprcparm(coarse_mat_)==mat_repl_) then
|
||||
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nrg))
|
||||
else if (baseprecv(ilev)%iprcparm(coarse_mat_) /= mat_distr_) then
|
||||
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',&
|
||||
& baseprecv(ilev)%iprcparm(coarse_mat_)
|
||||
endif
|
||||
|
||||
|
||||
call psb_baseprc_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%x2l,&
|
||||
& zzero,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%desc_data, 'N',work,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
if(ilev < nlev) then
|
||||
mlprec_wrk(ilev)%tx = mlprec_wrk(ilev)%x2l
|
||||
call psb_spmm(-zone,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
|
||||
& zone,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,work=work)
|
||||
if(info /=0) goto 9999
|
||||
endif
|
||||
|
||||
enddo
|
||||
|
||||
do ilev = nlev-1, 1, -1
|
||||
|
||||
ismth=baseprecv(ilev+1)%iprcparm(smth_kind_)
|
||||
|
||||
if (ismth /= no_smth_) then
|
||||
|
||||
if (ismth == smth_omg_) &
|
||||
& call psb_halo(mlprec_wrk(ilev+1)%y2l,&
|
||||
& baseprecv(ilev+1)%desc_data,info,work=work)
|
||||
call psb_csmm(zone,baseprecv(ilev+1)%av(sm_pr_),mlprec_wrk(ilev+1)%y2l,&
|
||||
& zone,mlprec_wrk(ilev)%y2l,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
else
|
||||
|
||||
n_row = baseprecv(ilev+1)%base_desc%matrix_data(psb_n_row_)
|
||||
do i=1, n_row
|
||||
mlprec_wrk(ilev)%y2l(i) = mlprec_wrk(ilev)%y2l(i) + &
|
||||
& mlprec_wrk(ilev+1)%y2l(baseprecv(ilev+1)%mlia(i))
|
||||
enddo
|
||||
|
||||
end if
|
||||
|
||||
enddo
|
||||
|
||||
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,&
|
||||
& baseprecv(1)%base_desc,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
|
||||
|
||||
case(smooth_both_)
|
||||
|
||||
!
|
||||
! Symmetrized smoothing.
|
||||
! 1. X(1) = Xext
|
||||
! 2. Y(1) = (K(1)**(-1))*X(1)
|
||||
! 3. TX(1) = X(1) - A(1)*Y(1)
|
||||
! 4. DO ILEV=2, NLEV
|
||||
! X(ILEV) = AV(PR_SM_T_,ILEV)*TX(ILEV-1)
|
||||
! Y(ILEV) = (K(ILEV)**(-1))*X(ILEV)
|
||||
! TX(ILEV) = (X(ILEV)-A(ILEV)*Y(ILEV))
|
||||
! 5. DO ILEV=NLEV-1,1,-1
|
||||
! Y(ILEV) = Y(ILEV) + AV(PR_SM_,ILEV+1)*Y(ILEV+1)
|
||||
! Y(ILEV) = Y(ILEV) + (K(ILEV)**(-1))*(X(ILEV)-A(ILEV)*Y(ILEV))
|
||||
! 6. Yext = beta*Yext + alpha*Y(1)
|
||||
!
|
||||
! Note: level numbering reversed wrt ref. DD, i.e.
|
||||
! 1..NLEV <=> (j) <-> 0
|
||||
!
|
||||
!
|
||||
n_col = desc_data%matrix_data(psb_n_col_)
|
||||
nr2l = baseprecv(1)%desc_data%matrix_data(psb_n_col_)
|
||||
|
||||
allocate(mlprec_wrk(1)%x2l(nr2l),mlprec_wrk(1)%y2l(nr2l), &
|
||||
& mlprec_wrk(1)%ty(nr2l), mlprec_wrk(1)%tx(nr2l), stat=info)
|
||||
|
||||
mlprec_wrk(1)%x2l(:) = zzero
|
||||
mlprec_wrk(1)%y2l(:) = zzero
|
||||
mlprec_wrk(1)%tx(:) = zzero
|
||||
mlprec_wrk(1)%ty(:) = zzero
|
||||
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_geaxpby(zone,x,zzero,mlprec_wrk(1)%x2l,&
|
||||
& baseprecv(1)%base_desc,info)
|
||||
call psb_geaxpby(zone,x,zzero,mlprec_wrk(1)%tx,&
|
||||
& baseprecv(1)%base_desc,info)
|
||||
|
||||
call psb_baseprc_aply(zone,baseprecv(1),mlprec_wrk(1)%x2l,&
|
||||
& zzero,mlprec_wrk(1)%y2l,&
|
||||
& baseprecv(1)%base_desc,&
|
||||
& trans,work,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
mlprec_wrk(1)%ty = mlprec_wrk(1)%x2l
|
||||
|
||||
call psb_spmm(-zone,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,&
|
||||
& zone,mlprec_wrk(1)%ty,baseprecv(1)%base_desc,info,work=work)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
do ilev = 2, nlev
|
||||
n_row = baseprecv(ilev-1)%base_desc%matrix_data(psb_n_row_)
|
||||
n_col = baseprecv(ilev-1)%desc_data%matrix_data(psb_n_col_)
|
||||
nr2l = baseprecv(ilev)%desc_data%matrix_data(psb_n_col_)
|
||||
nrg = baseprecv(ilev)%desc_data%matrix_data(psb_n_row_)
|
||||
ismth=baseprecv(ilev)%iprcparm(smth_kind_)
|
||||
allocate(mlprec_wrk(ilev)%ty(nr2l),mlprec_wrk(ilev)%y2l(nr2l),&
|
||||
& mlprec_wrk(ilev)%x2l(nr2l), stat=info)
|
||||
|
||||
mlprec_wrk(ilev)%x2l(:) = zzero
|
||||
mlprec_wrk(ilev)%y2l(:) = zzero
|
||||
mlprec_wrk(ilev)%tx(:) = zzero
|
||||
mlprec_wrk(ilev)%ty(:) = zzero
|
||||
|
||||
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
if (ismth /= no_smth_) then
|
||||
!
|
||||
!Smoothed Aggregation
|
||||
!
|
||||
if (baseprecv(ilev)%iprcparm(glb_smth_) >0) then
|
||||
|
||||
call psb_halo(mlprec_wrk(ilev-1)%ty,baseprecv(ilev-1)%base_desc,&
|
||||
& info,work=work)
|
||||
if(info /=0) goto 9999
|
||||
else
|
||||
mlprec_wrk(ilev-1)%ty(n_row+1:max(n_row,n_col)) = zzero
|
||||
end if
|
||||
|
||||
call psb_csmm(zone,baseprecv(ilev)%av(sm_pr_t_),mlprec_wrk(ilev-1)%ty,zzero,&
|
||||
& mlprec_wrk(ilev)%x2l,info)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
else
|
||||
!
|
||||
! Raw aggregation, may take shortcuts
|
||||
!
|
||||
mlprec_wrk(ilev)%x2l = zzero
|
||||
do i=1,n_row
|
||||
mlprec_wrk(ilev)%x2l(baseprecv(ilev)%mlia(i)) = &
|
||||
& mlprec_wrk(ilev)%x2l(baseprecv(ilev)%mlia(i)) + &
|
||||
& mlprec_wrk(ilev-1)%ty(i)
|
||||
end do
|
||||
end if
|
||||
|
||||
if (baseprecv(ilev)%iprcparm(coarse_mat_)==mat_repl_) then
|
||||
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nrg))
|
||||
else if (baseprecv(ilev)%iprcparm(coarse_mat_) /= mat_distr_) then
|
||||
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',&
|
||||
& baseprecv(ilev)%iprcparm(coarse_mat_)
|
||||
endif
|
||||
|
||||
call psb_geaxpby(zone,mlprec_wrk(ilev)%x2l,zzero,mlprec_wrk(ilev)%tx,&
|
||||
& baseprecv(ilev)%base_desc,info)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
call psb_baseprc_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%x2l,&
|
||||
& zzero,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%desc_data, 'N',work,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
if(ilev < nlev) then
|
||||
mlprec_wrk(ilev)%ty = mlprec_wrk(ilev)%x2l
|
||||
call psb_spmm(-zone,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
|
||||
& zone,mlprec_wrk(ilev)%ty,baseprecv(ilev)%base_desc,info,work=work)
|
||||
if(info /=0) goto 9999
|
||||
endif
|
||||
|
||||
enddo
|
||||
|
||||
|
||||
do ilev=nlev-1, 1, -1
|
||||
|
||||
ismth=baseprecv(ilev+1)%iprcparm(smth_kind_)
|
||||
if (ismth /= no_smth_) then
|
||||
if (ismth == smth_omg_) &
|
||||
& call psb_halo(mlprec_wrk(ilev+1)%y2l,baseprecv(ilev+1)%desc_data,&
|
||||
& info,work=work)
|
||||
call psb_csmm(zone,baseprecv(ilev+1)%av(sm_pr_),mlprec_wrk(ilev+1)%y2l,&
|
||||
& zone,mlprec_wrk(ilev)%y2l,info)
|
||||
if(info /=0) goto 9999
|
||||
|
||||
else
|
||||
n_row = baseprecv(ilev)%base_desc%matrix_data(psb_n_row_)
|
||||
do i=1, n_row
|
||||
mlprec_wrk(ilev)%y2l(i) = mlprec_wrk(ilev)%y2l(i) + &
|
||||
& mlprec_wrk(ilev+1)%y2l(baseprecv(ilev+1)%mlia(i))
|
||||
enddo
|
||||
|
||||
end if
|
||||
|
||||
call psb_spmm(-zone,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
|
||||
& zone,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,work=work)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
call psb_baseprc_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
|
||||
& zone,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
enddo
|
||||
|
||||
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,&
|
||||
& baseprecv(1)%base_desc,info)
|
||||
|
||||
if(info /=0) goto 9999
|
||||
|
||||
case default
|
||||
|
||||
call psb_errpush(4013,name,a_err='wrong smooth_pos',&
|
||||
& i_Err=(/baseprecv(2)%iprcparm(smth_pos_),0,0,0,0/))
|
||||
goto 9999
|
||||
|
||||
end select
|
||||
|
||||
case default
|
||||
call psb_errpush(4013,name,a_err='wrong mltype',&
|
||||
& i_Err=(/baseprecv(2)%iprcparm(ml_type_),0,0,0,0/))
|
||||
goto 9999
|
||||
|
||||
end select
|
||||
|
||||
deallocate(mlprec_wrk)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_errpush(info,name)
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
!!$contains
|
||||
!!$ subroutine mlprec_wrk_free(wrk)
|
||||
!!$ type(psb_mlprec_wrk_type) :: wrk(:)
|
||||
!!$ ! This will not be needed when we have allocatables, as
|
||||
!!$ ! it is sufficient to deallocate the container, and
|
||||
!!$ ! the compiler is supposed to recursively deallocate the
|
||||
!!$ ! various components.
|
||||
!!$ integer i
|
||||
!!$
|
||||
!!$ do i=1, size(wrk)
|
||||
!!$ if (associated(wrk(i)%tx)) deallocate(wrk(i)%tx)
|
||||
!!$ if (associated(wrk(i)%ty)) deallocate(wrk(i)%ty)
|
||||
!!$ if (associated(wrk(i)%x2l)) deallocate(wrk(i)%x2l)
|
||||
!!$ if (associated(wrk(i)%y2l)) deallocate(wrk(i)%y2l)
|
||||
!!$ if (associated(wrk(i)%b2l)) deallocate(wrk(i)%b2l)
|
||||
!!$ if (associated(wrk(i)%tty)) deallocate(wrk(i)%tty)
|
||||
!!$ end do
|
||||
!!$ end subroutine mlprec_wrk_free
|
||||
|
||||
end subroutine psb_zmlprc_aply
|
||||
|
||||
@ -0,0 +1,198 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_zmlprc_bld(a,desc_a,p,info)
|
||||
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
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
|
||||
integer, intent(out) :: info
|
||||
|
||||
type(psb_desc_type) :: desc_ac
|
||||
|
||||
integer :: i, nrg, nzg, err_act,k
|
||||
character(len=20) :: name, ch_err
|
||||
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'
|
||||
if (psb_get_errstatus().ne.0) return
|
||||
info = 0
|
||||
ictxt = psb_cd_get_context(desc_a)
|
||||
call psb_info(ictxt,me,np)
|
||||
call psb_erractionsave(err_act)
|
||||
call psb_nullify_sp(ac)
|
||||
|
||||
|
||||
if (.not.allocated(p%iprcparm)) then
|
||||
info = 2222
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
call psb_check_def(p%iprcparm(ml_type_),'Multilevel type',&
|
||||
& mult_ml_prec_,is_legal_ml_type)
|
||||
call psb_check_def(p%iprcparm(aggr_alg_),'aggregation',&
|
||||
& loc_aggr_,is_legal_ml_aggr_kind)
|
||||
call psb_check_def(p%iprcparm(smth_kind_),'Smoother kind',&
|
||||
& smth_omg_,is_legal_ml_smth_kind)
|
||||
call psb_check_def(p%iprcparm(coarse_mat_),'Coarse matrix',&
|
||||
& mat_distr_,is_legal_ml_coarse_mat)
|
||||
call psb_check_def(p%iprcparm(smth_pos_),'smooth_pos',&
|
||||
& pre_smooth_,is_legal_ml_smooth_pos)
|
||||
|
||||
|
||||
!!$ nullify(p%desc_data)
|
||||
select case(p%iprcparm(f_type_))
|
||||
case(f_ilu_n_)
|
||||
call psb_check_def(p%iprcparm(ilu_fill_in_),'Level',0,is_legal_ml_lev)
|
||||
case(f_ilu_e_)
|
||||
call psb_check_def(p%dprcparm(fact_eps_),'Eps',dzero,is_legal_ml_eps)
|
||||
end select
|
||||
call psb_check_def(p%dprcparm(smooth_omega_),'omega',dzero,is_legal_omega)
|
||||
call psb_check_def(p%iprcparm(jac_sweeps_),'Jacobi sweeps',&
|
||||
& 1,is_legal_jac_sweeps)
|
||||
|
||||
|
||||
! Currently this is ignored by gen_aggrmap, but it could be
|
||||
! changed in the future. Need to package nlaggr & mlia in a
|
||||
! private data structure?
|
||||
call psb_genaggrmap(p%iprcparm(aggr_alg_),a,desc_a,p%nlaggr,p%mlia,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_gen_aggrmap'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (debug) write(0,*) 'Out from genaggrmap',p%nlaggr
|
||||
|
||||
call psb_nullify_desc(desc_ac)
|
||||
call psb_bldaggrmat(a,desc_a,ac,desc_ac,p,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_bld_aggrmat'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
if (debug) write(0,*) 'Out from bldaggrmat',desc_ac%matrix_data(:)
|
||||
|
||||
|
||||
|
||||
call psb_baseprc_bld(ac,desc_ac,p,info)
|
||||
if (debug) write(0,*) 'Out from baseprcbld',info
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_baseprc_bld'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
!
|
||||
! We have used a separate ac because:
|
||||
! 1. We want to reuse the same routines psb_ilu_bld etc.
|
||||
! 2. We do NOT want to pass an argument twice to them
|
||||
! p%av(ac_) and p, as this would violate the Fortran standard
|
||||
! Hence a separate AC and a TRANSFER function at the end.
|
||||
!
|
||||
call psb_sp_transfer(ac,p%av(ac_),info)
|
||||
p%base_a => p%av(ac_)
|
||||
call psb_cdtransfer(desc_ac,p%desc_ac,info)
|
||||
|
||||
if (info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_cdtransfer'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
p%base_desc => p%desc_ac
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
Return
|
||||
|
||||
end subroutine psb_zmlprc_bld
|
||||
@ -0,0 +1,247 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans, work)
|
||||
|
||||
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(:)
|
||||
integer, intent(out) :: info
|
||||
character(len=1), optional :: trans
|
||||
complex(kind(0.d0)), optional, target :: work(:)
|
||||
|
||||
! Local variables
|
||||
character :: trans_
|
||||
complex(kind(1.d0)), pointer :: work_(:)
|
||||
integer :: ictxt,np,me,err_act
|
||||
logical,parameter :: debug=.false., debugprt=.false.
|
||||
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)
|
||||
|
||||
ictxt=desc_data%matrix_data(psb_ctxt_)
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
if (present(trans)) then
|
||||
trans_=trans
|
||||
else
|
||||
trans_='N'
|
||||
end if
|
||||
|
||||
if (present(work)) then
|
||||
work_ => work
|
||||
else
|
||||
allocate(work_(4*desc_data%matrix_data(psb_n_col_)),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
end if
|
||||
|
||||
if (.not.(allocated(prec%baseprecv))) then
|
||||
write(0,*) 'Inconsistent preconditioner: neither SMTH nor BASE?'
|
||||
end if
|
||||
if (size(prec%baseprecv) >1) then
|
||||
if (debug) write(0,*) 'Into mlprc_aply',size(x),size(y)
|
||||
call psb_mlprc_aply(zone,prec%baseprecv,x,zzero,y,desc_data,trans_,work_,info)
|
||||
if(info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='psb_zmlprc_aply')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
else if (size(prec%baseprecv) == 1) then
|
||||
call psb_baseprc_aply(zone,prec%baseprecv(1),x,zzero,y,desc_data,trans_, work_,info)
|
||||
else
|
||||
write(0,*) 'Inconsistent preconditioner: size of baseprecv???'
|
||||
endif
|
||||
|
||||
if (present(work)) then
|
||||
else
|
||||
deallocate(work_)
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine psb_zprc_aply
|
||||
|
||||
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_zprc_aply1(prec,x,desc_data,info,trans)
|
||||
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(:)
|
||||
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_base_mod
|
||||
use psb_prec_type
|
||||
type(psb_desc_type),intent(in) :: desc_data
|
||||
type(psb_zprec_type), intent(in) :: prec
|
||||
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
|
||||
|
||||
! Local variables
|
||||
character :: trans_
|
||||
integer :: ictxt,np,me,i, isz, err_act, int_err(5)
|
||||
complex(kind(1.d0)), pointer :: WW(:), w1(:)
|
||||
character(len=20) :: name, ch_err
|
||||
name='psb_zprec1'
|
||||
info = 0
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
ictxt=desc_data%matrix_data(psb_ctxt_)
|
||||
call psb_info(ictxt, me, np)
|
||||
if (present(trans)) then
|
||||
trans_=trans
|
||||
else
|
||||
trans_='N'
|
||||
end if
|
||||
|
||||
allocate(ww(size(x)),w1(size(x)),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
if (debug) write(0,*) 'Prc_aply1 Size(x) ',size(x), size(ww),size(w1)
|
||||
call psb_zprc_aply(prec,x,ww,desc_data,info,trans_,work=w1)
|
||||
if(info /=0) goto 9999
|
||||
x(:) = ww(:)
|
||||
deallocate(ww,W1)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_errpush(info,name)
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
end subroutine psb_zprc_aply1
|
||||
@ -0,0 +1,169 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_zprecbld(a,desc_a,p,info,upd)
|
||||
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
use psb_prec_mod
|
||||
Implicit None
|
||||
|
||||
type(psb_zspmat_type), target :: a
|
||||
type(psb_desc_type), intent(in), target :: desc_a
|
||||
type(psb_zprec_type),intent(inout) :: p
|
||||
integer, intent(out) :: info
|
||||
character, intent(in), optional :: upd
|
||||
|
||||
|
||||
! Local scalars
|
||||
Integer :: err,i,j,k,ictxt, me,np,lw, err_act
|
||||
integer :: int_err(5)
|
||||
character :: iupd
|
||||
|
||||
logical, parameter :: debug=.false.
|
||||
integer,parameter :: iroot=0,iout=60,ilout=40
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=0
|
||||
err=0
|
||||
call psb_erractionsave(err_act)
|
||||
name = 'psb_precbld'
|
||||
|
||||
if (debug) write(0,*) 'Entering precbld',P%prec,desc_a%matrix_data(:)
|
||||
info = 0
|
||||
int_err(1) = 0
|
||||
ictxt = psb_cd_get_context(desc_a)
|
||||
|
||||
if (debug) write(0,*) 'Preconditioner psb_info'
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
if (present(upd)) then
|
||||
if (debug) write(0,*) 'UPD ', upd
|
||||
if ((upd.eq.'F').or.(upd.eq.'T')) then
|
||||
iupd=upd
|
||||
else
|
||||
iupd='F'
|
||||
endif
|
||||
else
|
||||
iupd='F'
|
||||
endif
|
||||
|
||||
if (.not.allocated(p%baseprecv)) then
|
||||
!! Error 1: should call precset
|
||||
info=4010
|
||||
ch_err='unallocated bpv'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
!
|
||||
! Should add check to ensure all procs have the same...
|
||||
!
|
||||
! ALso should define symbolic names for the preconditioners.
|
||||
!
|
||||
if (size(p%baseprecv) >= 1) then
|
||||
call init_baseprc_av(p%baseprecv(1),info)
|
||||
if (info /= 0) then
|
||||
info=4010
|
||||
ch_err='allocate'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
call psb_baseprc_bld(a,desc_a,p%baseprecv(1),info,iupd)
|
||||
|
||||
else
|
||||
info=4010
|
||||
ch_err='size bpv'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
|
||||
endif
|
||||
|
||||
if (size(p%baseprecv) > 1) then
|
||||
|
||||
do i=2, size(p%baseprecv)
|
||||
call init_baseprc_av(p%baseprecv(i),info)
|
||||
if (info /= 0) then
|
||||
info=4010
|
||||
ch_err='allocate'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
call psb_mlprc_bld(p%baseprecv(i-1)%base_a,p%baseprecv(i-1)%base_desc,&
|
||||
& p%baseprecv(i),info)
|
||||
if (info /= 0) then
|
||||
info=4010
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
if (debug) then
|
||||
write(0,*) 'Return from ',i-1,' call to mlprcbld ',info
|
||||
endif
|
||||
|
||||
end do
|
||||
|
||||
endif
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
contains
|
||||
|
||||
subroutine init_baseprc_av(p,info)
|
||||
type(psb_zbaseprc_type), intent(inout) :: p
|
||||
integer :: info
|
||||
if (allocated(p%av)) then
|
||||
! Have not decided what to do yet
|
||||
end if
|
||||
allocate(p%av(max_avsz),stat=info)
|
||||
!!$ if (info /= 0) return
|
||||
do k=1,size(p%av)
|
||||
call psb_nullify_sp(p%av(k))
|
||||
end do
|
||||
end subroutine init_baseprc_av
|
||||
|
||||
end subroutine psb_zprecbld
|
||||
|
||||
@ -0,0 +1,74 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_zprecfree(p,info)
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
!....parameters...
|
||||
|
||||
type(psb_zprec_type), intent(inout) :: p
|
||||
integer, intent(out) :: info
|
||||
|
||||
!...locals....
|
||||
integer :: ictxt,me, np,err_act,i
|
||||
character(len=20) :: name
|
||||
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=0
|
||||
name = 'pszprecfree'
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
me=-1
|
||||
|
||||
if (allocated(p%baseprecv)) then
|
||||
do i=1,size(p%baseprecv)
|
||||
call psb_base_precfree(p%baseprecv(i),info)
|
||||
end do
|
||||
deallocate(p%baseprecv)
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine psb_zprecfree
|
||||
@ -0,0 +1,187 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_zprecset(p,ptype,info,iv,rs,rv,ilev,nlev)
|
||||
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
|
||||
type(psb_zprec_type), intent(inout) :: p
|
||||
character(len=*), intent(in) :: ptype
|
||||
integer, intent(out) :: info
|
||||
integer, optional, intent(in) :: iv(:)
|
||||
integer, optional, intent(in) :: nlev,ilev
|
||||
real(kind(1.d0)), optional, intent(in) :: rs
|
||||
real(kind(1.d0)), optional, intent(in) :: rv(:)
|
||||
|
||||
character(len=len(ptype)) :: typeup
|
||||
integer :: isz, err, nlev_, ilev_, i
|
||||
|
||||
info = 0
|
||||
|
||||
if (present(ilev)) then
|
||||
ilev_ = max(1, ilev)
|
||||
else
|
||||
ilev_ = 1
|
||||
end if
|
||||
if (present(nlev)) then
|
||||
if (allocated(p%baseprecv)) then
|
||||
write(0,*) 'Warning: NLEV is ignored when P is already allocated'
|
||||
end if
|
||||
nlev_ = max(1, nlev)
|
||||
else
|
||||
nlev_ = 1
|
||||
end if
|
||||
|
||||
if (.not.allocated(p%baseprecv)) then
|
||||
allocate(p%baseprecv(nlev_),stat=err)
|
||||
else
|
||||
nlev_ = size(p%baseprecv)
|
||||
endif
|
||||
|
||||
if ((ilev_<1).or.(ilev_ > nlev_)) then
|
||||
write(0,*) 'PRECSET ERRROR: ilev out of bounds'
|
||||
info = -1
|
||||
return
|
||||
endif
|
||||
|
||||
call psb_realloc(ifpsz,p%baseprecv(ilev_)%iprcparm,info)
|
||||
if (info == 0) call psb_realloc(dfpsz,p%baseprecv(ilev_)%dprcparm,info)
|
||||
if (info /= 0) return
|
||||
p%baseprecv(ilev_)%iprcparm(:) = 0
|
||||
|
||||
select case(toupper(ptype(1:len_trim(ptype))))
|
||||
case ('NONE','NOPREC')
|
||||
p%baseprecv(ilev_)%iprcparm(:) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(p_type_) = noprec_
|
||||
p%baseprecv(ilev_)%iprcparm(f_type_) = f_none_
|
||||
p%baseprecv(ilev_)%iprcparm(restr_) = psb_none_
|
||||
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
|
||||
p%baseprecv(ilev_)%iprcparm(iren_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
|
||||
|
||||
case ('DIAG','DIAGSC')
|
||||
p%baseprecv(ilev_)%iprcparm(:) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(p_type_) = diagsc_
|
||||
p%baseprecv(ilev_)%iprcparm(f_type_) = f_none_
|
||||
p%baseprecv(ilev_)%iprcparm(restr_) = psb_none_
|
||||
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
|
||||
p%baseprecv(ilev_)%iprcparm(iren_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
|
||||
|
||||
case ('BJA','ILU')
|
||||
p%baseprecv(ilev_)%iprcparm(:) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(p_type_) = bja_
|
||||
p%baseprecv(ilev_)%iprcparm(f_type_) = f_ilu_n_
|
||||
p%baseprecv(ilev_)%iprcparm(restr_) = psb_none_
|
||||
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
|
||||
p%baseprecv(ilev_)%iprcparm(iren_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(ilu_fill_in_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
|
||||
|
||||
case ('ASM','AS')
|
||||
p%baseprecv(ilev_)%iprcparm(:) = 0
|
||||
! Defaults first
|
||||
p%baseprecv(ilev_)%iprcparm(p_type_) = asm_
|
||||
p%baseprecv(ilev_)%iprcparm(f_type_) = f_ilu_n_
|
||||
p%baseprecv(ilev_)%iprcparm(restr_) = psb_halo_
|
||||
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
|
||||
p%baseprecv(ilev_)%iprcparm(iren_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 1
|
||||
p%baseprecv(ilev_)%iprcparm(ilu_fill_in_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
|
||||
if (present(iv)) then
|
||||
isz = size(iv)
|
||||
if (isz >= 1) p%baseprecv(ilev_)%iprcparm(n_ovr_) = iv(1)
|
||||
if (isz >= 2) p%baseprecv(ilev_)%iprcparm(restr_) = iv(2)
|
||||
if (isz >= 3) p%baseprecv(ilev_)%iprcparm(prol_) = iv(3)
|
||||
if (isz >= 4) p%baseprecv(ilev_)%iprcparm(f_type_) = iv(4)
|
||||
! Do not consider renum for the time being.
|
||||
!!$ if (isz >= 5) p%baseprecv(ilev_)%iprcparm(iren_) = iv(5)
|
||||
end if
|
||||
|
||||
|
||||
case ('ML', '2L', '2LEV')
|
||||
|
||||
|
||||
p%baseprecv(ilev_)%iprcparm(:) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(p_type_) = bja_
|
||||
p%baseprecv(ilev_)%iprcparm(restr_) = psb_none_
|
||||
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
|
||||
p%baseprecv(ilev_)%iprcparm(iren_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
|
||||
p%baseprecv(ilev_)%iprcparm(ml_type_) = mult_ml_prec_
|
||||
p%baseprecv(ilev_)%iprcparm(aggr_alg_) = loc_aggr_
|
||||
p%baseprecv(ilev_)%iprcparm(smth_kind_) = smth_omg_
|
||||
p%baseprecv(ilev_)%iprcparm(coarse_mat_) = mat_distr_
|
||||
p%baseprecv(ilev_)%iprcparm(smth_pos_) = post_smooth_
|
||||
p%baseprecv(ilev_)%iprcparm(glb_smth_) = 1
|
||||
p%baseprecv(ilev_)%iprcparm(om_choice_) = lib_choice_
|
||||
p%baseprecv(ilev_)%iprcparm(f_type_) = f_ilu_n_
|
||||
p%baseprecv(ilev_)%iprcparm(ilu_fill_in_) = 0
|
||||
p%baseprecv(ilev_)%dprcparm(smooth_omega_) = 4.d0/3.d0
|
||||
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
|
||||
|
||||
if (present(iv)) then
|
||||
isz = size(iv)
|
||||
if (isz >= 1) p%baseprecv(ilev_)%iprcparm(ml_type_) = iv(1)
|
||||
if (isz >= 2) p%baseprecv(ilev_)%iprcparm(aggr_alg_) = iv(2)
|
||||
if (isz >= 3) p%baseprecv(ilev_)%iprcparm(coarse_mat_) = iv(3)
|
||||
if (isz >= 4) p%baseprecv(ilev_)%iprcparm(smth_pos_) = iv(4)
|
||||
if (isz >= 5) p%baseprecv(ilev_)%iprcparm(f_type_) = iv(5)
|
||||
if (isz >= 6) p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = iv(6)
|
||||
if (isz >= 7) p%baseprecv(ilev_)%iprcparm(smth_kind_) = iv(7)
|
||||
end if
|
||||
|
||||
if (present(rs)) then
|
||||
p%baseprecv(ilev_)%iprcparm(om_choice_) = user_choice_
|
||||
p%baseprecv(ilev_)%dprcparm(smooth_omega_) = rs
|
||||
end if
|
||||
|
||||
|
||||
case default
|
||||
write(0,*) 'Unknown preconditioner type request "',ptype,'"'
|
||||
err = 2
|
||||
|
||||
end select
|
||||
|
||||
info = err
|
||||
|
||||
end subroutine psb_zprecset
|
||||
@ -0,0 +1,204 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_zslu_bld(a,desc_a,p,info)
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
|
||||
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
|
||||
|
||||
|
||||
type(psb_zspmat_type) :: blck, atmp
|
||||
character(len=5) :: fmt
|
||||
character :: upd='F'
|
||||
integer :: i,j,nza,nzb,nzt,ictxt, me,np,err_act
|
||||
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'
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
ictxt = desc_A%matrix_data(psb_ctxt_)
|
||||
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
fmt = 'COO'
|
||||
call psb_nullify_sp(blck)
|
||||
call psb_nullify_sp(atmp)
|
||||
|
||||
atmp%fida='COO'
|
||||
if (Debug) then
|
||||
write(0,*) me, 'SPLUBLD: Calling csdp'
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
|
||||
call psb_csdp(a,atmp,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_csdp'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
nza = atmp%infoa(psb_nnz_)
|
||||
if (Debug) then
|
||||
write(0,*) me, 'SPLUBLD: Done csdp',info,nza,atmp%m,atmp%k
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
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_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 asmatbld',info,nzb,blck%fida
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
if (nzb > 0 ) then
|
||||
if (size(atmp%aspk)<nza+nzb) then
|
||||
call psb_sp_reall(atmp,nza+nzb,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
|
||||
endif
|
||||
if (Debug) then
|
||||
write(0,*) me, 'SPLUBLD: Done realloc',info,nza+nzb,atmp%fida
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
|
||||
do j=1,nzb
|
||||
atmp%aspk(nza+j) = blck%aspk(j)
|
||||
atmp%ia1(nza+j) = blck%ia1(j)
|
||||
atmp%ia2(nza+j) = blck%ia2(j)
|
||||
end do
|
||||
atmp%infoa(psb_nnz_) = nza+nzb
|
||||
atmp%m = atmp%m + blck%m
|
||||
atmp%k = max(a%k,blck%k)
|
||||
else
|
||||
atmp%infoa(psb_nnz_) = nza
|
||||
atmp%m = a%m
|
||||
atmp%k = a%k
|
||||
endif
|
||||
|
||||
i=0
|
||||
do j=1, atmp%infoa(psb_nnz_)
|
||||
if (atmp%ia2(j) <= atmp%m) then
|
||||
i = i + 1
|
||||
atmp%aspk(i) = atmp%aspk(j)
|
||||
atmp%ia1(i) = atmp%ia1(j)
|
||||
atmp%ia2(i) = atmp%ia2(j)
|
||||
endif
|
||||
enddo
|
||||
atmp%infoa(psb_nnz_) = i
|
||||
|
||||
|
||||
call psb_ipcoo2csr(atmp,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_ipcoo2csr'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
nzt = psb_sp_get_nnzeros(atmp)
|
||||
if (Debug) then
|
||||
write(0,*) me,'Calling psb_slu_factor ',nzt,atmp%m,&
|
||||
& atmp%k,p%desc_data%matrix_data(psb_n_row_)
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
|
||||
call psb_zslu_factor(atmp%m,nzt,&
|
||||
& atmp%aspk,atmp%ia1,atmp%ia2,p%iprcparm(slu_ptr_),info)
|
||||
if(info /= 0) then
|
||||
ch_err='psb_slu_fact'
|
||||
call psb_errpush(4110,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (Debug) then
|
||||
write(0,*) me, 'SPLUBLD: Done slu_Factor',info,p%iprcparm(slu_ptr_)
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
|
||||
call psb_sp_free(blck,info)
|
||||
call psb_sp_free(atmp,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_sp_free'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine psb_zslu_bld
|
||||
|
||||
@ -0,0 +1,379 @@
|
||||
/*
|
||||
* 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
|
||||
* 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.
|
||||
*
|
||||
*/
|
||||
/* This file is an interface to the SuperLU routines for sparse
|
||||
factorization. It was obtaned by modifying the
|
||||
c_fortran_dgssv.c file from the SuperLU source distribution;
|
||||
original copyright terms reproduced below.
|
||||
|
||||
PSBLAS v 2.0 */
|
||||
|
||||
|
||||
/* =====================
|
||||
|
||||
Copyright (c) 2003, The Regents of the University of California, through
|
||||
Lawrence Berkeley National Laboratory (subject to receipt of any required
|
||||
approvals from U.S. Dept. of Energy)
|
||||
|
||||
All rights reserved.
|
||||
|
||||
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) Neither the name of Lawrence Berkeley National Laboratory, U.S. Dept. of
|
||||
Energy nor the names of its contributors may be used to endorse or promote
|
||||
products derived from this software without specific prior 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 COPYRIGHT OWNER OR
|
||||
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.
|
||||
|
||||
*/
|
||||
|
||||
/*
|
||||
* -- SuperLU routine (version 3.0) --
|
||||
* Univ. of California Berkeley, Xerox Palo Alto Research Center,
|
||||
* and Lawrence Berkeley National Lab.
|
||||
* October 15, 2003
|
||||
*
|
||||
*/
|
||||
|
||||
#ifdef Have_SLU_
|
||||
#include "zsp_defs.h"
|
||||
#define HANDLE_SIZE 8
|
||||
/* kind of integer to hold a pointer. Use int.
|
||||
This might need to be changed on 64-bit systems. */
|
||||
#ifdef LargeFptr
|
||||
typedef long long fptr; /* 32-bit by default */
|
||||
#else
|
||||
typedef int fptr; /* 32-bit by default */
|
||||
#endif
|
||||
|
||||
typedef struct {
|
||||
SuperMatrix *L;
|
||||
SuperMatrix *U;
|
||||
int *perm_c;
|
||||
int *perm_r;
|
||||
} factors_t;
|
||||
|
||||
|
||||
#else
|
||||
|
||||
#include <stdio.h>
|
||||
|
||||
#endif
|
||||
|
||||
|
||||
#ifdef Add_
|
||||
#define psb_zslu_factor_ psb_zslu_factor_
|
||||
#define psb_zslu_solve_ psb_zslu_solve_
|
||||
#define psb_zslu_free_ psb_zslu_free_
|
||||
#endif
|
||||
#ifdef AddDouble_
|
||||
#define psb_zslu_factor_ psb_zslu_factor__
|
||||
#define psb_zslu_solve_ psb_zslu_solve__
|
||||
#define psb_zslu_free_ psb_zslu_free__
|
||||
#endif
|
||||
#ifdef NoChange
|
||||
#define psb_zslu_factor_ psb_zslu_factor
|
||||
#define psb_zslu_solve_ psb_zslu_solve
|
||||
#define psb_zslu_free_ psb_zslu_free
|
||||
#endif
|
||||
|
||||
|
||||
|
||||
|
||||
void
|
||||
psb_zslu_factor_(int *n, int *nnz,
|
||||
#ifdef Have_SLU_
|
||||
doublecomplex *values, int *colind, int *rowptr,
|
||||
fptr *f_factors, /* a handle containing the address
|
||||
pointing to the factored matrices */
|
||||
#else
|
||||
void *values, int *colind, int *rowptr,
|
||||
void *f_factors,
|
||||
#endif
|
||||
int *info)
|
||||
|
||||
{
|
||||
/*
|
||||
* This routine can be called from Fortran.
|
||||
* performs LU decomposition.
|
||||
*
|
||||
* f_factors (input/output) fptr*
|
||||
* On output contains the pointer pointing to
|
||||
* the structure of the factored matrices.
|
||||
*
|
||||
*/
|
||||
|
||||
#ifdef Have_SLU_
|
||||
SuperMatrix A, AC, B;
|
||||
SuperMatrix *L, *U;
|
||||
int *perm_r; /* row permutations from partial pivoting */
|
||||
int *perm_c; /* column permutation vector */
|
||||
int *etree; /* column elimination tree */
|
||||
SCformat *Lstore;
|
||||
NCformat *Ustore;
|
||||
int i, panel_size, permc_spec, relax;
|
||||
trans_t trans;
|
||||
double drop_tol = 0.0;
|
||||
mem_usage_t mem_usage;
|
||||
superlu_options_t options;
|
||||
SuperLUStat_t stat;
|
||||
factors_t *LUfactors;
|
||||
|
||||
trans = NOTRANS;
|
||||
|
||||
|
||||
/* Set the default input options. */
|
||||
set_default_options(&options);
|
||||
|
||||
/* Initialize the statistics variables. */
|
||||
StatInit(&stat);
|
||||
|
||||
/* Adjust to 0-based indexing */
|
||||
for (i = 0; i < *nnz; ++i) --colind[i];
|
||||
for (i = 0; i <= *n; ++i) --rowptr[i];
|
||||
|
||||
zCreate_CompRow_Matrix(&A, *n, *n, *nnz, values, colind, rowptr,
|
||||
SLU_NR, SLU_Z, SLU_GE);
|
||||
L = (SuperMatrix *) SUPERLU_MALLOC( sizeof(SuperMatrix) );
|
||||
U = (SuperMatrix *) SUPERLU_MALLOC( sizeof(SuperMatrix) );
|
||||
if ( !(perm_r = intMalloc(*n)) ) ABORT("Malloc fails for perm_r[].");
|
||||
if ( !(perm_c = intMalloc(*n)) ) ABORT("Malloc fails for perm_c[].");
|
||||
if ( !(etree = intMalloc(*n)) ) ABORT("Malloc fails for etree[].");
|
||||
|
||||
/*
|
||||
* Get column permutation vector perm_c[], according to permc_spec:
|
||||
* permc_spec = 0: natural ordering
|
||||
* permc_spec = 1: minimum degree on structure of A'*A
|
||||
* permc_spec = 2: minimum degree on structure of A'+A
|
||||
* permc_spec = 3: approximate minimum degree for unsymmetric matrices
|
||||
*/
|
||||
options.ColPerm=2;
|
||||
permc_spec = options.ColPerm;
|
||||
get_perm_c(permc_spec, &A, perm_c);
|
||||
|
||||
sp_preorder(&options, &A, perm_c, etree, &AC);
|
||||
|
||||
panel_size = sp_ienv(1);
|
||||
relax = sp_ienv(2);
|
||||
|
||||
zgstrf(&options, &AC, drop_tol, relax, panel_size,
|
||||
etree, NULL, 0, perm_c, perm_r, L, U, &stat, info);
|
||||
|
||||
if ( *info == 0 ) {
|
||||
Lstore = (SCformat *) L->Store;
|
||||
Ustore = (NCformat *) U->Store;
|
||||
zQuerySpace(L, U, &mem_usage);
|
||||
#if 0
|
||||
printf("No of nonzeros in factor L = %d\n", Lstore->nnz);
|
||||
printf("No of nonzeros in factor U = %d\n", Ustore->nnz);
|
||||
printf("No of nonzeros in L+U = %d\n", Lstore->nnz + Ustore->nnz);
|
||||
printf("L\\U MB %.3f\ttotal MB needed %.3f\texpansions %d\n",
|
||||
mem_usage.for_lu/1e6, mem_usage.total_needed/1e6,
|
||||
mem_usage.expansions);
|
||||
#endif
|
||||
} else {
|
||||
printf("dgstrf() error returns INFO= %d\n", *info);
|
||||
if ( *info <= *n ) { /* factorization completes */
|
||||
zQuerySpace(L, U, &mem_usage);
|
||||
printf("L\\U MB %.3f\ttotal MB needed %.3f\texpansions %d\n",
|
||||
mem_usage.for_lu/1e6, mem_usage.total_needed/1e6,
|
||||
mem_usage.expansions);
|
||||
}
|
||||
}
|
||||
|
||||
/* Restore to 1-based indexing */
|
||||
for (i = 0; i < *nnz; ++i) ++colind[i];
|
||||
for (i = 0; i <= *n; ++i) ++rowptr[i];
|
||||
|
||||
/* Save the LU factors in the factors handle */
|
||||
LUfactors = (factors_t*) SUPERLU_MALLOC(sizeof(factors_t));
|
||||
LUfactors->L = L;
|
||||
LUfactors->U = U;
|
||||
LUfactors->perm_c = perm_c;
|
||||
LUfactors->perm_r = perm_r;
|
||||
*f_factors = (fptr) LUfactors;
|
||||
|
||||
/* Free un-wanted storage */
|
||||
SUPERLU_FREE(etree);
|
||||
Destroy_SuperMatrix_Store(&A);
|
||||
Destroy_CompCol_Permuted(&AC);
|
||||
StatFree(&stat);
|
||||
#else
|
||||
fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n");
|
||||
*info=-1;
|
||||
#endif
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
psb_zslu_solve_(int *itrans, int *n, int *nrhs,
|
||||
#ifdef Have_SLU_
|
||||
doublecomplex *b, int *ldb,
|
||||
fptr *f_factors, /* a handle containing the address
|
||||
pointing to the factored matrices */
|
||||
#else
|
||||
void *b, int *ldb,
|
||||
void *f_factors,
|
||||
#endif
|
||||
int *info)
|
||||
|
||||
{
|
||||
/*
|
||||
* This routine can be called from Fortran.
|
||||
* performs triangular solve
|
||||
*
|
||||
*/
|
||||
#ifdef Have_SLU_
|
||||
SuperMatrix B;
|
||||
SuperMatrix *L, *U;
|
||||
int *perm_r; /* row permutations from partial pivoting */
|
||||
int *perm_c; /* column permutation vector */
|
||||
int *etree; /* column elimination tree */
|
||||
SCformat *Lstore;
|
||||
NCformat *Ustore;
|
||||
int i, panel_size, permc_spec, relax;
|
||||
trans_t trans;
|
||||
double drop_tol = 0.0;
|
||||
mem_usage_t mem_usage;
|
||||
superlu_options_t options;
|
||||
SuperLUStat_t stat;
|
||||
factors_t *LUfactors;
|
||||
|
||||
if (*itrans == 0) {
|
||||
trans = NOTRANS;
|
||||
} else if (*itrans ==1) {
|
||||
trans = TRANS;
|
||||
} else if (*itrans ==2) {
|
||||
trans = CONJ;
|
||||
} else {
|
||||
trans = NOTRANS;
|
||||
}
|
||||
/* Initialize the statistics variables. */
|
||||
StatInit(&stat);
|
||||
|
||||
/* Extract the LU factors in the factors handle */
|
||||
LUfactors = (factors_t*) *f_factors;
|
||||
L = LUfactors->L;
|
||||
U = LUfactors->U;
|
||||
perm_c = LUfactors->perm_c;
|
||||
perm_r = LUfactors->perm_r;
|
||||
|
||||
zCreate_Dense_Matrix(&B, *n, *nrhs, b, *ldb, SLU_DN, SLU_Z, SLU_GE);
|
||||
/* Solve the system A*X=B, overwriting B with X. */
|
||||
zgstrs (trans, L, U, perm_c, perm_r, &B, &stat, info);
|
||||
if (info != 0) {
|
||||
if (B.Stype != SLU_DN) fprintf(stderr,"zgstrs error kind 1: SLU_DN\n");
|
||||
if (B.Dtype != SLU_Z) fprintf(stderr,"zgstrs error kind 2: SLU_Z\n");
|
||||
if (B.Mtype != SLU_GE) fprintf(stderr,"zgstrs error kind 3: SLU_GE\n");
|
||||
}
|
||||
|
||||
Destroy_SuperMatrix_Store(&B);
|
||||
StatFree(&stat);
|
||||
#else
|
||||
fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n");
|
||||
*info=-1;
|
||||
#endif
|
||||
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
psb_zslu_free_(
|
||||
#ifdef Have_SLU_
|
||||
fptr *f_factors, /* a handle containing the address
|
||||
pointing to the factored matrices */
|
||||
#else
|
||||
void *f_factors,
|
||||
#endif
|
||||
int *info)
|
||||
|
||||
{
|
||||
/*
|
||||
* This routine can be called from Fortran.
|
||||
*
|
||||
* free all storage in the end
|
||||
*
|
||||
*/
|
||||
#ifdef Have_SLU_
|
||||
SuperMatrix A, AC, B;
|
||||
SuperMatrix *L, *U;
|
||||
int *perm_r; /* row permutations from partial pivoting */
|
||||
int *perm_c; /* column permutation vector */
|
||||
int *etree; /* column elimination tree */
|
||||
SCformat *Lstore;
|
||||
NCformat *Ustore;
|
||||
int i, panel_size, permc_spec, relax;
|
||||
trans_t trans;
|
||||
double drop_tol = 0.0;
|
||||
mem_usage_t mem_usage;
|
||||
superlu_options_t options;
|
||||
SuperLUStat_t stat;
|
||||
factors_t *LUfactors;
|
||||
|
||||
trans = NOTRANS;
|
||||
/* Free the LU factors in the factors handle */
|
||||
LUfactors = (factors_t*) *f_factors;
|
||||
SUPERLU_FREE (LUfactors->perm_r);
|
||||
SUPERLU_FREE (LUfactors->perm_c);
|
||||
Destroy_SuperNode_Matrix(LUfactors->L);
|
||||
Destroy_CompCol_Matrix(LUfactors->U);
|
||||
SUPERLU_FREE (LUfactors->L);
|
||||
SUPERLU_FREE (LUfactors->U);
|
||||
SUPERLU_FREE (LUfactors);
|
||||
*info = 0;
|
||||
#else
|
||||
fprintf(stderr," SLU Not Configured, fix make.inc and recompile\n");
|
||||
*info=-1;
|
||||
#endif
|
||||
}
|
||||
|
||||
|
||||
@ -0,0 +1,458 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_zsp_renum(a,desc_a,blck,p,atmp,info)
|
||||
use psb_base_mod
|
||||
use psb_prec_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
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer, intent(out) :: info
|
||||
|
||||
|
||||
character(len=20) :: name, ch_err
|
||||
integer nztota, nztotb, nztmp, nzl, nnr, ir, mglob, mtype, n_row, &
|
||||
& nrow_a,n_col, nhalo,lovr, ind, iind, pi,nr,ns,i,j,jj,k,kk
|
||||
integer ::ictxt,np,me, err_act
|
||||
integer, allocatable :: itmp(:), itmp2(:)
|
||||
complex(kind(1.d0)), allocatable :: ztmp(:)
|
||||
real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6,mpi_wtime, t7, t8
|
||||
external mpi_wtime
|
||||
|
||||
if (psb_get_errstatus().ne.0) return
|
||||
info=0
|
||||
name='apply_renum'
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
ictxt=psb_cd_get_context(desc_a)
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
!!!!!!!!!!!!!!!! CHANGE FOR NON-CSR A
|
||||
!
|
||||
! Renumbering type:
|
||||
! 1. Global column indices
|
||||
! (2. GPS band reduction disabled for the time being)
|
||||
|
||||
if (p%iprcparm(iren_)==renum_glb_) then
|
||||
atmp%m = a%m + blck%m
|
||||
atmp%k = a%k
|
||||
atmp%fida='CSR'
|
||||
atmp%descra = 'GUN'
|
||||
|
||||
! This is the renumbering coherent with global indices..
|
||||
mglob = psb_cd_get_global_rows(desc_a)
|
||||
!
|
||||
! Remember: we have switched IA1=COLS and IA2=ROWS
|
||||
! Now identify the set of distinct local column indices
|
||||
!
|
||||
|
||||
nnr = p%desc_data%matrix_data(psb_n_row_)
|
||||
allocate(p%perm(nnr),p%invperm(nnr),itmp2(nnr),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
do k=1,nnr
|
||||
itmp2(k) = p%desc_data%loc_to_glob(k)
|
||||
enddo
|
||||
!
|
||||
! We want: NEW(I) = OLD(PERM(I))
|
||||
!
|
||||
call isrx(nnr,itmp2,p%perm)
|
||||
|
||||
do k=1, nnr
|
||||
p%invperm(p%perm(k)) = k
|
||||
enddo
|
||||
t3 = mpi_wtime()
|
||||
|
||||
! Build ATMP with new numbering.
|
||||
nztmp=size(atmp%aspk)
|
||||
allocate(itmp(max(8,atmp%m+2,nztmp+2)),ztmp(atmp%m),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
j = 1
|
||||
atmp%ia2(1) = 1
|
||||
do i=1, atmp%m
|
||||
ir = p%perm(i)
|
||||
|
||||
if (ir <= a%m ) then
|
||||
|
||||
nzl = a%ia2(ir+1) - a%ia2(ir)
|
||||
if (nzl > size(ztmp)) then
|
||||
call psb_realloc(nzl,ztmp,info)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
jj = a%ia2(ir)
|
||||
k=0
|
||||
do kk=1, nzl
|
||||
if (a%ia1(jj+kk-1)<=atmp%m) then
|
||||
k = k + 1
|
||||
ztmp(k) = a%aspk(jj+kk-1)
|
||||
atmp%ia1(j+k-1) = p%invperm(a%ia1(jj+kk-1))
|
||||
endif
|
||||
enddo
|
||||
call isrx(k,atmp%ia1(j:j+k-1),itmp2)
|
||||
do kk=1,k
|
||||
atmp%aspk(j+kk-1) = ztmp(itmp2(kk))
|
||||
enddo
|
||||
|
||||
else if (ir <= atmp%m ) then
|
||||
|
||||
ir = ir - a%m
|
||||
nzl = blck%ia2(ir+1) - blck%ia2(ir)
|
||||
if (nzl > size(ztmp)) then
|
||||
call psb_realloc(nzl,ztmp,info)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
jj = blck%ia2(ir)
|
||||
k=0
|
||||
do kk=1, nzl
|
||||
if (blck%ia1(jj+kk-1)<=atmp%m) then
|
||||
k = k + 1
|
||||
ztmp(k) = blck%aspk(jj+kk-1)
|
||||
atmp%ia1(j+k-1) = p%invperm(blck%ia1(jj+kk-1))
|
||||
endif
|
||||
enddo
|
||||
call isrx(k,atmp%ia1(j:j+k-1),itmp2)
|
||||
do kk=1,k
|
||||
atmp%aspk(j+kk-1) = ztmp(itmp2(kk))
|
||||
enddo
|
||||
|
||||
else
|
||||
write(0,*) 'Row index error 1 :',i,ir
|
||||
endif
|
||||
|
||||
j = j + k
|
||||
atmp%ia2(i+1) = j
|
||||
|
||||
enddo
|
||||
|
||||
t4 = mpi_wtime()
|
||||
|
||||
|
||||
deallocate(itmp,itmp2,ztmp)
|
||||
|
||||
else if (p%iprcparm(iren_)==renum_gps_) then
|
||||
|
||||
atmp%m = a%m + blck%m
|
||||
atmp%k = a%k
|
||||
atmp%fida='CSR'
|
||||
atmp%descra = 'GUN'
|
||||
do i=1, a%m
|
||||
atmp%ia2(i) = a%ia2(i)
|
||||
do j= a%ia2(i), a%ia2(i+1)-1
|
||||
atmp%ia1(j) = a%ia1(j)
|
||||
enddo
|
||||
enddo
|
||||
atmp%ia2(a%m+1) = a%ia2(a%m+1)
|
||||
nztota = atmp%ia2(a%m+1) -1
|
||||
if (blck%m>0) then
|
||||
do i=1, blck%m
|
||||
atmp%ia2(a%m+i) = nztota+blck%ia2(i)
|
||||
do j= blck%ia2(i), blck%ia2(i+1)-1
|
||||
atmp%ia1(nztota+j) = blck%ia1(j)
|
||||
enddo
|
||||
enddo
|
||||
atmp%ia2(atmp%m+1) = nztota+blck%ia2(blck%m+1)
|
||||
endif
|
||||
nztmp = atmp%ia2(atmp%m+1) - 1
|
||||
|
||||
|
||||
! This is a renumbering with Gibbs-Poole-Stockmeyer
|
||||
! band reduction. Switched off for now. To be fixed,
|
||||
! gps_reduction should get p%perm.
|
||||
|
||||
! write(0,*) me,' Renumbering: realloc perms',atmp%m
|
||||
call psb_realloc(atmp%m,p%perm,info)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_realloc(atmp%m,p%invperm,info)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
allocate(itmp(max(8,atmp%m+2,nztmp+2)),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
itmp(1:8) = 0
|
||||
! write(0,*) me,' Renumbering: Calling Metis'
|
||||
|
||||
! write(0,*) size(p%av(u_pr_)%pl),size(p%av(l_pr_)%pr)
|
||||
call gps_reduction(atmp%m,atmp%ia2,atmp%ia1,p%perm,p%invperm,info)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='gps_reduction'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
! write(0,*) me,' Renumbering: Done GPS'
|
||||
! call psb_barrier(ictxt)
|
||||
do i=1, atmp%m
|
||||
if (p%perm(i) /= i) then
|
||||
write(0,*) me,' permutation is not identity '
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
|
||||
|
||||
|
||||
do k=1, nnr
|
||||
p%invperm(p%perm(k)) = k
|
||||
enddo
|
||||
t3 = mpi_wtime()
|
||||
|
||||
! Build ATMP with new numbering.
|
||||
|
||||
allocate(itmp2(max(8,atmp%m+2,nztmp+2)),ztmp(atmp%m),stat=info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='Allocate')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
j = 1
|
||||
atmp%ia2(1) = 1
|
||||
do i=1, atmp%m
|
||||
ir = p%perm(i)
|
||||
|
||||
if (ir <= a%m ) then
|
||||
|
||||
nzl = a%ia2(ir+1) - a%ia2(ir)
|
||||
if (nzl > size(ztmp)) then
|
||||
call psb_realloc(nzl,ztmp,info)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
jj = a%ia2(ir)
|
||||
k=0
|
||||
do kk=1, nzl
|
||||
if (a%ia1(jj+kk-1)<=atmp%m) then
|
||||
k = k + 1
|
||||
ztmp(k) = a%aspk(jj+kk-1)
|
||||
atmp%ia1(j+k-1) = p%invperm(a%ia1(jj+kk-1))
|
||||
endif
|
||||
enddo
|
||||
call isrx(k,atmp%ia1(j:j+k-1),itmp2)
|
||||
do kk=1,k
|
||||
atmp%aspk(j+kk-1) = ztmp(itmp2(kk))
|
||||
enddo
|
||||
|
||||
else if (ir <= atmp%m ) then
|
||||
|
||||
ir = ir - a%m
|
||||
nzl = blck%ia2(ir+1) - blck%ia2(ir)
|
||||
if (nzl > size(ztmp)) then
|
||||
call psb_realloc(nzl,ztmp,info)
|
||||
if(info/=0) then
|
||||
info=4010
|
||||
ch_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
jj = blck%ia2(ir)
|
||||
k=0
|
||||
do kk=1, nzl
|
||||
if (blck%ia1(jj+kk-1)<=atmp%m) then
|
||||
k = k + 1
|
||||
ztmp(k) = blck%aspk(jj+kk-1)
|
||||
atmp%ia1(j+k-1) = p%invperm(blck%ia1(jj+kk-1))
|
||||
endif
|
||||
enddo
|
||||
call isrx(k,atmp%ia1(j:j+k-1),itmp2)
|
||||
do kk=1,k
|
||||
atmp%aspk(j+kk-1) = ztmp(itmp2(kk))
|
||||
enddo
|
||||
|
||||
else
|
||||
write(0,*) 'Row index error 1 :',i,ir
|
||||
endif
|
||||
|
||||
j = j + k
|
||||
atmp%ia2(i+1) = j
|
||||
|
||||
enddo
|
||||
|
||||
t4 = mpi_wtime()
|
||||
|
||||
|
||||
|
||||
deallocate(itmp,itmp2,ztmp)
|
||||
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
contains
|
||||
|
||||
|
||||
subroutine gps_reduction(m,ia,ja,perm,iperm,info)
|
||||
integer i,j,dgConn,Npnt,m
|
||||
integer n,idpth,ideg,ibw2,ipf2
|
||||
integer,dimension(:) :: perm,iperm,ia,ja
|
||||
integer, intent(out) :: info
|
||||
|
||||
integer,dimension(:,:),allocatable::NDstk
|
||||
integer,dimension(:),allocatable::iOld,renum,ndeg,lvl,lvls1,lvls2,ccstor
|
||||
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=0
|
||||
name='gps_reduction'
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
!--- Calcolo il massimo grado di connettivita'.
|
||||
npnt = m
|
||||
write(6,*) ' GPS su ',npnt
|
||||
dgConn=0
|
||||
do i=1,m
|
||||
dgconn = max(dgconn,(ia(i+1)-ia(i)))
|
||||
enddo
|
||||
!--- Il max valore di connettivita' e "dgConn"
|
||||
|
||||
!--- Valori della common
|
||||
n=Npnt !--- Numero di righe
|
||||
iDeg=dgConn !--- Massima connettivita'
|
||||
! iDpth= !--- Numero di livelli non serve settarlo
|
||||
|
||||
allocate(NDstk(Npnt,dgConn),stat=info)
|
||||
if (info/=0) then
|
||||
info=4000
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
else
|
||||
write(0,*) 'gps_reduction first alloc OK'
|
||||
endif
|
||||
allocate(iOld(Npnt),renum(Npnt+1),ndeg(Npnt),lvl(Npnt),lvls1(Npnt),&
|
||||
&lvls2(Npnt),ccstor(Npnt),stat=info)
|
||||
if (info/=0) then
|
||||
info=4000
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
else
|
||||
write(0,*) 'gps_reduction 2nd alloc OK'
|
||||
endif
|
||||
|
||||
!--- Prepariamo il grafo della matrice
|
||||
Ndstk(:,:)=0
|
||||
do i=1,Npnt
|
||||
k=0
|
||||
do j = ia(i),ia(i+1) - 1
|
||||
if ((1<=ja(j)).and.( ja( j ) /= i ).and.(ja(j)<=npnt)) then
|
||||
k = k+1
|
||||
Ndstk(i,k)=ja(j)
|
||||
endif
|
||||
enddo
|
||||
ndeg(i)=k
|
||||
enddo
|
||||
|
||||
!--- Numerazione.
|
||||
do i=1,Npnt
|
||||
iOld(i)=i
|
||||
enddo
|
||||
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'
|
||||
!--- Permutazione
|
||||
perm(1:Npnt)=renum(1:Npnt)
|
||||
!--- Inversa permutazione
|
||||
do i=1,Npnt
|
||||
iperm(perm(i))=i
|
||||
enddo
|
||||
!--- Puliamo tutto.
|
||||
deallocate(NDstk,iOld,renum,ndeg,lvl,lvls1,lvls2,ccstor)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine gps_reduction
|
||||
|
||||
end subroutine psb_zsp_renum
|
||||
@ -0,0 +1,211 @@
|
||||
!!$
|
||||
!!$
|
||||
!!$ 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.
|
||||
!!$
|
||||
!!$
|
||||
subroutine psb_zumf_bld(a,desc_a,p,info)
|
||||
use psb_base_mod
|
||||
use psb_prec_type
|
||||
implicit none
|
||||
|
||||
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
|
||||
|
||||
|
||||
type(psb_zspmat_type) :: blck, atmp
|
||||
character(len=5) :: fmt
|
||||
character :: upd='F'
|
||||
integer :: i,j,nza,nzb,nzt,ictxt, me,np,err_act
|
||||
integer :: i_err(5)
|
||||
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)
|
||||
|
||||
ictxt = desc_A%matrix_data(psb_ctxt_)
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
fmt = 'COO'
|
||||
call psb_nullify_sp(blck)
|
||||
call psb_nullify_sp(atmp)
|
||||
|
||||
atmp%fida='COO'
|
||||
if (Debug) then
|
||||
write(0,*) me, 'UMFBLD: Calling csdp'
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
|
||||
call psb_zcsdp(a,atmp,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_zcsdp'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
nza = psb_sp_get_nnzeros(atmp)
|
||||
nzb = psb_sp_get_nnzeros(a)
|
||||
if (Debug) then
|
||||
write(0,*) me, 'UMFBLD: Done csdp',info,nza,atmp%m,atmp%k,nzb
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
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_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 asmatbld',info,nzb,blck%fida
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
if (nzb > 0 ) then
|
||||
if (size(atmp%aspk)<nza+nzb) then
|
||||
call psb_sp_reall(atmp,nza+nzb,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
|
||||
endif
|
||||
if (Debug) then
|
||||
write(0,*) me, 'UMFBLD: Done realloc',info,nza+nzb,atmp%fida
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
|
||||
do j=1,nzb
|
||||
atmp%aspk(nza+j) = blck%aspk(j)
|
||||
atmp%ia1(nza+j) = blck%ia1(j)
|
||||
atmp%ia2(nza+j) = blck%ia2(j)
|
||||
end do
|
||||
atmp%infoa(psb_nnz_) = nza+nzb
|
||||
atmp%m = atmp%m + blck%m
|
||||
atmp%k = max(a%k,blck%k)
|
||||
else
|
||||
atmp%infoa(psb_nnz_) = nza
|
||||
atmp%m = a%m
|
||||
atmp%k = a%k
|
||||
endif
|
||||
|
||||
i=0
|
||||
do j=1, atmp%infoa(psb_nnz_)
|
||||
if (atmp%ia2(j) <= atmp%m) then
|
||||
i = i + 1
|
||||
atmp%aspk(i) = atmp%aspk(j)
|
||||
atmp%ia1(i) = atmp%ia1(j)
|
||||
atmp%ia2(i) = atmp%ia2(j)
|
||||
endif
|
||||
enddo
|
||||
atmp%infoa(psb_nnz_) = i
|
||||
|
||||
|
||||
call psb_ipcoo2csc(atmp,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_ipcoo2csc'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
nzt = psb_sp_get_nnzeros(atmp)
|
||||
if (Debug) then
|
||||
write(0,*) me,'Calling psb_umf_factor ',nzt,atmp%m,&
|
||||
& atmp%k,p%desc_data%matrix_data(psb_n_row_)
|
||||
open(80+me)
|
||||
call psb_csprt(80+me,atmp)
|
||||
close(80+me)
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
|
||||
call psb_zumf_factor(atmp%m,nzt,&
|
||||
& atmp%aspk,atmp%ia1,atmp%ia2,&
|
||||
& p%iprcparm(umf_symptr_),p%iprcparm(umf_numptr_),info)
|
||||
if (info /= 0) then
|
||||
i_err(1) = info
|
||||
info=4110
|
||||
ch_err='psb_umf_fact'
|
||||
call psb_errpush(info,name,a_err=ch_err,i_err=i_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (Debug) then
|
||||
write(0,*) me, 'UMFBLD: Done umf_Factor',info,p%iprcparm(umf_numptr_)
|
||||
call psb_barrier(ictxt)
|
||||
endif
|
||||
call psb_sp_free(blck,info)
|
||||
call psb_sp_free(atmp,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_sp_free'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine psb_zumf_bld
|
||||
|
||||
|
||||
|
||||
@ -0,0 +1,232 @@
|
||||
/*
|
||||
* 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
|
||||
* 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.
|
||||
*
|
||||
*/
|
||||
/* 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 */
|
||||
|
||||
|
||||
/* =====================
|
||||
UMFPACK Version 4.4 (Jan. 28, 2005), Copyright (c) 2005 by Timothy A.
|
||||
Davis. All Rights Reserved.
|
||||
|
||||
UMFPACK License:
|
||||
|
||||
Your use or distribution of UMFPACK or any modified version of
|
||||
UMFPACK implies that you agree to this License.
|
||||
|
||||
THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY
|
||||
EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK.
|
||||
|
||||
Permission is hereby granted to use or copy this program, provided
|
||||
that the Copyright, this License, and the Availability of the original
|
||||
version is retained on all copies. User documentation of any code that
|
||||
uses UMFPACK or any modified version of UMFPACK code must cite the
|
||||
Copyright, this License, the Availability note, and "Used by permission."
|
||||
Permission to modify the code and to distribute modified code is granted,
|
||||
provided the Copyright, this License, and the Availability note are
|
||||
retained, and a notice that the code was modified is included. This
|
||||
software was developed with support from the National Science Foundation,
|
||||
and is provided to you free of charge.
|
||||
|
||||
Availability:
|
||||
|
||||
http://www.cise.ufl.edu/research/sparse/umfpack
|
||||
|
||||
*/
|
||||
|
||||
|
||||
|
||||
#ifdef Add_
|
||||
#define psb_zumf_factor_ psb_zumf_factor_
|
||||
#define psb_zumf_solve_ psb_zumf_solve_
|
||||
#define psb_zumf_free_ psb_zumf_free_
|
||||
#endif
|
||||
#ifdef AddDouble_
|
||||
#define psb_zumf_factor_ psb_zumf_factor__
|
||||
#define psb_zumf_solve_ psb_zumf_solve__
|
||||
#define psb_zumf_free_ psb_zumf_free__
|
||||
#endif
|
||||
#ifdef NoChange
|
||||
#define psb_zumf_factor_ psb_zumf_factor
|
||||
#define psb_zumf_solve_ psb_zumf_solve
|
||||
#define psb_zumf_free_ psb_zumf_free
|
||||
#endif
|
||||
|
||||
|
||||
#include <stdio.h>
|
||||
#ifdef Have_UMF_
|
||||
#include "umfpack.h"
|
||||
#endif
|
||||
|
||||
#ifdef LargeFptr
|
||||
typedef long long fptr; /* 64-bit*/
|
||||
#else
|
||||
typedef int fptr; /* 32-bit by default */
|
||||
#endif
|
||||
|
||||
void
|
||||
psb_zumf_factor_(int *n, int *nnz,
|
||||
double *values, int *rowind, int *colptr,
|
||||
#ifdef Have_UMF_
|
||||
fptr *symptr,
|
||||
fptr *numptr,
|
||||
|
||||
#else
|
||||
void *symptr,
|
||||
void *numptr,
|
||||
#endif
|
||||
int *info)
|
||||
|
||||
{
|
||||
|
||||
#ifdef Have_UMF_
|
||||
double Info [UMFPACK_INFO], Control [UMFPACK_CONTROL];
|
||||
void *Symbolic, *Numeric ;
|
||||
int i;
|
||||
|
||||
|
||||
umfpack_zi_defaults(Control);
|
||||
|
||||
for (i = 0; i <= *n; ++i) --colptr[i];
|
||||
for (i = 0; i < *nnz; ++i) --rowind[i];
|
||||
*info = umfpack_zi_symbolic (*n, *n, colptr, rowind, values, NULL, &Symbolic,
|
||||
Control, Info);
|
||||
|
||||
|
||||
if ( *info == UMFPACK_OK ) {
|
||||
*info = 0;
|
||||
} else {
|
||||
printf("umfpack_zi_symbolic() error returns INFO= %d\n", *info);
|
||||
*info = -11;
|
||||
*numptr = (fptr) NULL;
|
||||
return;
|
||||
}
|
||||
|
||||
*symptr = (fptr) Symbolic;
|
||||
|
||||
*info = umfpack_zi_numeric (colptr, rowind, values, NULL, Symbolic, &Numeric,
|
||||
Control, Info) ;
|
||||
|
||||
|
||||
if ( *info == UMFPACK_OK ) {
|
||||
*info = 0;
|
||||
*numptr = (fptr) Numeric;
|
||||
} else {
|
||||
printf("umfpack_zi_numeric() error returns INFO= %d\n", *info);
|
||||
*info = -12;
|
||||
*numptr = (fptr) NULL;
|
||||
}
|
||||
|
||||
for (i = 0; i <= *n; ++i) ++colptr[i];
|
||||
for (i = 0; i < *nnz; ++i) ++rowind[i];
|
||||
#else
|
||||
fprintf(stderr," UMF Not Configured, fix make.inc and recompile\n");
|
||||
*info=-1;
|
||||
#endif
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
psb_zumf_solve_(int *itrans, int *n,
|
||||
double *x, double *b, int *ldb,
|
||||
#ifdef Have_UMF_
|
||||
fptr *numptr,
|
||||
|
||||
#else
|
||||
void *numptr,
|
||||
#endif
|
||||
int *info)
|
||||
|
||||
{
|
||||
#ifdef Have_UMF_
|
||||
double Info [UMFPACK_INFO], Control [UMFPACK_CONTROL];
|
||||
void *Symbolic, *Numeric ;
|
||||
int i,trans;
|
||||
|
||||
|
||||
umfpack_di_defaults(Control);
|
||||
Control[UMFPACK_IRSTEP]=0;
|
||||
|
||||
|
||||
if (*itrans == 0) {
|
||||
trans = UMFPACK_A;
|
||||
} else if (*itrans ==1) {
|
||||
trans = UMFPACK_At;
|
||||
} else {
|
||||
trans = UMFPACK_A;
|
||||
}
|
||||
|
||||
*info = umfpack_zi_solve(trans,NULL,NULL,NULL,NULL,
|
||||
x,NULL,b,NULL,(void *) *numptr,Control,Info);
|
||||
|
||||
#else
|
||||
fprintf(stderr," UMF Not Configured, fix make.inc and recompile\n");
|
||||
*info=-1;
|
||||
#endif
|
||||
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
psb_zumf_free_(
|
||||
#ifdef Have_UMF_
|
||||
fptr *symptr,
|
||||
fptr *numptr,
|
||||
|
||||
#else
|
||||
void *symptr,
|
||||
void *numptr,
|
||||
#endif
|
||||
int *info)
|
||||
|
||||
{
|
||||
#ifdef Have_UMF_
|
||||
void *Symbolic, *Numeric ;
|
||||
Symbolic = (void *) *symptr;
|
||||
Numeric = (void *) *numptr;
|
||||
|
||||
umfpack_zi_free_numeric(&Numeric);
|
||||
umfpack_zi_free_symbolic(&Symbolic);
|
||||
*info=0;
|
||||
#else
|
||||
fprintf(stderr," UMF Not Configured, fix make.inc and recompile\n");
|
||||
*info=-1;
|
||||
#endif
|
||||
}
|
||||
|
||||
|
||||
Loading…
Reference in New Issue