fdurastante
/
amg4psblas
mirror of https://github.com/sfilippone/amg4psblas.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Initial import for new separate version of mld2p4.

Browse Source
stopcriterion
Salvatore Filippone 18 years ago
parent a63ad6e568
commit db5c62e5c9
50 changed files with 15015 additions and 0 deletions
Show Stats Download Patch File Download Diff File

33
LICENSE.MD2P4
Unescape Escape View File

@ -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.

86
Make.inc
Unescape Escape View File

@ -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 $<

85
Make.inc.g95
Unescape Escape View File

@ -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 $<

86
Make.inc.gcc42
Unescape Escape View File

@ -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 $<

88
Make.inc.ifc9
Unescape Escape View File

@ -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 $<

86
Make.inc.rs6k
Unescape Escape View File

@ -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 $<

46
Makefile
Unescape Escape View File

@ -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)

130
README
Unescape Escape View File

@ -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

245
psb_dasmatbld.f90
Unescape Escape View File

@ -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

281
psb_dbaseprc_aply.f90
Unescape Escape View File

@ -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

267
psb_dbaseprc_bld.f90
Unescape Escape View File

@ -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

270
psb_dbjac_aply.f90
Unescape Escape View File

@ -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

1043
psb_dbldaggrmat.f90
View File

File diff suppressed because it is too large Load Diff

168
psb_ddiagsc_bld.f90
Unescape Escape View File

@ -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

292
psb_dgenaggrmap.f90
Unescape Escape View File

@ -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

366
psb_dilu_bld.f90
Unescape Escape View File

@ -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

475
psb_dilu_fct.f90
Unescape Escape View File

@ -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

782
psb_dmlprc_aply.f90
Unescape Escape View File

@ -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

198
psb_dmlprc_bld.f90
Unescape Escape View File

@ -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

250
psb_dprc_aply.f90
Unescape Escape View File

@ -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

170
psb_dprecbld.f90
Unescape Escape View File

@ -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

72
psb_dprecfree.f90
Unescape Escape View File

@ -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

187
psb_dprecset.f90
Unescape Escape View File

@ -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

206
psb_dslu_bld.f90
Unescape Escape View File

@ -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

459
psb_dsp_renum.f90
Unescape Escape View File

@ -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

212
psb_dumf_bld.f90
Unescape Escape View File

@ -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

460
psb_prec_mod.f90
Unescape Escape View File

@ -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

847
psb_prec_type.f90
Unescape Escape View File

@ -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

373
psb_slu_impl.c
Unescape Escape View File

@ -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
}

233
psb_umf_impl.c
Unescape Escape View File

@ -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
}

236
psb_zasmatbld.f90
Unescape Escape View File

@ -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

280
psb_zbaseprc_aply.f90
Unescape Escape View File

@ -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

262
psb_zbaseprc_bld.f90
Unescape Escape View File

@ -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

270
psb_zbjac_aply.f90
Unescape Escape View File

@ -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

1041
psb_zbldaggrmat.f90
View File

File diff suppressed because it is too large Load Diff

164
psb_zdiagsc_bld.f90
Unescape Escape View File

@ -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

292
psb_zgenaggrmap.f90
Unescape Escape View File

@ -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

364
psb_zilu_bld.f90
Unescape Escape View File

@ -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

472
psb_zilu_fct.f90
Unescape Escape View File

@ -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

779
psb_zmlprc_aply.f90
Unescape Escape View File

@ -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

198
psb_zmlprc_bld.f90
Unescape Escape View File

@ -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

247
psb_zprc_aply.f90
Unescape Escape View File

@ -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

169
psb_zprecbld.f90
Unescape Escape View File

@ -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

74
psb_zprecfree.f90
Unescape Escape View File

@ -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

187
psb_zprecset.f90
Unescape Escape View File

@ -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

204
psb_zslu_bld.f90
Unescape Escape View File

@ -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

379
psb_zslu_impl.c
Unescape Escape View File

@ -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
}

458
psb_zsp_renum.f90
Unescape Escape View File

@ -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

211
psb_zumf_bld.f90
Unescape Escape View File

@ -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

232
psb_zumf_impl.c
Unescape Escape View File

@ -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
}
Write Preview
Loading…
Cancel
Save