fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-06 22:55:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

Started playing around with type extensions and typebound

Browse Source 
procedures.
Merged performance fixes from trunk.
This commit is contained in:
Salvatore Filippone
2008-09-19 16:06:44 +00:00
parent 32e6a17188
commit 00c1468c6c
285 changed files with 8931 additions and 7145 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Changelog
+27
View File
@@ -1,6 +1,33 @@
Changelog. A lot less detailed than usual, at least for past
history.
2008/09/18: Defined psb_sizeof to be integer(8). Added support
into psb_sum, psb_amx and other reductions for long int
scalars.
2008/09/16: Implemented new scheme for index conversion.
Changed cdall with an option to suppress global checks.
2008/09/02: Improved psi_fnd_owner performace.
2008/09/01: Better timings in the pargen test cases.
2008/08/28: Changed CDALL in case of VL to handle overlapped indices.
2008/07/28: New sorting/reordering modules.
2008/07/24: Addded HTML version of user's guide.
2008/07/22: Fixed I/O for Harwell-Boeing and Matrix Market examples
2008/05/27: Merged single precision branch.
2008/04/28: Fixed trimming space in sparse matrix conversion.
Fixed performance issue in cdins.
2008/03/25: Fix performance bug in psi_idx_ins_cnv. Changed names of
some internal components of preconditioner data structure.
2008/03/27: Merged the experimental branch for implementing the AVL tree
data structure in Fortran instead of relying on C and passing
functions around to perform comparisons. There seems to be
LICENSE
+1 -1
View File
@@ -1,4 +1,4 @@
Parallel Sparse BLAS v2.2
Parallel Sparse BLAS v2.3
(C) Copyright 2006/2007/2008
Salvatore Filippone University of Rome Tor Vergata
Alfredo Buttari University of Rome Tor Vergata
Make.inc.in
+3 -2
View File
@@ -48,8 +48,9 @@ FFLAGS=@FFLAGS@
INSTALL=@INSTALL@
INSTALL_DATA=@INSTALL_DATA@
INSTALL_DIR=@INSTALL_DIR@
INSTALL_LIBDIR=$(INSTALL_DIR)/lib
INSTALL_INCLUDEDIR=$(INSTALL_DIR)/include
INSTALL_LIBDIR=@INSTALL_LIBDIR@
INSTALL_INCLUDEDIR=@INSTALL_INCLUDEDIR@
INSTALL_DOCSDIR=@INSTALL_DOCSDIR@
LIBDIR=@LIBDIR@
BASELIBNAME=@BASELIBNAME@
Make/Make.inc.g95
-99
View File
@@ -1,99 +0,0 @@
.mod=.mod
.fh=.fh
.SUFFIXES:
.SUFFIXES: .f90 .F90 $(.mod) .F .f .c .o
####################### 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
#
# Which flag does your compiler use for module inclusion?
# Most compilers use -I but Sun uses -M
# FIFLAG is for INCLUDE
FMFLAG=-I
FIFLAG=-I
####################### Section 2 #######################
# Define your linker and linker flags here #
# Does your MPI provide mpi.mod or mpif.h? #
# MPI_FINC=-DMPI_H or MPI_FINC=-DMPI_MOD #
# If necessary add MPIINCDIR #
##########################################################
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
MPI_FINC=-DMPI_MOD
#$(FIFLAG)/opt/SUNWhpc/include
####################### Section 3 #######################
# Specify paths to libraries #
##########################################################
BLAS=-lblasg95 -L$(HOME)/LIB
BLACS=-lmpiblacsg95 -L$(HOME)/LIB
####################### Section 4 #######################
# Other useful tools&defines #
##########################################################
#
# The examples can make use of METIS from U. Minnesota.
# http://www.cs.umn.edu:~karypis
# but it's optional
#
#METIS_LIB = -L$(HOME)/NUMERICAL/metis-4.0 -lmetis
PSBLDLIBS=$(BLACS) $(BLAS) $(METIS_LIB)
# Add -DPtr64Bits if needed
PSBCDEFINES=-DLowerUnderscore
#
PSBFDEFINES=-DHAVE_KSENDID $(MPI_FINC) -DHAVE_MOVE_ALLOC
# -DHAVE_METIS
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
CDEFINES=$(PSBCDEFINES)
FDEFINES=$(PSBFDEFINES)
$(.mod).o:
.c.o:
$(CC) $(CCOPT) $(CINCLUDES) $(CDEFINES) -c $<
.f.o:
$(FC) $(FCOPT) $(FINCLUDES) -c $<
.f$(.mod):
$(FC) $(FCOPT) $(FINCLUDES) -c $<
.f90$(.mod):
$(F90) $(F90COPT) $(FINCLUDES) -c $<
.f90.o:
$(F90) $(F90COPT) $(FINCLUDES) -c $<
.F.o:
$(FC) $(FCOPT) $(FINCLUDES) $(FDEFINES) -c $<
.F90.o:
$(F90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $<
.F90$(.mod):
$(F90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $<
Make/Make.inc.gnu42
-103
View File
@@ -1,103 +0,0 @@
.mod=.mod
.fh=.fh
.SUFFIXES:
.SUFFIXES: .f90 .F90 $(.mod) .F .f .c .o
####################### Section 1 #######################
# Define your compilers and compiler flags here #
##########################################################
GNU42BIN=/usr/local/gcc42/bin
F90=$(GNU42BIN)/gfortran
FC=$(GNU42BIN)/gfortran
F77=$(FC)
CC=$(GNU42BIN)/gcc
F90COPT=-O3 -march=native
FCOPT=-O3 -march=native
CCOPT=-O3 -march=native
#
# Which flag does your compiler use for module inclusion?
# Most compilers use -I but Sun uses -M
# FIFLAG is for INCLUDE
FMFLAG=-I
FIFLAG=-I
####################### Section 2 #######################
# Define your linker and linker flags here #
# Does your MPI provide mpi.mod or mpif.h? #
# MPI_FINC=-DMPI_H or MPI_FINC=-DMPI_MOD #
# If necessary add MPIINCDIR #
##########################################################
MPIDIR=/usr/local/mpich-gcc42
MPIBIN=$(MPIDIR)/bin
F90LINK=$(MPIBIN)/mpif90
FLINK=$(MPIBIN)/mpif77
MPF90=$(MPIBIN)/mpif90
MPF77=$(MPIBIN)/mpif77
MPCC=$(MPIBIN)/mpicc
MPI_FINC=-DMPI_MOD
#$(FIFLAG)/opt/SUNWhpc/include
####################### Section 3 #######################
# Specify paths to libraries #
##########################################################
BLAS=-lblas-gcc42 -L$(HOME)/LIB
BLACS=-lmpiblacs-gcc42 -L$(HOME)/LIB
####################### Section 4 #######################
# Other useful tools&defines #
##########################################################
#
# The examples can make use of METIS from U. Minnesota.
# http://www.cs.umn.edu:~karypis
# but it's optional
#
#METIS_LIB = -L$(HOME)/NUMERICAL/metis-4.0 -lmetis
PSBLDLIBS=$(BLACS) $(BLAS) $(METIS_LIB)
# Add -DPtr64Bits if needed
PSBCDEFINES=-DLowerUnderscore
#
PSBFDEFINES=-DHAVE_KSENDID $(MPI_FINC) -DHAVE_MOVE_ALLOC
# -DHAVE_METIS
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
CDEFINES=$(PSBCDEFINES)
FDEFINES=$(PSBFDEFINES)
$(.mod).o:
.c.o:
$(CC) $(CCOPT) $(CINCLUDES) $(CDEFINES) -c $<
.f.o:
$(FC) $(FCOPT) $(FINCLUDES) -c $<
.f$(.mod):
$(FC) $(FCOPT) $(FINCLUDES) -c $<
.f90$(.mod):
$(F90) $(F90COPT) $(FINCLUDES) -c $<
.f90.o:
$(F90) $(F90COPT) $(FINCLUDES) -c $<
.F.o:
$(FC) $(FCOPT) $(FINCLUDES) $(FDEFINES) -c $<
.F90.o:
$(F90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $<
.F90$(.mod):
$(F90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $<
Make/Make.inc.gnu42-serialmpi
-102
View File
@@ -1,102 +0,0 @@
.mod=.mod
.fh=.fh
.SUFFIXES:
.SUFFIXES: .f90 .F90 $(.mod) .F .f .c .o
####################### 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
FCOPT=-O3
CCOPT=-O3
#
# Which flag does your compiler use for module inclusion?
# Most compilers use -I but Sun uses -M
# FIFLAG is for INCLUDE
FMFLAG=-I
FIFLAG=-I
####################### Section 2 #######################
# Define your linker and linker flags here #
# Does your MPI provide mpi.mod or mpif.h? #
# MPI_FINC=-DMPI_H or MPI_FINC=-DMPI_MOD #
# If necessary add MPIINCDIR #
##########################################################
F90LINK=$(FC)
FLINK=$(FC)
MPF90=$(FC)
MPF77=$(FC)
MPCC=$(CC)
MPI_FINC=-DMPI_MOD
#$(FIFLAG)/opt/SUNWhpc/include
####################### Section 3 #######################
# Specify paths to libraries #
##########################################################
BLAS=-lblas-gcc42 -L$(HOME)/LIB
# No BLACS in serialMPI. But we need the fakempi.o
#BLACS=-lmpiblacs-gcc42 -L$(HOME)/LIB
EXTRA_COBJS=fakempi.o
####################### Section 4 #######################
# Other useful tools&defines #
##########################################################
#
# The examples can make use of METIS from U. Minnesota.
# http://www.cs.umn.edu:~karypis
# but it's optional
#
#METIS_LIB = -L$(HOME)/NUMERICAL/metis-4.0 -lmetis
PSBLDLIBS=$(BLACS) $(BLAS) $(METIS_LIB)
# Add -DPtr64Bits if needed
PSBCDEFINES=-DLowerUnderscore
#
PSBFDEFINES=-DHAVE_MOVE_ALLOC -DSERIAL_MPI $(MPI_FINC)
# -DHAVE_METIS
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
CDEFINES=$(PSBCDEFINES)
FDEFINES=$(PSBFDEFINES)
$(.mod).o:
.c.o:
$(CC) $(CCOPT) $(CINCLUDES) $(CDEFINES) -c $<
.f.o:
$(FC) $(FCOPT) $(FINCLUDES) -c $<
.f$(.mod):
$(FC) $(FCOPT) $(FINCLUDES) -c $<
.f90$(.mod):
$(F90) $(F90COPT) $(FINCLUDES) -c $<
.f90.o:
$(F90) $(F90COPT) $(FINCLUDES) -c $<
.F.o:
$(FC) $(FCOPT) $(FINCLUDES) $(FDEFINES) -c $<
.F90.o:
$(F90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $<
.F90$(.mod):
$(F90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $<
Make/Make.inc.gnu43
-103
View File
@@ -1,103 +0,0 @@
.mod=.mod
.fh=.fh
.SUFFIXES:
.SUFFIXES: .f90 .F90 $(.mod) .F .f .c .o
####################### Section 1 #######################
# Define your compilers and compiler flags here #
##########################################################
GNU43BIN=/usr/local/gcc43/bin
F90=$(GNU43BIN)/gfortran
FC=$(GNU43BIN)/gfortran
F77=$(FC)
CC=$(GNU43BIN)/gcc
F90COPT=-O3 -march=native
FCOPT=-O3 -march=native
CCOPT=-O3 -march=native
#
# Which flag does your compiler use for module inclusion?
# Most compilers use -I but Sun uses -M
# FIFLAG is for INCLUDE
FMFLAG=-I
FIFLAG=-I
####################### Section 2 #######################
# Define your linker and linker flags here #
# Does your MPI provide mpi.mod or mpif.h? #
# MPI_FINC=-DMPI_H or MPI_FINC=-DMPI_MOD #
# If necessary add MPIINCDIR #
##########################################################
MPIDIR=/usr/local/mpich-gcc43
MPIBIN=$(MPIDIR)/bin
F90LINK=$(MPIBIN)/mpif90
FLINK=$(MPIBIN)/mpif77
MPF90=$(MPIBIN)/mpif90
MPF77=$(MPIBIN)/mpif77
MPCC=$(MPIBIN)/mpicc
MPI_FINC=-DMPI_MOD
#$(FIFLAG)/opt/SUNWhpc/include
####################### Section 3 #######################
# Specify paths to libraries #
##########################################################
BLAS=-lblas-gcc42 -L$(HOME)/LIB
BLACS=-lmpiblacs-gcc42 -L$(HOME)/LIB
####################### Section 4 #######################
# Other useful tools&defines #
##########################################################
#
# The examples can make use of METIS from U. Minnesota.
# http://www.cs.umn.edu:~karypis
# but it's optional
#
#METIS_LIB = -L$(HOME)/NUMERICAL/metis-4.0 -lmetis
PSBLDLIBS=$(BLACS) $(BLAS) $(METIS_LIB)
# Add -DPtr64Bits if needed
PSBCDEFINES=-DLowerUnderscore
#
PSBFDEFINES=-DHAVE_KSENDID $(MPI_FINC) -DHAVE_MOVE_ALLOC
# -DHAVE_METIS
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
CDEFINES=$(PSBCDEFINES)
FDEFINES=$(PSBFDEFINES)
$(.mod).o:
.c.o:
$(CC) $(CCOPT) $(CINCLUDES) $(CDEFINES) -c $<
.f.o:
$(FC) $(FCOPT) $(FINCLUDES) -c $<
.f$(.mod):
$(FC) $(FCOPT) $(FINCLUDES) -c $<
.f90$(.mod):
$(F90) $(F90COPT) $(FINCLUDES) -c $<
.f90.o:
$(F90) $(F90COPT) $(FINCLUDES) -c $<
.F.o:
$(FC) $(FCOPT) $(FINCLUDES) $(FDEFINES) -c $<
.F90.o:
$(F90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $<
.F90$(.mod):
$(F90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $<
Make/Make.inc.ifort9
-105
View File
@@ -1,105 +0,0 @@
.mod=.mod
.fh=.fh
.SUFFIXES:
.SUFFIXES: .f90 .F90 $(.mod) .F .f .c .o
####################### 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
#
# Which flag does your compiler use for module inclusion?
# Most compilers use -I but Sun uses -M
# FIFLAG is for INCLUDE
FMFLAG=-I
FIFLAG=-I
####################### Section 2 #######################
# Define your linker and linker flags here #
# Does your MPI provide mpi.mod or mpif.h? #
# MPI_FINC=-DMPI_H or MPI_FINC=-DMPI_MOD #
# If necessary add MPIINCDIR #
##########################################################
MPIDIR=/usr/local/mpich-ifc91
MPIBIN=$(MPIDIR)/bin
F90LINK=$(MPIBIN)/mpif90
FLINK=$(MPIBIN)/mpif77
MPF90=$(MPIBIN)/mpif90
MPF77=$(MPIBIN)/mpif77
MPCC=$(MPIBIN)/mpicc
MPI_FINC=-DMPI_MOD
#$(FIFLAG)/opt/SUNWhpc/include
####################### Section 3 #######################
# Specify paths to libraries #
##########################################################
BLAS=-lblas-ifort91 -L$(HOME)/LIB
BLACS=-lmpiblacs-ifort91 -L$(HOME)/LIB
####################### Section 4 #######################
# Other useful tools&defines #
##########################################################
#
# The examples can make use of METIS from U. Minnesota.
# http://www.cs.umn.edu:~karypis
# but it's optional
#
#METIS_LIB = -L$(HOME)/NUMERICAL/metis-4.0 -lmetis
PSBLDLIBS=$(BLACS) $(BLAS) $(METIS_LIB)
# Add -DPtr64Bits if needed
PSBCDEFINES=-DLowerUnderscore
#
# Note: MOVE_ALLOC is only on Intel Fortran 9.1, NOT on 9.0
PSBFDEFINES=-DHAVE_KSENDID $(MPI_FINC) -DHAVE_MOVE_ALLOC
# -DHAVE_METIS
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
CDEFINES=$(PSBCDEFINES)
FDEFINES=$(PSBFDEFINES)
$(.mod).o:
.c.o:
$(CC) $(CCOPT) $(CINCLUDES) $(CDEFINES) -c $<
.f.o:
$(FC) $(FCOPT) $(FINCLUDES) -c $<
.f$(.mod):
$(FC) $(FCOPT) $(FINCLUDES) -c $<
.f90$(.mod):
$(F90) $(F90COPT) $(FINCLUDES) -c $<
.f90.o:
$(F90) $(F90COPT) $(FINCLUDES) -c $<
.F.o:
$(FC) $(FCOPT) $(FINCLUDES) $(FDEFINES) -c $<
.F90.o:
$(F90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $<
.F90$(.mod):
$(F90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $<
Make/Make.inc.sp5
-103
View File
@@ -1,103 +0,0 @@
.mod=.mod
.fh=.fh
.SUFFIXES:
.SUFFIXES: .f90 .F90 $(.mod) .F .f .c .o
####################### Section 1 #######################
# Define your compilers and compiler flags here #
# These seems to be valid as of XLF 10.1 #
##########################################################
F90=xlf95 -qsuffix=f=f90:cpp=F90
FC=xlf -qsuffix=cpp=F
F77=$(FC)
CC=xlc
F90COPT= -O3
FCOPT=-O3
CCOPT=-O3
#
# Which flag does your compiler use for module inclusion?
# Most compilers use -I but Sun uses -M
# FIFLAG is for INCLUDE
FMFLAG=-I
FIFLAG=-I
####################### Section 2 #######################
# Define your linker and linker flags here #
# Does your MPI provide mpi.mod or mpif.h? #
# MPI_FINC=-DMPI_H or MPI_FINC=-DMPI_MOD #
# If necessary add MPIINCDIR #
##########################################################
MPF90=mpxlf95 -qsuffix=f=f90:cpp=F90
F90LINK=$(MPF90)
FLINK=$(MPF90)
MPF77=mpxlf95 -qfixed
MPCC=mpcc
MPI_FINC=-WF,-DMPI_MOD
#$(FIFLAG)/opt/SUNWhpc/include
####################### Section 3 #######################
# Specify paths to libraries #
##########################################################
BLAS=-lessl
BLACS=-lblacssmp
####################### Section 4 #######################
# Other useful tools&defines #
##########################################################
#
# The examples can make use of METIS from U. Minnesota.
# http://www.cs.umn.edu:~karypis
# but it's optional
#
#METIS_LIB = -L$(HOME)/NUMERICAL/metis-4.0 -lmetis
PSBLDLIBS=$(BLACS) $(BLAS) $(METIS_LIB)
# Add -DPtr64Bits if needed
PSBCDEFINES=-DLowerCase -DPtr64Bits
#
PSBFDEFINES=-WF,-DHAVE_ESSL_BLACS $(MPI_FINC)
# There's no MOVE_ALLOC yet in XLF 10.1.
#-WF,-DHAVE_MOVE_ALLOC -WF,-DHAVE_METIS
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
CDEFINES=$(PSBCDEFINES)
FDEFINES=$(PSBFDEFINES)
$(.mod).o:
.c.o:
$(CC) $(CCOPT) $(CINCLUDES) $(CDEFINES) -c $<
.f.o:
$(FC) $(FCOPT) $(FINCLUDES) -c $<
.f$(.mod):
$(FC) $(FCOPT) $(FINCLUDES) -c $<
.f90$(.mod):
$(F90) $(F90COPT) $(FINCLUDES) -c $<
.f90.o:
$(F90) $(F90COPT) $(FINCLUDES) -c $<
.F.o:
$(FC) $(FCOPT) $(FINCLUDES) $(FDEFINES) -c $<
.F90.o:
$(F90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $<
.F90$(.mod):
$(F90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $<
Make/Make.inc.sun-6.2
-102
View File
@@ -1,102 +0,0 @@
#Makefile for Sun Fortran Compiler version 6.2
.mod=.mod
.fh=.fh
.SUFFIXES:
.SUFFIXES: .f90 .F90 $(.mod) .F .f .c .o
####################### Section 1 #######################
# Define your compilers and compiler flags here #
##########################################################
F90=f90
FC=f90
F77=$(FC)
CC=cc
F90COPT=-fast
FCOPT=-fast
CCOPT=-fast
#
# Which flag does your compiler use for module inclusion?
# Most compilers use -I but Sun uses -M
# FIFLAG is for INCLUDE
FMFLAG=-M
FIFLAG=-I
####################### Section 2 #######################
# Define your linker and linker flags here #
# Does your MPI provide mpi.mod or mpif.h? #
# MPI_FINC=-DMPI_H or MPI_FINC=-DMPI_MOD #
# If necessary add MPIINCDIR #
##########################################################
F90LINK=mpf90
FLINK=mpf90 -lf77compat
MPF90=mpf90
MPF77=mpf90 -lf77compat
MPCC=mpcc
MPI_FINC=-DMPI_H $(FIFLAG)/opt/SUNWhpc/include
####################### Section 3 #######################
# Specify paths to libraries #
##########################################################
BLAS=-lblas
BLACS=-lblacsCinit_MPI-SUN4SOL2-0.a -lblacsF77init_MPI-SUN4SOL2-0.a -lblacs_MPI-SUN4SOL2-0.a -L$(HOME)/LIB
BLACS=$(HOME)/LIB/libblacs_MPI-SUN4SOL2-0.a $(HOME)/LIB/libblacsCinit_MPI-SUN4SOL2-0.a $(HOME)/LIB/libblacsF77init_MPI-SUN4SOL2-0.a $(HOME)/LIB/libblacs_MPI-SUN4SOL2-0.a -lmpi
####################### Section 4 #######################
# Other useful tools&defines #
##########################################################
#
# The examples can make use of METIS from U. Minnesota.
# http://www.cs.umn.edu:~karypis
# but it's optional
#
#METIS_LIB = -L$(HOME)/NUMERICAL/metis-4.0 -lmetis
PSBLDLIBS=$(BLACS) $(BLAS) $(METIS_LIB)
# Add -DPtr64Bits if needed
PSBCDEFINES=-DLowerUnderscore
# SUN compiler does not have MOVE_ALLOC.
PSBFDEFINES=-DHAVE_KSENDID $(MPI_FINC)
# -DHAVE_MOVE_ALLOC
# -DHAVE_METIS
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
CDEFINES=$(PSBCDEFINES)
FDEFINES=$(PSBFDEFINES)
$(.mod).o:
.c.o:
$(CC) $(CCOPT) $(CINCLUDES) $(CDEFINES) -c $<
.f.o:
$(FC) $(FCOPT) $(FINCLUDES) -c $<
.f$(.mod):
$(FC) $(FCOPT) $(FINCLUDES) -c $<
.f90$(.mod):
$(F90) $(F90COPT) $(FINCLUDES) -c $<
.f90.o:
$(F90) $(F90COPT) $(FINCLUDES) -c $<
.F.o:
$(FC) $(FCOPT) $(FINCLUDES) $(FDEFINES) -c $<
.F90.o:
$(F90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $<
.F90$(.mod):
$(F90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $<
Makefile
+5
View File
@@ -18,6 +18,8 @@ install:
$(INSTALL_DATA) lib/*.a $(INSTALL_LIBDIR))
(./mkdir.sh $(INSTALL_INCLUDEDIR) && \
$(INSTALL_DATA) lib/*$(.mod) $(INSTALL_INCLUDEDIR))
(./mkdir.sh $(INSTALL_DOCSDIR) && \
/bin/cp -fr docs/*pdf docs/html $(INSTALL_DOCSDIR))
clean:
(cd base; make clean)
(cd prec; make clean )
@@ -31,4 +33,7 @@ veryclean: cleanlib
(cd prec; make veryclean )
(cd krylov; make veryclean)
(cd util; make veryclean)
(cd test/fileread; make clean)
(cd test/pargen; make clean)
(cd test/util; make clean)
README
+21 -62
View File
@@ -1,4 +1,4 @@
This directory contains the PSBLAS library, version 2.2
This directory contains the PSBLAS library, version 2.3
Version 1.0 of the library was described in:
@@ -22,13 +22,10 @@ specified in TR15581).
For the Intel compilers, we recommend version 9.1 or later.
IBM SP.
IBM SP:
The library has been tested on an IBM SP5, with XLC and XLF
version 10.1 and the IBM ESSL/PESSL versions of the BLAS and the
BLACS.
The setting
F90=xlf95 -qsuffix=f=f90:cpp=F90
in Make.inc.sp5 takes care of the f90/F90 extensions.
UTILITIES
@@ -38,7 +35,8 @@ Harwell-Boeing and MatrixMarket file formats.
DOCUMENTATION
See userguide.pdf
See docs/psblas-2.3.pdf; an HTML version of the same document is
available in docs/html.
Please consult the sample programs, especially test/pargen/ppde.f90.
@@ -55,11 +53,6 @@ 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.
INSTALLING
To compile and run our software you will need the following
@@ -80,8 +73,8 @@ prerequisites (see also SERIAL below):
This is optional; it is used in the util and test/fileread
directories but only if you define the HAVE_METIS directive.
We offer an experimental configure script: if everything works well,
it will generate a Make.inc file suitable for building the library.
The configure script will generate a Make.inc file suitable for
building the library.
The script is capable of recognizing the needed libraries with their
default names; if they are in unusual places consider adding the paths
with --with-lib, or explicitly specifying the names in --with-blas,
@@ -89,32 +82,17 @@ with --with-lib, or explicitly specifying the names in --with-blas,
Please note that a common way for the configure script to fail is to
specify inconsistent MPI vs. plain compilers, either directly or
indirectly via environment variables; e.g. specifying the Intel
compiler with FC=ifort and the default MPIFC=mpif90 which points to
GNU Fortran 4.1. The best way to avoid this situation is (in our
opinion) to use the environment modules package (see
http://modules.sourceforge.net/), and load the relevant variables with
(e.g.)
compiler with FC=ifort while at the same time having an MPIFC=mpif90
which points to GNU Fortran.
The best way to avoid this situation is (in our opinion) to use the
environment modules package (see http://modules.sourceforge.net/), and
load the relevant variables with (e.g.)
module load gnu42 mpich
This will delegate to the modules setup to make sure that the version
of mpich in use is the one compiled with the gnu42 compilers.
After the configure script has completed you can always tweak the
Make.inc file yourself.
An annoying problem exists with some versions of MPICH: the configure
script will set -DMPI_MOD, which is to say, the MPI call interfaces
will be resolved by using the MPI Fortran module. However usage of the
module may cause compilation to fail if coupled with the debugging
option -ggdb, because the compiler complains that it cannot find any
matching interface.
The solution: either take out the -ggdb option, or, if you really need
to debug, force -DMPI_H in place of -DMPI_MOD.
As a backup alternative, you can always choose a Make.inc.XXX file in
directory Make that fits your compilers, modify the paths to libraries
to match your installation and copy it to Make.inc in the top
directory.
After you have Make.inc fixed, run
make
to compile the library; go to the test directory and its
@@ -134,52 +112,33 @@ coupled with the debugging option -g, because the compiler complains
that it cannot find a matching interface for some of the
communication routines.
The solution: either take out the -g option, or, if you really need to
debug, force -DMPI_H in place of -DMPI_MOD.
debug, edit Make.inc to force -DMPI_H in place of -DMPI_MOD.
SERIAL: We now provide an (experimental) option to run in serial
mode. This has only been tested with GCC but it should work
with the others as well. In serial mode you don't need the
prereqs 1 and 2 above, and you need to use the -serialmpi
Make.inc. BEWARE: we only provide a VERY minimal set of fake mpi
routines that is known to work with our codes; specifically, we
do not handle a process doing send/receives to itself, neither
do we handle user defined data types.
TODO:
Fix all reamining bugs. Bugs? We dont' have any ! ;-)
Work on a single precision version if there is sufficient demand for
it.
The PSBLAS team.
RELATED SOFTWARE
If you are looking for more sophisticated preconditioners, you may be
interested in the package MLD2P4 from http://www.mld2p4.it
Contact: Salvatore Filippone salvatore.filippone@uniroma2.it
Credits for version 2.2:
Michele Martone contributed the configure machinery.
Michele Martone contributed the initial version of the configure
machinery.
Credits for version 2.0:
Salvatore Filippone
Alfredo Buttari
In a sister package called MLD2P4 we are going to provide a library of
more sophisticated preconditioners, including parallel multilevel ones
that were developed with the contribution of:
Pasqua D'Ambra
Daniela di Serafino
In that package we will provide 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.
The MLD2P4 package will be published soon, watch this space!.
Credits for version 1.0:
Salvatore Filippone
base/internals/Makefile
+2 -2
View File
@@ -4,7 +4,7 @@ FOBJS = psi_compute_size.o psi_crea_bnd_elem.o psi_crea_index.o \
psi_crea_ovr_elem.o psi_bld_tmpovrl.o psi_dl_check.o \
psi_sort_dl.o \
psi_ldsc_pre_halo.o psi_bld_tmphalo.o psi_bld_hash.o\
psi_sort_dl.o psi_idx_cnv.o psi_idx_ins_cnv.o psi_fnd_owner.o
psi_sort_dl.o psi_idx_cnv.o psi_idx_ins_cnv.o
FOBJS2 = psi_exist_ovr_elem.o psi_list_search.o srtlist.o
#COBJS = avltree.o srcht.o
@@ -13,7 +13,7 @@ MPFOBJS = psi_dswapdata.o psi_dswaptran.o\
psi_iswapdata.o psi_iswaptran.o \
psi_cswapdata.o psi_cswaptran.o \
psi_zswapdata.o psi_zswaptran.o \
psi_desc_index.o psi_extrct_dl.o
psi_desc_index.o psi_extrct_dl.o psi_fnd_owner.o
LIBDIR=..
MODDIR=../modules
FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG)$(MODDIR) $(FMFLAG).
base/internals/psi_bld_hash.f90
+29 -10
View File
@@ -33,8 +33,8 @@
! File: psi_bld_hash.f90
!
! Subroutine: psi_bld_hash
! Convers the AVL tree data structure into the hashed list
! of ordered sublists.
! Build a hashed list of ordered sublists of the indices
! contained in loc_to_glob.
!
!
! Arguments:
@@ -53,7 +53,7 @@ subroutine psi_bld_hash(desc,info)
type(psb_desc_type), intent(inout) :: desc
integer, intent(out) :: info
integer :: i,j,np,me,lhalo,nhalo,&
integer :: i,j,np,me,lhalo,nhalo,nbits,hsize,hmask,&
& n_col, err_act, key, ih, nh, idx, nk,icomm
integer :: ictxt,n_row
character(len=20) :: name,ch_err
@@ -85,7 +85,26 @@ subroutine psi_bld_hash(desc,info)
nk = n_col
call psb_realloc(nk,2,desc%glb_lc,info)
if (info ==0) call psb_realloc(psb_hash_size+1,desc%hashv,info,lb=0)
nbits = psb_hash_bits
hsize = 2**nbits
do
if (hsize < 0) then
! This should never happen for sane values
! of psb_max_hash_bits.
write(0,*) 'Error: hash size overflow ',hsize,nbits
info = -2
return
end if
if (hsize > nk) exit
if (nbits >= psb_max_hash_bits) exit
nbits = nbits + 1
hsize = hsize * 2
end do
hmask = hsize - 1
desc%hashvsize = hsize
desc%hashvmask = hmask
if (info ==0) call psb_realloc(hsize+1,desc%hashv,info,lb=0)
if (info /= 0) then
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
@@ -94,32 +113,32 @@ subroutine psi_bld_hash(desc,info)
! Build a hashed table of sorted lists to search for
! indices.
desc%hashv(0:psb_hash_size) = 0
desc%hashv(0:hsize) = 0
do i=1, nk
key = desc%loc_to_glob(i)
ih = iand(key,psb_hash_mask)
ih = iand(key,hmask)
desc%hashv(ih) = desc%hashv(ih) + 1
end do
nh = desc%hashv(0)
idx = 1
do i=1, psb_hash_size
do i=1, hsize
desc%hashv(i-1) = idx
idx = idx + nh
nh = desc%hashv(i)
end do
do i=1, nk
key = desc%loc_to_glob(i)
ih = iand(key,psb_hash_mask)
ih = iand(key,hmask)
idx = desc%hashv(ih)
desc%glb_lc(idx,1) = key
desc%glb_lc(idx,2) = i
desc%hashv(ih) = desc%hashv(ih) + 1
end do
do i = psb_hash_size, 1, -1
do i = hsize, 1, -1
desc%hashv(i) = desc%hashv(i-1)
end do
desc%hashv(0) = 1
do i=0, psb_hash_size-1
do i=0, hsize-1
idx = desc%hashv(i)
nh = desc%hashv(i+1) - desc%hashv(i)
if (nh > 1) then
base/internals/psi_bld_tmphalo.f90
+35 -44
View File
@@ -91,53 +91,44 @@ subroutine psi_bld_tmphalo(desc,info)
! Here we do not know yet who owns what, so we have
! to call fnd_owner.
nh = (n_col-n_row)
if (nh >= 0) then
Allocate(helem(nh),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
Allocate(helem(max(1,nh)),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
do i=1, nh
helem(i) = desc%loc_to_glob(n_row+i)
end do
do i=1, nh
helem(i) = desc%loc_to_glob(n_row+i)
end do
call psi_fnd_owner(nh,helem,hproc,desc,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='fnd_owner')
goto 9999
endif
if (nh > size(hproc)) then
info=4010
call psb_errpush(4010,name,a_err='nh > size(hproc)')
goto 9999
end if
allocate(tmphl((3*((n_col-n_row)+1)+1)),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
j = 1
do i=1,nh
tmphl(j+0) = hproc(i)
if (tmphl(j+0)<0) then
write(0,*) 'Unrecoverable error: missing proc from asb'
end if
tmphl(j+1) = 1
tmphl(j+2) = n_row+i
j = j + 3
end do
tmphl(j) = -1
lhalo = j
nhalo = (lhalo-1)/3
else
allocate(tmphl(1),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
tmphl=-1
call psi_fnd_owner(nh,helem,hproc,desc,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='fnd_owner')
goto 9999
endif
if (nh > size(hproc)) then
info=4010
call psb_errpush(4010,name,a_err='nh > size(hproc)')
goto 9999
end if
allocate(tmphl((3*((n_col-n_row)+1)+1)),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
j = 1
do i=1,nh
tmphl(j+0) = hproc(i)
if (tmphl(j+0)<0) then
write(0,*) 'Unrecoverable error: missing proc from asb'
end if
tmphl(j+1) = 1
tmphl(j+2) = n_row+i
j = j + 3
end do
tmphl(j) = -1
lhalo = j
nhalo = (lhalo-1)/3
call psb_transfer(tmphl,desc%halo_index,info)
base/internals/psi_fnd_owner.F90
+300
View File
@@ -0,0 +1,300 @@
!!$
!!$ Parallel Sparse BLAS version 2.2
!!$ (C) Copyright 2006/2007/2008
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
!
! File: psi_fnd_owner.f90
!
! Subroutine: psi_fnd_owner
! Figure out who owns global indices.
!
! Arguments:
! nv - integer Number of indices required on the calling
! process
! idx(:) - integer Required indices on the calling process.
! Note: the indices should be unique!
! iprc(:) - integer, allocatable Output: process identifiers for the corresponding
! indices
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. return code.
!
subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
use psb_descriptor_type
use psb_serial_mod
use psb_const_mod
use psb_error_mod
use psb_penv_mod
use psb_realloc_mod
use psi_mod, psb_protect_name => psi_fnd_owner
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
integer, intent(in) :: nv
integer, intent(in) :: idx(:)
integer, allocatable, intent(out) :: iprc(:)
type(psb_desc_type), intent(in) :: desc
integer, intent(out) :: info
integer, allocatable :: hsz(:),hidx(:),helem(:),hproc(:),&
& sdsz(:),sdidx(:), rvsz(:), rvidx(:),answers(:,:),idxsrch(:,:)
integer :: i,n_row,n_col,err_act,ih,icomm,hsize,ip,isz,k,j,&
& last_ih, last_j
integer :: ictxt,np,me
logical, parameter :: gettime=.false.
real(psb_dpk_) :: t0, t1, t2, t3, t4, tamx, tidx
character(len=20) :: name
info = 0
name = 'psi_fnd_owner'
call psb_erractionsave(err_act)
ictxt = psb_cd_get_context(desc)
icomm = psb_cd_get_mpic(desc)
n_row = psb_cd_get_local_rows(desc)
n_col = psb_cd_get_local_cols(desc)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
call psb_errpush(info,name)
goto 9999
endif
if (nv < 0 ) then
info = 2010
call psb_errpush(info,name)
goto 9999
endif
if (.not.(psb_is_ok_desc(desc))) then
call psb_errpush(4010,name,a_err='invalid desc')
goto 9999
end if
if (gettime) then
t0 = psb_wtime()
end if
!
! The basic idea is very simple.
! First we collect (to all) all the requests.
Allocate(hidx(np+1),hsz(np),&
& sdsz(0:np-1),sdidx(0:np-1),&
& rvsz(0:np-1),rvidx(0:np-1),&
& stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
hsz = 0
hsz(me+1) = nv
call psb_amx(ictxt,hsz,info)
hidx(1) = 0
do i=1, np
hidx(i+1) = hidx(i) + hsz(i)
end do
hsize = hidx(np+1)
Allocate(helem(hsize),hproc(hsize),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
if (gettime) then
t3 = psb_wtime()
end if
call mpi_allgatherv(idx,hsz(me+1),mpi_integer,&
& hproc,hsz,hidx,mpi_integer,&
& icomm,info)
if (gettime) then
tamx = psb_wtime() - t3
end if
! Second, we figure out locally whether we own the indices (whoever is
! asking for them).
if (gettime) then
t3 = psb_wtime()
end if
call psi_idx_cnv(hsize,hproc,helem,desc,info,owned=.true.)
if (gettime) then
tidx = psb_wtime()-t3
end if
if (info /= 0) then
call psb_errpush(4010,name,a_err='psi_idx_cnv')
goto 9999
end if
! Third: we build the answers for those indices we own,
! with a section for each process asking.
hidx = hidx +1
j = 0
do ip = 0, np-1
sdidx(ip) = j
sdsz(ip) = 0
do i=hidx(ip+1), hidx(ip+1+1)-1
if ((0 < helem(i)).and. (helem(i) <= n_row)) then
j = j + 1
hproc(j) = hproc(i)
sdsz(ip) = sdsz(ip) + 1
end if
end do
end do
if (gettime) then
t3 = psb_wtime()
end if
! Collect all the answers with alltoallv (need sizes)
call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info)
isz = sum(rvsz)
allocate(answers(isz,2),idxsrch(nv,2),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
j = 0
do ip=0, np-1
rvidx(ip) = j
j = j + rvsz(ip)
end do
call mpi_alltoallv(hproc,sdsz,sdidx,mpi_integer,&
& answers(:,1),rvsz,rvidx,mpi_integer,&
& icomm,info)
if (gettime) then
tamx = psb_wtime() - t3 + tamx
end if
j = 1
do ip = 0,np-1
do k=1,rvsz(ip)
answers(j,2) = ip
j = j + 1
end do
end do
! Sort the answers and the requests, so we can
! match them efficiently
call psb_msort(answers(:,1),ix=answers(:,2),&
& flag=psb_sort_keep_idx_)
idxsrch(1:nv,1) = idx(1:nv)
call psb_msort(idxsrch(1:nv,1),ix=idxsrch(1:nv,2))
! Now extract the answers for our local query
call psb_realloc(nv,iprc,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_realloc')
goto 9999
end if
last_ih = -1
last_j = -1
j = 1
do i=1, nv
ih = idxsrch(i,1)
if (ih == last_ih) then
iprc(idxsrch(i,2)) = answers(last_j,2)
else
do
if (j > size(answers,1)) then
! Last resort attempt.
call ibsrch(j,ih,size(answers,1),answers(:,1))
if (j == -1) then
write(0,*) me,'psi_fnd_owner: searching for ',ih, &
& 'not found : ',size(answers,1),':',answers(:,1)
info = 4001
call psb_errpush(4001,name,a_err='out bounds srch ih')
goto 9999
end if
end if
if (answers(j,1) == ih) exit
if (answers(j,1) > ih) then
k = j
call ibsrch(j,ih,k,answers(1:k,1))
if (j == -1) then
write(0,*) me,'psi_fnd_owner: searching for ',ih, &
& 'not found : ',size(answers,1),':',answers(:,1)
info = 4001
call psb_errpush(4001,name,a_err='out bounds srch ih')
goto 9999
end if
end if
j = j + 1
end do
! Note that the answers here are given in order
! of sending process, so we are implicitly getting
! the max process index in case of overlap.
last_ih = ih
do
last_j = j
iprc(idxsrch(i,2)) = answers(j,2)
j = j + 1
if (j > size(answers,1)) exit
if (answers(j,1) /= ih) exit
end do
end if
end do
if (gettime) then
call psb_barrier(ictxt)
t1 = psb_wtime()
t1 = t1 -t0 - tamx - tidx
call psb_amx(ictxt,tamx)
call psb_amx(ictxt,tidx)
call psb_amx(ictxt,t1)
if (me==psb_root_) then
write(*,'(" fnd_owner idx time : ",es10.4)') tidx
write(*,'(" fnd_owner amx time : ",es10.4)') tamx
write(*,'(" fnd_owner remainedr : ",es10.4)') t1
endif
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psi_fnd_owner
base/internals/psi_fnd_owner.f90
-168
View File
@@ -1,168 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 2.2
!!$ (C) Copyright 2006/2007/2008
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
!
! File: psi_fnd_owner.f90
!
! Subroutine: psi_fnd_owner
! Figure out who owns global indices.
!
! Arguments:
! nv - integer Number of indices required on the calling
! process
! idx(:) - integer Required indices on the calling process
! iprc(:) - integer, allocatable Output: process identifiers for the corresponding
! indices
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. return code.
!
subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
use psb_descriptor_type
use psb_serial_mod
use psb_const_mod
use psb_error_mod
use psb_penv_mod
use psb_realloc_mod
use psi_mod, psb_protect_name => psi_fnd_owner
implicit none
integer, intent(in) :: nv
integer, intent(in) :: idx(:)
integer, allocatable, intent(out) :: iprc(:)
type(psb_desc_type), intent(in) :: desc
integer, intent(out) :: info
integer,allocatable :: hsz(:),hidx(:),helem(:),hproc(:)
integer :: i,n_row,n_col, err_act,ih,icomm,hsize
integer :: ictxt,np,me
character(len=20) :: name
info = 0
name = 'psi_fnd_owner'
call psb_erractionsave(err_act)
ictxt = psb_cd_get_context(desc)
icomm = psb_cd_get_mpic(desc)
n_row = psb_cd_get_local_rows(desc)
n_col = psb_cd_get_local_cols(desc)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
call psb_errpush(info,name)
goto 9999
endif
if (nv < 0 ) then
info = 2010
call psb_errpush(info,name)
goto 9999
endif
if (.not.(psb_is_ok_desc(desc))) then
call psb_errpush(4010,name,a_err='invalid desc')
goto 9999
end if
!
! The basic idea is very simple.
! First we figure out the total number of requests.
Allocate(hidx(np+1),hsz(np),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
hsz = 0
hsz(me+1) = nv
call psb_amx(ictxt,hsz,info)
hidx(1) = 1
do i=1, np
hidx(i+1) = hidx(i) + hsz(i)
end do
hsize = hidx(np+1)-1
Allocate(helem(hsize),hproc(hsize),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
! Second we build the aggregate list of requests (with psb_amx)
helem(:) = 0
ih = hidx(me+1)
do i=1, hsz(me+1)
helem(ih+i-1) = idx(i)
end do
call psb_amx(ictxt,helem,info)
! Third, we figure out locally whether we own the indices (whoever is
! asking for them) and build our part of the reply (we shift process
! indices so that they're 1-based)
call psi_idx_cnv(hsize,helem,desc,info,owned=.true.)
if (info /= 0) then
call psb_errpush(4010,name,a_err='psi_idx_cnv')
goto 9999
end if
do i=1,hsize
if ((0< helem(i)).and. (helem(i) <= n_row))then
hproc(i) = me+1
else
hproc(i) = 0
end if
end do
! Fourth, we do a psb_amx on the replies so that we have everybody's answers
call psb_amx(ictxt,hproc,info)
! Fifth, we extract the answers for our local query, and shift back the
! process indices to 0-based.
call psb_realloc(nv,iprc,info)
ih = hidx(me+1)
do i=1, hsz(me+1)
iprc(i) = hproc(ih+i-1) - 1
end do
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psi_fnd_owner
base/internals/psi_idx_cnv.f90
+155 -139
View File
@@ -56,15 +56,13 @@ subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned)
integer, intent(inout) :: idxin(:)
type(psb_desc_type), intent(in) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask(:)
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer :: ictxt,mglob, nglob
integer :: ictxt,mglob, nglob,ip,lip,i
integer :: np, me
integer :: nrow,ncol, err_act
integer, allocatable :: idxout(:)
integer, parameter :: relocsz=200
character(len=20) :: name
logical, pointer :: mask_(:)
logical :: owned_
info = 0
@@ -91,7 +89,7 @@ subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned)
goto 9999
end if
if (nv == 0) return
if (size(idxin) < nv) then
info = 1111
@@ -106,15 +104,6 @@ subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned)
call psb_errpush(info,name)
goto 9999
end if
mask_ => mask
else
allocate(mask_(nv),stat=info)
if (info /= 0) then
info = 4000
call psb_errpush(info,name)
goto 9999
endif
mask_ = .true.
endif
if (present(owned)) then
@@ -123,19 +112,123 @@ subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned)
owned_ = .false.
endif
allocate(idxout(nv),stat=info)
if (info /= 0) then
info = 4000
call psb_errpush(info,name)
goto 9999
endif
call psi_idx_cnv2(nv,idxin,idxout,desc,info,mask_,owned_)
idxin(1:nv) = idxout(1:nv)
!
! The input descriptor may be in any state
!
if (psb_is_large_desc(desc)) then
!
! Large descriptor: the size of the index space is such that
! we decided not to allocate the glob_to_loc(:) map.
!
if (psb_is_bld_desc(desc)) then
!
! During the build phase of a large descriptor the indices
! are kept in an AVL tree.
!
if (present(mask)) then
deallocate(idxout)
do i = 1, nv
if (mask(i)) then
ip = idxin(i)
if ((ip < 1 ).or.(ip>mglob)) then
idxin(i) = -1
cycle
endif
call psi_inner_cnv(ip,lip,desc%hashvmask,desc%hashv,desc%glb_lc)
if ((lip < 0).and.associated(desc%hash)) &
& call psb_hash_searchkey(ip,lip,desc%hash,info)
if (owned_) then
if (lip<=nrow) then
idxin(i) = lip
else
idxin(i) = -1
endif
else
idxin(i) = lip
endif
end if
enddo
else
do i = 1, nv
ip = idxin(i)
if ((ip < 1 ).or.(ip>mglob)) then
idxin(i) = -1
cycle
endif
call psi_inner_cnv(ip,lip,desc%hashvmask,desc%hashv,desc%glb_lc)
if ((lip < 0).and.associated(desc%hash)) &
& call psb_hash_searchkey(ip,lip,desc%hash,info)
if (owned_) then
if (lip<=nrow) then
idxin(i) = lip
else
idxin(i) = -1
endif
else
idxin(i) = lip
endif
enddo
end if
else if (psb_is_asb_desc(desc)) then
!
! When a large descriptor is assembled the indices
! are kept in a (hashed) list of ordered lists,
! hence psi_inner_cnv does the hashing and binary search.
!
if (.not.allocated(desc%hashv)) then
info = 4001
call psb_errpush(info,name,a_err='Invalid hashv into inner_cnv')
end if
call psi_inner_cnv(nv,idxin,desc%hashvmask,desc%hashv,desc%glb_lc,mask=mask)
end if
if (.not.present(mask)) then
deallocate(mask_)
else
!
! Not a large descriptor, so we have the glob_to_loc(:) map
! available.
!
if (present(mask)) then
do i = 1, nv
if (mask(i)) then
ip = idxin(i)
if ((ip < 1 ).or.(ip>mglob)) then
info = 1133
call psb_errpush(info,name)
goto 9999
endif
lip = desc%glob_to_loc(ip)
if (owned_) then
if (lip<=nrow) then
idxin(i) = lip
else
idxin(i) = -1
endif
else
idxin(i) = lip
endif
end if
enddo
else
do i = 1, nv
ip = idxin(i)
if ((ip < 1 ).or.(ip>mglob)) then
info = 1133
call psb_errpush(info,name)
goto 9999
endif
lip = desc%glob_to_loc(ip)
if (owned_) then
if (lip<=nrow) then
idxin(i) = lip
else
idxin(i) = -1
endif
else
idxin(i) = lip
endif
enddo
end if
end if
call psb_erractionrestore(err_act)
@@ -204,18 +297,17 @@ subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned)
use psb_const_mod
use psb_error_mod
use psb_penv_mod
use psb_avl_mod
use psi_mod, psb_protect_name => psi_idx_cnv2
implicit none
integer, intent(in) :: nv, idxin(:)
integer, intent(out) :: idxout(:)
type(psb_desc_type), intent(in) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask(:)
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer :: i,ictxt,mglob, nglob
integer :: np, me
integer :: nrow,ncol, ip, err_act,lip, lipf
integer :: nrow,ncol, err_act
integer, parameter :: relocsz=200
character(len=20) :: name
logical, pointer :: mask_(:)
@@ -258,106 +350,9 @@ subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned)
goto 9999
end if
if (present(mask)) then
if (size(mask) < nv) then
info = 1111
call psb_errpush(info,name)
goto 9999
end if
mask_ => mask
else
allocate(mask_(nv),stat=info)
if (info /= 0) then
info = 4000
call psb_errpush(info,name)
goto 9999
endif
mask_ = .true.
endif
if (present(owned)) then
owned_ = owned
else
owned_ = .false.
endif
!
! The input descriptor may be in any state
!
if (psb_is_large_desc(desc)) then
!
! Large descriptor: the size of the index space is such that
! we decided not to allocate the glob_to_loc(:) map.
!
if (psb_is_bld_desc(desc)) then
!
! During the build phase of a large descriptor the indices
! are kept in an AVL tree.
!
do i = 1, nv
if (mask_(i)) then
ip = idxin(i)
if ((ip < 1 ).or.(ip>mglob)) then
idxout(i) = -1
cycle
endif
call SearchKey(desc%avltree,ip,lip,info)
if (owned_) then
if (lip<=nrow) then
idxout(i) = lip
else
idxout(i) = -1
endif
else
idxout(i) = lip
endif
end if
enddo
else if (psb_is_asb_desc(desc)) then
!
! When a large descriptor is assembled the indices
! are kept in a (hashed) list of ordered lists,
! hence psi_inner_cnv does the hashing and binary search.
!
if (.not.allocated(desc%hashv)) then
write(0,*) 'Inconsistent input to inner_cnv'
end if
call psi_inner_cnv(nv,idxin,idxout,psb_hash_mask,desc%hashv,desc%glb_lc)
end if
else
!
! Not a large descriptor, so we have the glob_to_loc(:) map
! available.
!
do i = 1, nv
if (mask_(i)) then
ip = idxin(i)
if ((ip < 1 ).or.(ip>mglob)) then
info = 1133
call psb_errpush(info,name)
goto 9999
endif
lip = desc%glob_to_loc(ip)
if (owned_) then
if (lip<=nrow) then
idxout(i) = lip
else
idxout(i) = -1
endif
else
idxout(i) = lip
endif
end if
enddo
end if
if (.not.present(mask)) then
deallocate(mask_)
end if
idxout(1:nv) = idxin(1:nv)
call psi_idx_cnv1(nv,idxout,desc,info,mask=mask,owned=owned)
call psb_erractionrestore(err_act)
return
@@ -427,24 +422,45 @@ subroutine psi_idx_cnvs(idxin,idxout,desc,info,mask,owned)
integer, intent(out) :: idxout
type(psb_desc_type), intent(in) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
logical :: mask_(1)
integer :: iout(1)
logical :: mask_, owned_
if (present(mask)) then
if (present(mask)) then
mask_ = mask
else
mask_ = .true.
endif
if (present(owned)) then
owned_ = owned
else
owned_ = .true.
endif
call psi_idx_cnv(1,(/idxin/),iout,desc,info,(/mask_/),owned_)
mask_=.true.
end if
iout = idxin
call psi_idx_cnv(1,iout,desc,info,mask=mask_,owned=owned)
idxout=iout(1)
return
end subroutine psi_idx_cnvs
subroutine psi_idx_cnvs1(idxin,desc,info,mask,owned)
use psi_mod, psb_protect_name => psi_idx_cnvs1
use psb_descriptor_type
integer, intent(inout) :: idxin
type(psb_desc_type), intent(in) :: desc
integer, intent(out) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
logical :: mask_(1)
integer :: iout(1)
if (present(mask)) then
mask_ = mask
else
mask_=.true.
end if
iout(1) = idxin
call psi_idx_cnv(1,iout,desc,info,mask=mask_,owned=owned)
idxin = iout(1)
return
end subroutine psi_idx_cnvs1
base/internals/psi_idx_ins_cnv.f90
+314 -191
View File
@@ -60,14 +60,14 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask)
integer, intent(inout) :: idxin(:)
type(psb_desc_type), intent(inout) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask(:)
logical, intent(in), optional :: mask(:)
integer :: ictxt,mglob, nglob
integer :: np, me
integer :: nrow,ncol, err_act
integer, allocatable :: idxout(:)
integer :: pnt_halo, nh, ip, lip,nxt,lipf,i,k,isize
logical :: pnt_h_ok
integer, parameter :: relocsz=200
character(len=20) :: name
logical, pointer :: mask_(:)
character(len=20) :: name,ch_err
info = 0
name = 'psb_idx_ins_cnv'
@@ -93,7 +93,7 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask)
goto 9999
end if
if (nv == 0) return
if (size(idxin) < nv) then
info = 1111
@@ -108,32 +108,237 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask)
call psb_errpush(info,name)
goto 9999
end if
mask_ => mask
else
allocate(mask_(nv),stat=info)
if (info /= 0) then
info = 4000
call psb_errpush(info,name)
goto 9999
endif
if (psb_is_large_desc(desc)) then
if (present(mask)) then
do i = 1, nv
if (mask(i)) then
ip = idxin(i)
if ((ip < 1 ).or.(ip>mglob)) then
idxin(i) = -1
cycle
endif
nxt = ncol + 1
call psi_inner_cnv(ip,lip,desc%hashvmask,desc%hashv,desc%glb_lc)
if (lip < 0) &
& call psb_hash_searchinskey(ip,lip,nxt,desc%hash,info)
if (info >=0) then
if (nxt == lip) then
ncol = nxt
isize = size(desc%loc_to_glob)
if (ncol > isize) then
nh = ncol + max(nv,relocsz)
call psb_realloc(nh,desc%loc_to_glob,info,pad=-1)
if (info /= 0) then
info=1
ch_err='psb_realloc'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
end if
isize = nh
endif
desc%loc_to_glob(nxt) = ip
endif
info = 0
else
ch_err='SearchInsKeyVal'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
end if
idxin(i) = lip
info = 0
else
idxin(i) = -1
end if
enddo
else
do i = 1, nv
ip = idxin(i)
if ((ip < 1 ).or.(ip>mglob)) then
idxin(i) = -1
cycle
endif
nxt = ncol + 1
call psi_inner_cnv(ip,lip,desc%hashvmask,desc%hashv,desc%glb_lc)
if (lip < 0) &
& call psb_hash_searchinskey(ip,lip,nxt,desc%hash,info)
if (info >=0) then
if (nxt == lip) then
ncol = nxt
isize = size(desc%loc_to_glob)
if (ncol > isize) then
nh = ncol + max(nv,relocsz)
call psb_realloc(nh,desc%loc_to_glob,info,pad=-1)
if (info /= 0) then
info=1
ch_err='psb_realloc'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
end if
isize = nh
endif
desc%loc_to_glob(nxt) = ip
endif
info = 0
else
ch_err='SearchInsKeyVal'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
end if
idxin(i) = lip
info = 0
enddo
endif
mask_ = .true.
endif
allocate(idxout(nv),stat=info)
if (info /= 0) then
info = 4000
call psb_errpush(info,name)
goto 9999
endif
call psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask_)
idxin(1:nv) = idxout(1:nv)
else
deallocate(idxout)
if (.not.allocated(desc%halo_index)) then
allocate(desc%halo_index(relocsz))
desc%halo_index(:) = -1
desc%matrix_data(psb_pnt_h_) = 1
endif
pnt_halo = desc%matrix_data(psb_pnt_h_)
pnt_h_ok = .false.
isize = size(desc%halo_index)
if ((1 <= pnt_halo).and.(pnt_halo <= isize)) then
if (desc%halo_index(pnt_halo) == -1 ) then
if (pnt_halo == 1) then
pnt_h_ok = .true.
else if (desc%halo_index(pnt_halo-1) /= -1 ) then
pnt_h_ok = .true.
end if
end if
end if
if (.not.pnt_h_ok) then
pnt_halo = 1
do
if (desc%halo_index(pnt_halo) == -1) exit
if (pnt_halo == isize) exit
pnt_halo = pnt_halo + 1
end do
if (desc%halo_index(pnt_halo) /= -1) then
call psb_realloc(isize+relocsz,desc%halo_index,info,pad=-1)
pnt_halo = pnt_halo + 1
end if
end if
if (present(mask)) then
do i = 1, nv
if (mask(i)) then
ip = idxin(i)
if ((ip < 1 ).or.(ip>mglob)) then
idxin(i) = -1
cycle
endif
k = desc%glob_to_loc(ip)
if (k < -np) then
k = k + np
k = - k - 1
ncol = ncol + 1
lip = ncol
desc%glob_to_loc(ip) = ncol
isize = size(desc%loc_to_glob)
if (ncol > isize) then
nh = ncol + max(nv,relocsz)
call psb_realloc(nh,desc%loc_to_glob,info,pad=-1)
if (info /= 0) then
info=3
ch_err='psb_realloc'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
end if
isize = nh
endif
desc%loc_to_glob(ncol) = ip
isize = size(desc%halo_index)
if ((pnt_halo+3) > isize) then
nh = isize + max(nv,relocsz)
call psb_realloc(nh,desc%halo_index,info,pad=-1)
if (info /= 0) then
info=4
ch_err='psb_realloc'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
end if
isize = nh
endif
desc%halo_index(pnt_halo) = k
desc%halo_index(pnt_halo+1) = 1
desc%halo_index(pnt_halo+2) = ncol
pnt_halo = pnt_halo + 3
else
lip = k
endif
idxin(i) = lip
else
idxin(i) = -1
end if
enddo
else
do i = 1, nv
ip = idxin(i)
if ((ip < 1 ).or.(ip>mglob)) then
idxin(i) = -1
cycle
endif
k = desc%glob_to_loc(ip)
if (k < -np) then
k = k + np
k = - k - 1
ncol = ncol + 1
lip = ncol
desc%glob_to_loc(ip) = ncol
isize = size(desc%loc_to_glob)
if (ncol > isize) then
nh = ncol + max(nv,relocsz)
call psb_realloc(nh,desc%loc_to_glob,info,pad=-1)
if (info /= 0) then
info=3
ch_err='psb_realloc'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
end if
isize = nh
endif
desc%loc_to_glob(ncol) = ip
isize = size(desc%halo_index)
if ((pnt_halo+3) > isize) then
nh = isize + max(nv,relocsz)
call psb_realloc(nh,desc%halo_index,info,pad=-1)
if (info /= 0) then
info=4
ch_err='psb_realloc'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
end if
isize = nh
endif
desc%halo_index(pnt_halo) = k
desc%halo_index(pnt_halo+1) = 1
desc%halo_index(pnt_halo+2) = ncol
pnt_halo = pnt_halo + 3
else
lip = k
endif
idxin(i) = lip
enddo
end if
desc%matrix_data(psb_pnt_h_) = pnt_halo
if (.not.present(mask)) then
deallocate(mask_)
end if
desc%matrix_data(psb_n_col_) = ncol
call psb_erractionrestore(err_act)
return
@@ -204,21 +409,19 @@ subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask)
use psb_const_mod
use psb_error_mod
use psb_penv_mod
use psb_avl_mod
use psi_mod
implicit none
integer, intent(in) :: nv, idxin(:)
integer, intent(out) :: idxout(:)
type(psb_desc_type), intent(inout) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask(:)
logical, intent(in), optional :: mask(:)
integer :: i,ictxt,k,mglob, nglob
integer :: np, me, isize
integer :: pnt_halo,nrow,ncol, nh, ip, err_act,lip,nxt,lipf
logical :: pnt_h_ok
integer, parameter :: relocsz=200
character(len=20) :: name,ch_err
logical, pointer :: mask_(:)
info = 0
name = 'psb_idx_ins_cnv'
@@ -257,160 +460,8 @@ subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask)
goto 9999
end if
if (present(mask)) then
if (size(mask) < nv) then
info = 1111
call psb_errpush(info,name)
goto 9999
end if
mask_ => mask
else
allocate(mask_(nv),stat=info)
if (info /= 0) then
info = 4000
call psb_errpush(info,name)
goto 9999
endif
mask_ = .true.
endif
if (psb_is_large_desc(desc)) then
do i = 1, nv
if (mask_(i)) then
ip = idxin(i)
if ((ip < 1 ).or.(ip>mglob)) then
idxout(i) = -1
cycle
endif
nxt = ncol + 1
call SearchInsKey(desc%avltree,ip,lip,nxt,info)
if (info >=0) then
if (nxt == lip) then
ncol = nxt
isize = size(desc%loc_to_glob)
if (ncol > isize) then
nh = ncol + max(nv,relocsz)
call psb_realloc(nh,desc%loc_to_glob,info,pad=-1)
if (info /= 0) then
info=1
ch_err='psb_realloc'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
end if
isize = nh
endif
desc%loc_to_glob(nxt) = ip
endif
info = 0
else
ch_err='SearchInsKeyVal'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
end if
idxout(i) = lip
info = 0
else
idxout(i) = -1
end if
enddo
else
if (.not.allocated(desc%halo_index)) then
allocate(desc%halo_index(relocsz))
desc%halo_index(:) = -1
desc%matrix_data(psb_pnt_h_) = 1
endif
pnt_halo = desc%matrix_data(psb_pnt_h_)
pnt_h_ok = .false.
isize = size(desc%halo_index)
if ((1 <= pnt_halo).and.(pnt_halo <= isize)) then
if (desc%halo_index(pnt_halo) == -1 ) then
if (pnt_halo == 1) then
pnt_h_ok = .true.
else if (desc%halo_index(pnt_halo-1) /= -1 ) then
pnt_h_ok = .true.
end if
end if
end if
if (.not.pnt_h_ok) then
pnt_halo = 1
do
if (desc%halo_index(pnt_halo) == -1) exit
if (pnt_halo == isize) exit
pnt_halo = pnt_halo + 1
end do
if (desc%halo_index(pnt_halo) /= -1) then
call psb_realloc(isize+relocsz,desc%halo_index,info,pad=-1)
pnt_halo = pnt_halo + 1
end if
end if
do i = 1, nv
if (mask_(i)) then
ip = idxin(i)
if ((ip < 1 ).or.(ip>mglob)) then
idxout(i) = -1
cycle
endif
k = desc%glob_to_loc(ip)
if (k < -np) then
k = k + np
k = - k - 1
ncol = ncol + 1
lip = ncol
desc%glob_to_loc(ip) = ncol
isize = size(desc%loc_to_glob)
if (ncol > isize) then
nh = ncol + max(nv,relocsz)
call psb_realloc(nh,desc%loc_to_glob,info,pad=-1)
if (info /= 0) then
info=3
ch_err='psb_realloc'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
end if
isize = nh
endif
desc%loc_to_glob(ncol) = ip
isize = size(desc%halo_index)
if ((pnt_halo+3) > isize) then
nh = isize + max(nv,relocsz)
call psb_realloc(nh,desc%halo_index,info,pad=-1)
if (info /= 0) then
info=4
ch_err='psb_realloc'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
end if
isize = nh
endif
desc%halo_index(pnt_halo) = k
desc%halo_index(pnt_halo+1) = 1
desc%halo_index(pnt_halo+2) = ncol
pnt_halo = pnt_halo + 3
else
lip = k
endif
idxout(i) = lip
else
idxout(i) = -1
end if
enddo
desc%matrix_data(psb_pnt_h_) = pnt_halo
end if
desc%matrix_data(psb_n_col_) = ncol
if (.not.present(mask)) then
deallocate(mask_)
end if
idxout(1:nv) = idxin(1:nv)
call psi_idx_ins_cnv(nv,idxout,desc,info,mask)
call psb_erractionrestore(err_act)
return
@@ -475,25 +526,97 @@ end subroutine psi_idx_ins_cnv2
! info - integer. return code.
! mask - logical, optional Only do the conversion for specific indices.
!
subroutine psi_idx_ins_cnvs(idxin,idxout,desc,info,mask)
use psi_mod, psb_protect_name => psi_idx_ins_cnvs
subroutine psi_idx_ins_cnvs2(idxin,idxout,desc,info,mask)
use psi_mod, psb_protect_name => psi_idx_ins_cnvs2
use psb_descriptor_type
integer, intent(in) :: idxin
integer, intent(out) :: idxout
type(psb_desc_type), intent(inout) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask
logical, intent(in), optional :: mask
integer :: iout(1)
logical :: mask_
logical :: mask_(1)
if (present(mask)) then
mask_ = mask
else
mask_ = .true.
endif
call psi_idx_ins_cnv(1,(/idxin/),iout,desc,info,(/mask_/))
idxout=iout(1)
end if
iout(1) = idxin
call psi_idx_ins_cnv(1,iout,desc,info,mask_)
idxout = iout(1)
return
end subroutine psi_idx_ins_cnvs2
!!$
!!$ Parallel Sparse BLAS version 2.2
!!$ (C) Copyright 2006/2007/2008
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
!
!
! Subroutine: psi_idx_ins_cnvs
! Converts an index from global to local numbering.
! This routine is called while the descriptor is in the build state;
! the idea is that if an index is not yet marked as local, it is a new
! connection to another process, i.e. a new entry into the halo.
! But we still need the mask, because we have to take out the column indices
! corresponding to row indices we do not own (see psb_cdins for how this is used).
!
! Arguments:
! idxin - integer Required index s
! idxout - integer Output value (negative for masked entries)
! desc - type(psb_desc_type). The communication descriptor.
! info - integer. return code.
! mask - logical, optional Only do the conversion for specific indices.
!
subroutine psi_idx_ins_cnvs1(idxin,desc,info,mask)
use psi_mod, psb_protect_name => psi_idx_ins_cnvs1
use psb_descriptor_type
integer, intent(inout) :: idxin
type(psb_desc_type), intent(inout) :: desc
integer, intent(out) :: info
logical, intent(in), optional :: mask
integer :: iout(1)
logical :: mask_(1)
if (present(mask)) then
mask_ = mask
else
mask_ = .true.
end if
iout(1) = idxin
call psi_idx_ins_cnv(1,iout,desc,info,mask_)
idxin = iout(1)
return
end subroutine psi_idx_ins_cnvs
end subroutine psi_idx_ins_cnvs1
base/internals/psi_inter_desc_index.F90
-338
View File
@@ -1,338 +0,0 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
!
!
! File: psi_inter_desc_index.f90
!
! Subroutine: psi_inter_desc_index
! Converts a list of data exchanges from build format to assembled format.
! See below for a description of the formats.
!
! Arguments:
! desc_a - type(psb_desc_type) The descriptor; in this context only the index
! mapping parts are used.
! index_in(:) - integer The index list, build format
! index_out(:) - integer, allocatable The index list, assembled format
! glob_idx - logical Whether the input indices are in local or global
! numbering; the global numbering is used when
! converting the overlap exchange lists.
! nxch - integer The number of data exchanges on the calling process
! nsnd - integer Total send buffer size on the calling process
! nrcv - integer Total receive buffer size on the calling process
!
! The format of the index lists. Copied from base/modules/psb_desc_type
!
! 7. The data exchange is based on lists of local indices to be exchanged; all the
! lists have the same format, as follows:
! the list is composed of variable dimension blocks, one for each process to
! communicate with; each block contains indices of local elements to be
! exchanged. We do choose the order of communications: do not change
! the sequence of blocks unless you know what you're doing, or you'll
! risk a deadlock. NOTE: This is the format when the state is PSB_ASB_.
! See below for BLD. The end-of-list is marked with a -1.
!
! notation stored in explanation
! --------------- --------------------------- -----------------------------------
! process_id index_v(p+proc_id_) identifier of process with which
! data is exchanged.
! n_elements_recv index_v(p+n_elem_recv_) number of elements to receive.
! elements_recv index_v(p+elem_recv_+i) indexes of local elements to
! receive. these are stored in the
! array from location p+elem_recv_ to
! location p+elem_recv_+
! index_v(p+n_elem_recv_)-1.
! n_elements_send index_v(p+n_elem_send_) number of elements to send.
! elements_send index_v(p+elem_send_+i) indexes of local elements to
! send. these are stored in the
! array from location p+elem_send_ to
! location p+elem_send_+
! index_v(p+n_elem_send_)-1.
!
! This organization is valid for both halo and overlap indices; overlap entries
! need to be updated to ensure that a variable at a given global index
! (assigned to multiple processes) has the same value. The way to resolve the
! issue is to exchange the data and then sum (or average) the values. See
! psb_ovrl subroutine.
!
! 8. When the descriptor is in the BLD state the INDEX vectors contains only
! the indices to be received, organized as a sequence
! of entries of the form (proc,N,(lx1,lx2,...,lxn)) with owning process,
! number of indices (most often N=1), list of local indices.
! This is because we only know the list of halo indices to be received
! as we go about building the sparse matrix pattern, and we want the build
! phase to be loosely synchronized. Thus we record the indices we have to ask
! for, and at the time we call PSB_CDASB we match all the requests to figure
! out who should be sending what to whom.
! However this implies that we know who owns the indices; if we are in the
! LARGE case (as described above) this is actually only true for the OVERLAP list
! that is filled in at CDALL time, and not for the HALO; thus the HALO list
! is rebuilt during the CDASB process (in the psi_ldsc_pre_halo subroutine).
!
!
subroutine psi_inter_desc_index(desc,index_in,dep_list,&
& length_dl,nsnd,nrcv,desc_index,isglob_in,info)
use psb_descriptor_type
use psb_realloc_mod
use psb_error_mod
use psb_const_mod
#ifdef MPI_MOD
use mpi
#endif
use psb_penv_mod
use psi_mod, psb_protect_name => psi_inter_desc_index
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
! ...array parameters.....
type(psb_desc_type) :: desc
integer :: index_in(:),dep_list(:)
integer,allocatable :: desc_index(:)
integer :: length_dl,nsnd,nrcv,info
logical :: isglob_in
! ....local scalars...
integer :: j,me,np,i,proc
! ...parameters...
integer :: ictxt
integer, parameter :: no_comm=-1
! ...local arrays..
integer,allocatable :: brvindx(:),rvsz(:),&
& bsdindx(:),sdsz(:), sndbuf(:), rcvbuf(:)
integer :: ihinsz,ntot,k,err_act,nidx,&
& idxr, idxs, iszs, iszr, nesd, nerv, icomm
logical,parameter :: usempi=.true.
integer :: debug_level, debug_unit
character(len=20) :: name
info = 0
name='psi_inter_desc_index'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = psb_cd_get_context(desc)
icomm = psb_cd_get_mpic(desc)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
call psb_errpush(info,name)
goto 9999
endif
if (debug_level >= psb_debug_inner_) then
write(debug_unit,*) me,' ',trim(name),': start'
call psb_barrier(ictxt)
endif
!
! first, find out the sizes to be exchanged.
! note: things marked here as sndbuf/rcvbuf (for mpi) corresponds to things
! to be received/sent (in the final psblas descriptor).
! be careful of the inversion
!
allocate(sdsz(np),rvsz(np),bsdindx(np),brvindx(np),stat=info)
if(info /= 0) then
info=4000
call psb_errpush(info,name)
goto 9999
end if
sdsz(:) = 0
rvsz(:) = 0
bsdindx(:) = 0
brvindx(:) = 0
i = 1
do
if (index_in(i) == -1) exit
proc = index_in(i)
i = i + 1
nerv = index_in(i)
sdsz(proc+1) = sdsz(proc+1) + nerv
i = i + nerv + 1
end do
ihinsz=i
call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mpi_alltoall')
goto 9999
end if
i = 1
idxs = 0
idxr = 0
do i=1, length_dl
proc = dep_list(i)
bsdindx(proc+1) = idxs
idxs = idxs + sdsz(proc+1)
brvindx(proc+1) = idxr
idxr = idxr + rvsz(proc+1)
end do
iszs = sum(sdsz)
iszr = sum(rvsz)
nsnd = iszr
nrcv = iszs
if ((iszs /= idxs).or.(iszr /= idxr)) then
write(0,*) 'strange results?', iszs,idxs,iszr,idxr
end if
if (debug_level >= psb_debug_inner_) then
write(debug_unit,*) me,' ',trim(name),': computed sizes ',iszr,iszs
call psb_barrier(ictxt)
endif
ntot = (3*(count((sdsz>0).or.(rvsz>0)))+ iszs + iszr) + 1
if (allocated(desc_index)) then
nidx = size(desc_index)
else
nidx = 0
endif
if (nidx < ntot) then
call psb_realloc(ntot,desc_index,info)
endif
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_realloc')
goto 9999
end if
if (debug_level >= psb_debug_inner_) then
write(debug_unit,*) me,' ',trim(name),': computed allocated workspace ',iszr,iszs
call psb_barrier(ictxt)
endif
allocate(sndbuf(iszs),rcvbuf(iszr),stat=info)
if(info /= 0) then
info=4000
call psb_errpush(info,name)
goto 9999
end if
!
! Second build the lists of requests
!
i = 1
do
if (i > ihinsz) then
write(0,*) me,' did not find index_in end??? ',i,ihinsz
exit
end if
if (index_in(i) == -1) exit
proc = index_in(i)
i = i + 1
nerv = index_in(i)
!
! note that here bsdinx is zero-based, hence the following loop
!
if (isglob_in) then
do j=1, nerv
sndbuf(bsdindx(proc+1)+j) = (index_in(i+j))
end do
else
do j=1, nerv
sndbuf(bsdindx(proc+1)+j) = desc%loc_to_glob(index_in(i+j))
end do
endif
bsdindx(proc+1) = bsdindx(proc+1) + nerv
i = i + nerv + 1
end do
if (debug_level >= psb_debug_inner_) then
write(debug_unit,*) me,' ',trim(name),': prepared send buffer '
call psb_barrier(ictxt)
endif
!
! now have to regenerate bsdindx
!
idxs = 0
idxr = 0
do i=1, length_dl
proc = dep_list(i)
bsdindx(proc+1) = idxs
idxs = idxs + sdsz(proc+1)
brvindx(proc+1) = idxr
idxr = idxr + rvsz(proc+1)
end do
call mpi_alltoallv(sndbuf,sdsz,bsdindx,mpi_integer,&
& rcvbuf,rvsz,brvindx,mpi_integer,icomm,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mpi_alltoallv')
goto 9999
end if
!
! at this point we can finally build the output desc_index. beware
! of snd/rcv inversion.
!
i = 1
do k = 1, length_dl
proc = dep_list(k)
desc_index(i) = proc
i = i + 1
nerv = sdsz(proc+1)
desc_index(i) = nerv
call psi_idx_cnv(nerv,sndbuf(bsdindx(proc+1)+1:bsdindx(proc+1)+nerv),&
& desc_index(i+1:i+nerv),desc,info)
i = i + nerv + 1
nesd = rvsz(proc+1)
desc_index(i) = nesd
call psi_idx_cnv(nesd,rcvbuf(brvindx(proc+1)+1:brvindx(proc+1)+nesd),&
& desc_index(i+1:i+nesd),desc,info)
i = i + nesd + 1
end do
desc_index(i) = - 1
deallocate(sdsz,rvsz,bsdindx,brvindx,sndbuf,rcvbuf,stat=info)
if (info /= 0) then
info=4000
call psb_errpush(info,name)
goto 9999
end if
if (debug_level >= psb_debug_inner_) then
write(debug_unit,*) me,' ',trim(name),': done'
call psb_barrier(ictxt)
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
end subroutine psi_inter_desc_index
base/internals/psi_ldsc_pre_halo.f90
+10
View File
@@ -93,6 +93,16 @@ subroutine psi_ldsc_pre_halo(desc,ext_hv,info)
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
! We no longer need the desc%hash structure.
if (associated(desc%hash)) then
deallocate(desc%hash,stat=info)
if (info /= 0) then
ch_err='psi_bld_tmphalo'
info = 4010
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
if (.not.ext_hv) then
call psi_bld_tmphalo(desc,info)
if (info /= 0) then
base/modules/Makefile
+4 -4
View File
@@ -2,12 +2,11 @@ include ../../Make.inc
MODULES = psb_realloc_mod.o psb_string_mod.o psb_spmat_type.o \
psb_desc_type.o psb_spsb_mod.o psb_sort_mod.o\
psb_serial_mod.o psb_tools_mod.o psb_blacs_mod.o psb_avl_mod.o\
psb_serial_mod.o psb_tools_mod.o psb_blacs_mod.o \
psb_error_mod.o psb_const_mod.o psb_inter_desc_type.o \
psb_comm_mod.o psb_psblas_mod.o psi_serial_mod.o psi_mod.o \
psb_check_mod.o psb_gps_mod.o psb_inter_desc_mod.o
psb_check_mod.o psb_gps_mod.o psb_inter_desc_mod.o psb_hash_mod.o
# psb_methd_mod.o psb_prec_type.o psb_prec_mod.o blacs_env.o
LIBMOD=psb_base_mod$(.mod)
MPFOBJS=psb_penv_mod.o
@@ -30,7 +29,7 @@ psb_penv_mod.o: psb_const_mod.o psb_error_mod.o psb_realloc_mod.o psb_blacs_mod.
psb_blacs_mod.o: psb_const_mod.o
psi_serial_mod.o: psb_const_mod.o psb_realloc_mod.o
psi_mod.o: psb_penv_mod.o psb_error_mod.o psb_desc_type.o psb_const_mod.o psi_serial_mod.o
psb_desc_type.o: psb_const_mod.o psb_error_mod.o psb_penv_mod.o psb_realloc_mod.o psb_avl_mod.o
psb_desc_type.o: psb_const_mod.o psb_error_mod.o psb_penv_mod.o psb_realloc_mod.o psb_hash_mod.o
psb_inter_desc_type.o: psb_desc_type.o psb_spmat_type.o psb_error_mod.o psb_serial_mod.o psb_comm_mod.o
psb_inter_desc_mod.o: psb_inter_desc_type.o
psb_check_mod.o: psb_desc_type.o
@@ -39,6 +38,7 @@ psb_sort_mod.o: psb_error_mod.o psb_realloc_mod.o psb_const_mod.o
psb_methd_mod.o: psb_serial_mod.o psb_desc_type.o psb_prec_type.o
psb_tools_mod.o: psb_spmat_type.o psb_desc_type.o psi_mod.o psb_gps_mod.o psb_inter_desc_mod.o
psb_gps_mod.o: psb_realloc_mod.o
psb_hash_mod.o: psb_const_mod.o psb_realloc_mod.o
psb_base_mod.o: $(MODULES)
base/modules/psb_avl_mod.f90
-617
View File
@@ -1,617 +0,0 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
module psb_item_mod
type psb_item_int2
integer :: key, val
end type psb_item_int2
interface psb_sizeof
module procedure psb_item_int2_size
end interface
contains
function psb_item_int2_size(node)
use psb_const_mod
type(psb_item_int2) :: node
psb_item_int2_size = psb_sizeof_int * 2
end function psb_item_int2_size
subroutine psb_print_item_key_val(iout,item)
integer, intent(in) :: iout
type(psb_item_int2), intent(in) :: item
write(iout,*) 'Value: ',item%key,item%val
end subroutine psb_print_item_key_val
end module psb_item_mod
module psb_avl_mod
use psb_item_mod
integer, parameter :: LeftHigh = -1, EqualHeight=0, RightHigh=1
integer, parameter :: AVLTreeDuplicate = -123, AVLTreeOK=0, &
& AVLTreeOutOfMemory=-512, AVLTreeFatalError=-1024
integer :: level,outlev
integer, parameter :: poolsize = 1024
type psb_treenode_int2
type(psb_item_int2) :: item
type(psb_treenode_int2), pointer :: left=>null(), right=>null()
integer :: balance
end type psb_treenode_int2
type psb_treevect_int2
type(psb_treenode_int2) :: pool(poolsize)
integer :: avail
type(psb_treevect_int2), pointer :: next=>null(), prev=>null()
end type psb_treevect_int2
type psb_tree_int2
type(psb_treevect_int2), pointer :: head=>null(), current=>null()
type(psb_treenode_int2), pointer :: root=>null()
integer :: nnodes
end type psb_tree_int2
interface psb_sizeof
module procedure psb_Sizeof_Tree_int2, psb_sizeof_node_int2
end interface
interface InitSearchTree
module procedure InitSearchTree_int2
end interface
interface FreeSearchTree
module procedure FreeSearchTree_int2
end interface
interface SearchKey
module procedure SearchKey_int2
end interface
interface SearchInsKey
module procedure SearchInsKey_int2
end interface
interface GetAVLTree
module procedure GetAVLTree_int2
end interface
interface CloneSearchTree
module procedure CloneSearchTree_int2
end interface
interface CloneAVLTree
module procedure CloneAVLTree_int2
end interface
interface GetAVLNode
module procedure GetAVLNode_int2
end interface
interface UnGetAVLNode
module procedure UnGetAVLNode_int2
end interface
interface VisitAVLTree
module procedure VisitAVLTree_int2, VisitAVLTreeNode_int2
end interface
interface VisitAVLTreeLev
module procedure VisitAVLTreeLev_int2, VisitAVLTreeNodeLev_int2
end interface
interface AVLTreeLeftBalance
module procedure AVLTreeLeftBalance_int2
end interface
interface AVLTreeRightBalance
module procedure AVLTreeRightBalance_int2
end interface
interface AVLTreeRotateLeft
module procedure AVLTreeRotateLeft_int2
end interface
interface AVLTreeRotateRight
module procedure AVLTreeRotateRight_int2
end interface
interface AVLSearchKey
module procedure AVLSearchKey_int2
end interface
interface AVLSearchInsKey
module procedure AVLSearchInsKey_int2
end interface
interface AVLSearchInsNode
module procedure AVLSearchInsNode_int2
end interface
contains
subroutine InitSearchTree_int2(tree, info)
type(psb_tree_int2), pointer :: tree
integer :: info
if (associated(tree)) then
call FreeSearchTree(tree,info)
end if
call GetAVLTree(tree,info)
end subroutine InitSearchTree_int2
subroutine CloneSearchTree_int2(treein, treeout)
type(psb_tree_int2), pointer :: treein,treeout
integer :: info
if (.not.associated(treein)) then
treeout => null()
return
endif
call GetAVLTree(treeout,info)
call CloneAVLTree(treein%root,treeout)
end subroutine CloneSearchTree_int2
recursive subroutine CloneAVLTree_int2(root, tree)
type(psb_treenode_int2), pointer :: root
type(psb_tree_int2), pointer :: tree
integer :: info, key,val,next
if (.not.associated(root)) return
key = root%item%key
next = root%item%val
call SearchInsKey(tree,key,val,next,info)
call CloneAVLTree(root%left,tree)
call CloneAVLTree(root%right,tree)
end subroutine CloneAVLTree_int2
subroutine FreeSearchTree_int2(tree, info)
type(psb_tree_int2), pointer :: tree
integer :: info
type(psb_treevect_int2), pointer :: current,next
if (.not.associated(tree)) return
current => tree%head
do
if (.not.associated(current)) exit
next => current%next
deallocate(current,stat=info)
if (info /= 0) then
info = AVLTreeFatalError
return
end if
current => next
end do
deallocate(tree,stat=info)
if (info /= 0) then
info = AVLTreeFatalError
return
end if
end subroutine FreeSearchTree_int2
function psb_Sizeof_Tree_int2(tree)
use psb_const_mod
type(psb_tree_int2), pointer :: tree
integer :: psb_Sizeof_Tree_int2
integer :: val
type(psb_treevect_int2), pointer :: current,next
val = 0
if (associated(tree)) then
current => tree%head
do
if (.not.associated(current)) exit
val = val + 3*psb_sizeof_int + poolsize*psb_sizeof(current%pool(1))
current => current%next
end do
end if
psb_Sizeof_Tree_int2 = val
end function psb_Sizeof_Tree_int2
function psb_sizeof_node_int2(node)
use psb_const_mod
type(psb_treenode_int2) :: node
integer :: psb_sizeof_node_int2
integer :: val
psb_sizeof_node_int2 = 3*psb_sizeof_int + psb_sizeof(node%item)
end function psb_sizeof_node_int2
subroutine SearchKey_int2(tree,key,val,info)
type(psb_tree_int2), target :: tree
integer :: key,val,info
type(psb_item_int2), pointer :: retval
info = 0
call AVLSearchKey(tree,key,retval,info)
if (associated(retval)) then
val = retval%val
else
val = -1
end if
end subroutine SearchKey_int2
subroutine SearchInsKey_int2(tree,key,val, nextval,info)
type(psb_tree_int2), target :: tree
integer :: key,val,nextval,info
call AVLSearchInsKey(tree,key,val,nextval,info)
end subroutine SearchInsKey_int2
subroutine GetAVLTree_int2(tree, info)
type(psb_tree_int2), pointer :: tree
integer :: info
allocate(tree, stat=info)
if (info == 0) allocate(tree%head,stat=info)
if (info == 0) then
tree%current => tree%head
tree%head%avail = 0
tree%nnodes=0
end if
if (info /= 0) then
write(0,*) 'Failed allocation 1 GetAVLTree '
info = AVLTreeOutOfMemory
return
end if
end subroutine GetAVLTree_int2
subroutine VisitAVLTree_int2(tree, info,iout)
type(psb_tree_int2), pointer :: tree
integer :: info
integer, optional :: iout
info = 0
if (.not.associated(tree)) return
call VisitAVLTree(tree%root,iout)
end subroutine VisitAVLTree_int2
recursive subroutine VisitAVLTreeNode_int2(root,iout)
type(psb_treenode_int2), pointer :: root
integer, optional :: iout
integer :: info
if (.not.associated(root)) return
call VisitAVLTree(root%left,iout)
if (present(iout)) then
call psb_print_item_key_val(iout,root%item)
else
call psb_print_item_key_val(6,root%item)
end if
call VisitAVLTree(root%right,iout)
end subroutine VisitAVLTreeNode_int2
subroutine VisitAVLTreeLev_int2(tree, info)
type(psb_tree_int2), pointer :: tree
integer :: info
if (.not.associated(tree)) return
do outlev = 0, 3
write(6,*) 'Tree level : ',outlev
call VisitAVLTreeLev(tree%root,0)
end do
end subroutine VisitAVLTreeLev_int2
recursive subroutine VisitAVLTreeNodeLev_int2(root,level)
type(psb_treenode_int2), pointer :: root
integer :: info,level
if (.not.associated(root)) return
call VisitAVLTreeLev(root%left,level+1)
if (level == outlev) call psb_print_item_key_val(6,root%item)
call VisitAVLTreeLev(root%right,level+1)
end subroutine VisitAVLTreeNodeLev_int2
function GetAVLNode_int2(tree, info)
type(psb_tree_int2), target :: tree
type(psb_treenode_int2), pointer :: GetAVLNode_int2
integer :: info
type(psb_treevect_int2), pointer :: current, temp
GetAVLNode_int2 => null()
if (.not.associated(tree%current)) then
allocate(tree%head,stat=info)
if (info /= 0) then
info = AVLTreeOutOfMemory
return
end if
tree%current => tree%head
tree%current%avail = 0
end if
current => tree%current
do
if (current%avail < poolsize) exit
if (.not.(associated(current%next))) then
allocate(temp,stat=info)
if (info /= 0) then
info = AVLTreeOutOfMemory
return
end if
temp%avail = 0
temp%prev => current
current%next => temp
end if
current => current%next
end do
tree%current => current
current%avail = current%avail + 1
GetAVLNode_int2 => current%pool(current%avail)
end function GetAVLNode_int2
subroutine UnGetAVLNode_int2(tree, info)
type(psb_tree_int2), target :: tree
integer :: info
if (.not.associated(tree%current)) then
return
end if
if (tree%current%avail > 0) &
& tree%current%avail = tree%current%avail - 1
return
end subroutine UnGetAVLNode_int2
subroutine AVLSearchKey_int2(tree,key,retval,info)
type(psb_tree_int2), target :: tree
integer :: key,info
type(psb_item_int2), pointer :: retval
type(psb_treenode_int2), pointer :: root
retval => null()
root => tree%root
do
if (.not.associated(root)) exit
if (key < root%item%key) then
root => root%left
else if (key == root%item%key) then
retval => root%item
exit
else if (key > root%item%key) then
root => root%right
end if
end do
end subroutine AVLSearchKey_int2
subroutine AVLSearchInsKey_int2(tree,key,val,nextval,info)
type(psb_tree_int2), target :: tree
integer :: key,val,nextval,info
type(psb_treenode_int2), pointer :: itemp
logical :: taller
itemp => GetAVLNode(tree,info)
if (info /=0) then
return
end if
if (.not.associated(itemp)) then
info = -5
return
endif
itemp%item%key = key
itemp%item%val = nextval
itemp%left => null()
itemp%right => null()
call AVLSearchInsNode(tree%root,itemp,taller,info)
val = itemp%item%val
if (info == AVLTreeDuplicate) then
call UnGetAVLNode(tree,info)
!!$ write(0,*) 'From searchInsNode ',key,val,nextval
info = 0
return
else if (info == AVLTreeOK) then
tree%nnodes = tree%nnodes + 1
info = 0
return
else
write(0,*) 'Error from inner SearchInsNode '
endif
end subroutine AVLSearchInsKey_int2
recursive subroutine AVLSearchInsNode_int2(root,node,taller,info)
type(psb_treenode_int2), pointer :: root, node
integer :: info
logical :: taller
info = AVLTreeOK
taller = .false.
if (.not.associated(root)) then
root => node
node%balance = EqualHeight
node%left => null()
node%right => null()
taller = .true.
else if (node%item%key == root%item%key) then
!!$ write(0,*) 'SearchInsNode : found key',node%item%key,node%item%val,&
!!$ &root%item%key,root%item%val
info = AVLTreeDuplicate
node%item%val = root%item%val
return
else if (node%item%key < root%item%key) then
call AVLSearchInsNode(root%left,node,taller,info)
if (info == AVLTreeDuplicate) return
if (info == AVLTreeFatalError) return
if (taller) then
select case(root%balance)
case(LeftHigh)
call AVLTreeLeftBalance(root,taller)
case(EqualHeight)
root%balance = LeftHigh
case(RightHigh)
root%balance = EqualHeight
taller = .false.
case default
info = AVLTreeFatalError
end select
end if
else if (node%item%key > root%item%key) then
call AVLSearchInsNode(root%right,node,taller,info)
if (info == AVLTreeDuplicate) return
if (info == AVLTreeFatalError) return
if (taller) then
select case(root%balance)
case(LeftHigh)
root%balance = EqualHeight
taller = .false.
case(EqualHeight)
root%balance = RightHigh
case(RightHigh)
call AVLTreeRightBalance(root,taller)
case default
info = AVLTreeFatalError
end select
end if
end if
end subroutine AVLSearchInsNode_int2
recursive subroutine AVLTreeLeftBalance_int2(root,taller)
type(psb_treenode_int2), pointer :: root
logical :: taller
type(psb_treenode_int2), pointer :: rs, ls
ls => root%left
select case (ls%balance)
case(LeftHigh)
root%balance = EqualHeight
ls%balance = EqualHeight
call AVLTreeRotateRight(root)
taller = .false.
case(EqualHeight)
write(0,*) 'Warning: balancing and already balanced left tree? '
case(RightHigh)
rs => ls%right
select case(rs%balance)
case(LeftHigh)
root%balance = RightHigh
ls%balance = EqualHeight
case(EqualHeight)
root%balance = EqualHeight
ls%balance = EqualHeight
case(RightHigh)
root%balance = EqualHeight
ls%balance = LeftHigh
end select
rs%balance = EqualHeight
call AVLTreeRotateLeft(root%left)
call AVLTreeRotateRight(root)
taller = .false.
end select
end subroutine AVLTreeLeftBalance_int2
recursive subroutine AVLTreeRightBalance_int2(root,taller)
type(psb_treenode_int2), pointer :: root
logical :: taller
type(psb_treenode_int2), pointer :: rs, ls
rs => root%right
select case (rs%balance)
case(RightHigh)
root%balance = EqualHeight
rs%balance = EqualHeight
call AVLTreeRotateLeft(root)
taller = .false.
case(EqualHeight)
write(0,*) 'Warning: balancing and already balanced right tree? '
case(LeftHigh)
ls => rs%left
select case(ls%balance)
case(RightHigh)
root%balance = LeftHigh
rs%balance = EqualHeight
case(EqualHeight)
root%balance = EqualHeight
rs%balance = EqualHeight
case(LeftHigh)
root%balance = EqualHeight
rs%balance = RightHigh
end select
ls%balance = EqualHeight
call AVLTreeRotateRight(root%right)
call AVLTreeRotateLeft(root)
taller = .false.
end select
end subroutine AVLTreeRightBalance_int2
subroutine AVLTreeRotateLeft_int2(root)
type(psb_treenode_int2), pointer :: root
type(psb_treenode_int2), pointer :: temp
if (.not.associated(root)) then
return
endif
if (.not.associated(root%right)) then
return
endif
temp => root%right
root%right => temp%left
temp%left => root
root => temp
end subroutine AVLTreeRotateLeft_int2
subroutine AVLTreeRotateRight_int2(root)
type(psb_treenode_int2), pointer :: root
type(psb_treenode_int2), pointer :: temp
if (.not.associated(root)) then
return
endif
if (.not.associated(root%left)) then
return
endif
temp => root%left
root%left => temp%right
temp%right => root
root => temp
end subroutine AVLTreeRotateRight_int2
end module psb_avl_mod
base/modules/psb_const_mod.f90
+8 -4
View File
@@ -31,13 +31,17 @@
!!$
module psb_const_mod
! This should be integer(8), and normally different from default integer.
integer, parameter :: longndig=12
integer, parameter :: psb_long_int_k_ = selected_int_kind(longndig)
!
! This must be the kind parameter corresponding to MPI_DOUBLE_PRECISION
! These must be the kind parameter corresponding to MPI_DOUBLE_PRECISION
! and MPI_REAL
!
integer, parameter :: psb_dpk_ = kind(1.d0)
integer, parameter :: psb_spk_ = kind(1.e0)
integer :: psb_sizeof_dp, psb_sizeof_int, psb_sizeof_sp
integer, parameter :: psb_dpk_ = kind(1.d0)
integer, parameter :: psb_spk_ = kind(1.e0)
integer :: psb_sizeof_dp, psb_sizeof_sp
integer :: psb_sizeof_int, psb_sizeof_long_int
!
! Handy & miscellaneous constants
base/modules/psb_desc_type.f90
+33 -103
View File
@@ -37,7 +37,7 @@
module psb_descriptor_type
use psb_const_mod
use psb_avl_mod
use psb_hash_mod
implicit none
@@ -102,9 +102,10 @@ module psb_descriptor_type
!
! Constants for hashing into desc%hashv(:) and desc%glb_lc(:,:)
!
integer, parameter :: psb_hash_bits=14
integer, parameter :: psb_hash_bits=16
integer, parameter :: psb_max_hash_bits=22
integer, parameter :: psb_hash_size=2**psb_hash_bits, psb_hash_mask=psb_hash_size-1
integer, parameter :: psb_default_large_threshold=512*1024 ! to be reviewed
integer, parameter :: psb_default_large_threshold=1*1024*1024
integer, parameter :: psb_hpnt_nentries_=7
!
@@ -136,6 +137,8 @@ module psb_descriptor_type
!| integer, allocatable :: hashv(:), glb_lc(:,:)
!| integer, allocatable :: lprm(:)
!| integer, allocatable :: idx_space(:)
!| type(psb_hash_type), pointer :: hash => null()
!| type(psb_desc_type), pointer :: base_desc => null()
!| end type psb_desc_type
!
!
@@ -193,17 +196,23 @@ module psb_descriptor_type
! will thus be N_COL + N_GLOB
! ii. If the global index space is very large (larger than the threshold value
! which may be set by the user), then it is not advisable to have such an
! array. In this case we only record the global indices that do have a
! array.
! In this case we only record the global indices that do have a
! local counterpart, so that the local storage will be proportional to
! N_COL. During the build phase we keep the known global indices in an
! AVL tree data structure whose pointer is stored in avltree, so that we
! can do both search and insertions in log time. At assembly time, we move
! the information into hashv(:) and glb_lc(:,:). The idea is that
! glb_lc(:,1) will hold sorted global indices, and glb_lc(:,2) the
! corresponding local indices, so that we may do a binary search. To cut down
! the search time we partition glb_lc into a set of lists addressed by
! hashv(:) based on the value of the lowest PSB_HASH_BITS bits of the
! global index.
! N_COL.
! The idea is that glb_lc(:,1) will hold sorted global indices, and
! glb_lc(:,2) the corresponding local indices, so that we may do a binary search.
! To cut down the search time we partition glb_lc into a set of lists
! addressed by hashv(:) based on the value of the lowest
! PSB_HASH_BITS bits of the global index.
! During the build phase glb_lc() will store the indices of the internal points,
! i.e. local indices 1:NROW, since those are known ad CDALL time.
! The halo indices that we encounter during the build phase are put in
! a PSB_HASH_TYPE data structure, which implements a very simple hash, which will
! nonetheless be quite fast at low occupancy rates.
! At assembly time, we move everything into hashv(:) and glb_lc(:,:).
! Note that the desc%hash component is a pointer, but it really should be
! an allocatable scalar.
!
! 7. The data exchange is based on lists of local indices to be exchanged; all the
! lists have the same format, as follows:
@@ -303,11 +312,12 @@ module psb_descriptor_type
integer, allocatable :: bnd_elem(:)
integer, allocatable :: loc_to_glob(:)
integer, allocatable :: glob_to_loc (:)
integer :: hashvsize, hashvmask
integer, allocatable :: hashv(:), glb_lc(:,:)
type(psb_tree_int2), pointer :: avltree => null()
integer, allocatable :: lprm(:)
integer, allocatable :: idx_space(:)
type(psb_desc_type), pointer :: base_desc => null()
type(psb_hash_type), pointer :: hash => null()
type(psb_desc_type), pointer :: base_desc => null()
end type psb_desc_type
interface psb_sizeof
@@ -354,15 +364,12 @@ module psb_descriptor_type
contains
function psb_cd_sizeof(desc)
function psb_cd_sizeof(desc) result(val)
implicit none
!....Parameters...
Type(psb_desc_type), intent(in) :: desc
Integer :: psb_cd_sizeof
!locals
integer :: val
integer, external :: SizeofPairSearchTree
integer(psb_long_int_k_) :: val
val = 0
if (allocated(desc%matrix_data)) val = val + psb_sizeof_int*size(desc%matrix_data)
@@ -378,9 +385,8 @@ contains
if (allocated(desc%glb_lc)) val = val + psb_sizeof_int*size(desc%glb_lc)
if (allocated(desc%lprm)) val = val + psb_sizeof_int*size(desc%lprm)
if (allocated(desc%idx_space)) val = val + psb_sizeof_int*size(desc%idx_space)
if (associated(desc%avltree)) val = val + psb_sizeof(desc%avltree)
if (associated(desc%hash)) val = val + psb_sizeof(desc%hash)
psb_cd_sizeof = val
end function psb_cd_sizeof
@@ -419,7 +425,7 @@ contains
type(psb_desc_type), intent(inout) :: desc
! We have nothing left to do here.
! Perhaps we should delete this subroutine?
nullify(desc%avltree,desc%base_desc)
nullify(desc%hash,desc%base_desc)
end subroutine psb_nullify_desc
@@ -481,7 +487,7 @@ contains
psb_is_ok_dec = ((dectype == psb_desc_asb_).or.(dectype == psb_desc_bld_).or.&
&(dectype == psb_cd_ovl_asb_).or.(dectype == psb_cd_ovl_bld_).or.&
&(dectype == psb_desc_upd_).or.&
&(dectype== psb_desc_repl_))
&(dectype == psb_desc_repl_))
end function psb_is_ok_dec
logical function psb_is_bld_dec(dectype)
@@ -619,70 +625,6 @@ contains
end function psb_cd_get_mpic
subroutine psb_cd_set_bld(desc,info)
!
! Change state of a descriptor into BUILD.
! If the descriptor is LARGE, check the AVL search tree
! and initialize it if necessary.
!
use psb_const_mod
use psb_error_mod
use psb_penv_mod
implicit none
type(psb_desc_type), intent(inout) :: desc
integer :: info
!locals
integer :: np,me,ictxt, err_act,idx,gidx,lidx
logical, parameter :: debug=.false.,debugprt=.false.
character(len=20) :: name
if (debug) write(0,*) me,'Entered CDCPY'
if (psb_get_errstatus() /= 0) return
info = 0
call psb_erractionsave(err_act)
name = 'psb_cd_set_bld'
ictxt = psb_cd_get_context(desc)
if (debug) write(0,*)'Entered CDSETBLD',ictxt
! check on blacs grid
call psb_info(ictxt, me, np)
if (debug) write(0,*) me,'Entered CDSETBLD'
if (psb_is_asb_desc(desc)) then
!!$ write(0,*) 'Warning: doing setbld on an assembled descriptor'
end if
if (psb_is_large_desc(desc)) then
if (debug) write(0,*) me,'SET_BLD: alocating avltree'
if (.not.associated(desc%avltree)) then
call InitSearchTree(desc%avltree,info)
do idx=1, psb_cd_get_local_cols(desc)
gidx = desc%loc_to_glob(idx)
call SearchInsKey(desc%avltree,gidx,lidx,idx,info)
if (lidx /= idx) then
write(0,*) 'Warning from cdset: mismatch in AVLTREE ',idx,lidx
endif
enddo
end if
end if
desc%matrix_data(psb_dec_type_) = psb_desc_bld_
if (debug) write(0,*) me,'SET_BLD: done'
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_cd_set_bld
subroutine psb_cd_set_ovl_asb(desc,info)
!
! Change state of a descriptor into ovl_build.
@@ -695,18 +637,6 @@ contains
end subroutine psb_cd_set_ovl_asb
subroutine psb_cd_set_ovl_bld(desc,info)
!
! Change state of a descriptor into ovl_build.
implicit none
type(psb_desc_type), intent(inout) :: desc
integer :: info
call psb_cd_set_bld(desc,info)
if (info == 0) desc%matrix_data(psb_dec_type_) = psb_cd_ovl_bld_
end subroutine psb_cd_set_ovl_bld
subroutine psb_get_xch_idx(idx,totxch,totsnd,totrcv)
implicit none
@@ -961,8 +891,8 @@ contains
end if
end if
if (associated(desc_a%avltree)) then
call FreeSearchTree(desc_a%avltree,info)
if (associated(desc_a%hash)) then
deallocate(desc_a%hash,stat=info)
if (info /= 0) then
info=2060
call psb_errpush(info,name)
@@ -1071,7 +1001,7 @@ contains
if (info == 0) &
& call psb_transfer( desc_in%glb_lc , desc_out%glb_lc , info)
desc_out%avltree => desc_in%avltree; nullify(desc_in%avltree)
desc_out%hash => desc_in%hash; nullify(desc_in%hash)
if (info /= 0) then
info = 4010
base/modules/psb_hash_mod.f90
+340
View File
@@ -0,0 +1,340 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
!
! package: psb_hash_mod
!
! This module implements a very simple minded hash table.
! The hash is based on the idea of open addressing with double hashing;
! the primary hash function h1(K) is simply the remainder modulo 2^N, while
! the secondary hash function is 1 if H1(k) == 0, otherwise IOR((2^N-H1(k)),1)
! (See Knuth: TAOCP, Vol. 3, sec. 6.4)
! These hash functions are not very smart; however they are very simple and fast.
! The intended usage of this hash table is to store indices of halo points, which
! are supposed to be few compared to the internal indices
! (which are stored elsewhere), so in this context they are acceptable.
!
!
!
module psb_hash_mod
use psb_const_mod
!
! For us a hash is a Nx2 table.
! Note: we are assuming that the keys are positive numbers.
! Allocatable scalars would be a nice solution...
!
type psb_hash_type
integer :: nbits, hsize, hmask, nk
integer, allocatable :: table(:,:)
integer(psb_long_int_k_) :: nsrch, nacc
end type psb_hash_type
integer, parameter :: HashDuplicate = 123, HashOK=0, HashOutOfMemory=-512,&
& HashFreeEntry = -1, HashNotFound = -256
interface psb_hash_init
module procedure psb_hash_init_v, psb_hash_init_n
end interface
interface psb_sizeof
module procedure psb_sizeof_hash_type
end interface
contains
function hashval(key) result(val)
integer, intent(in) :: key
integer, parameter :: ival=5381, mask=2147483647
integer :: key_, val, i
key_ = key
val = ival
do i=1, 4
val = val * 33 + iand(key_,255)
key_ = ishft(key_,-8)
end do
val = val + ishft(val,-5)
val = iand(val,mask)
end function hashval
function psb_Sizeof_hash_type(hash) result(val)
type(psb_hash_type), pointer :: hash
integer(psb_long_int_k_) :: val
val = 0
if (associated(hash)) then
val = val + psb_sizeof_int * size(hash%table)
end if
end function psb_Sizeof_hash_type
function psb_hash_avg_acc(hash)
type(psb_hash_type), intent(in) :: hash
real(psb_dpk_) :: psb_hash_avg_acc
psb_hash_avg_acc = dble(hash%nacc)/dble(hash%nsrch)
end function psb_hash_avg_acc
subroutine HashTransfer(hashin,hashout,info)
use psb_realloc_mod
type(psb_hash_type) :: hashin
type(psb_hash_type) :: hashout
integer, intent(out) :: info
info = HashOk
hashout%nbits = hashin%nbits
hashout%hsize = hashin%hsize
hashout%hmask = hashin%hmask
hashout%nk = hashin%nk
hashout%nsrch = hashin%nsrch
hashout%nacc = hashin%nacc
call psb_transfer(hashin%table, hashout%table,info)
end subroutine HashTransfer
subroutine HashCopy(hashin,hashout,info)
use psb_realloc_mod
type(psb_hash_type) :: hashin
type(psb_hash_type) :: hashout
integer, intent(out) :: info
info = HashOk
hashout%nbits = hashin%nbits
hashout%hsize = hashin%hsize
hashout%hmask = hashin%hmask
hashout%nk = hashin%nk
hashout%nsrch = hashin%nsrch
hashout%nacc = hashin%nacc
call psb_safe_ab_cpy(hashin%table, hashout%table,info)
end subroutine HashCopy
subroutine CloneHashTable(hashin,hashout,info)
type(psb_hash_type), pointer :: hashin
type(psb_hash_type), pointer :: hashout
integer, intent(out) :: info
if (associated(hashout)) then
deallocate(hashout,stat=info)
!if (info /= 0) return
end if
if (associated(hashin)) then
allocate(hashout,stat=info)
if (info /= 0) return
call HashCopy(hashin,hashout,info)
end if
end subroutine CloneHashTable
subroutine psb_hash_init_V(v,hash,info)
integer, intent(in) :: v(:)
type(psb_hash_type), intent(out) :: hash
integer, intent(out) :: info
integer :: i,j,k,hsize,nbits, nv
info = 0
nv = size(v)
call psb_hash_init(nv,hash,info)
if (info /= 0) return
do i=1,nv
call psb_hash_searchinskey(v(i),j,i,hash,info)
if ((j /= i).or.(info /= HashOK)) then
write(0,*) 'Error from hash_ins',i,v(i),j,info
info = HashNotFound
return
end if
end do
end subroutine psb_hash_init_V
subroutine psb_hash_init_n(nv,hash,info)
integer, intent(in) :: nv
type(psb_hash_type), intent(out) :: hash
integer, intent(out) :: info
integer :: i,j,k,hsize,nbits
info = 0
nbits = 12
hsize = 2**nbits
!
! Figure out the smallest power of 2 bigger than NV
!
do
if (hsize < 0) then
write(0,*) 'Error: hash size overflow ',hsize,nbits
info = -2
return
end if
if (hsize > nv) exit
nbits = nbits + 1
hsize = hsize * 2
end do
hash%nbits = nbits
hash%hsize = hsize
hash%hmask = hsize-1
hash%nsrch = 0
hash%nacc = 0
allocate(hash%table(0:hsize-1,2),stat=info)
if (info /= 0) then
write(0,*) 'Error: memory allocation failure ',hsize
info = HashOutOfMemory
return
end if
hash%table = HashFreeEntry
hash%nk = 0
end subroutine psb_hash_init_n
subroutine psb_hash_realloc(hash,info)
type(psb_hash_type), intent(inout) :: hash
integer, intent(out) :: info
type(psb_hash_type) :: nhash
integer :: nk, key, val, nextval,i
info = HashOk
call psb_hash_init((hash%hsize+1),nhash,info)
if (info /= HashOk) then
info = HashOutOfMemory
return
endif
do i=0, hash%hsize-1
key = hash%table(i,1)
nextval = hash%table(i,2)
if (key /= HashFreeEntry) then
call psb_hash_searchinskey(key,val,nextval,nhash,info)
if (info /= 0) then
info = HashOutOfMemory
return
end if
end if
end do
call HashTransfer(nhash,hash,info)
end subroutine psb_hash_realloc
recursive subroutine psb_hash_searchinskey(key,val,nextval,hash,info)
integer, intent(in) :: key,nextval
type(psb_hash_type) :: hash
integer, intent(out) :: val, info
integer :: i,j,k,hsize,hmask, hk, hd
info = HashOK
hsize = hash%hsize
hmask = hash%hmask
hk = iand(hashval(key),hmask)
if (hk == 0) then
hd = 1
else
hd = hsize - hk
hd = ior(hd,1)
end if
hash%nsrch = hash%nsrch + 1
do
hash%nacc = hash%nacc + 1
if (hash%table(hk,1) == key) then
val = hash%table(hk,2)
info = HashDuplicate
return
end if
if (hash%table(hk,1) == HashFreeEntry) then
if (hash%nk == hash%hsize -1) then
!
! Note: because of the way we allocate things at CDALL
! time this is really unlikely; if we get here, we
! have at least as many halo indices as internals, which
! means we're already in trouble. But we try to keep going.
!
call psb_hash_realloc(hash,info)
if (info /= HashOk) then
info = HashOutOfMemory
return
else
call psb_hash_searchinskey(key,val,nextval,hash,info)
return
end if
else
hash%nk = hash%nk + 1
hash%table(hk,1) = key
hash%table(hk,2) = nextval
val = nextval
return
end if
end if
hk = hk - hd
if (hk < 0) hk = hk + hsize
end do
end subroutine psb_hash_searchinskey
subroutine psb_hash_searchkey(key,val,hash,info)
integer, intent(in) :: key
type(psb_hash_type) :: hash
integer, intent(out) :: val, info
integer :: i,j,k,hsize,hmask, hk, hd
info = HashOK
hsize = hash%hsize
hmask = hash%hmask
hk = iand(hashval(key),hmask)
if (hk == 0) then
hd = 1
else
hd = hsize - hk
hd = ior(hd,1)
end if
hash%nsrch = hash%nsrch + 1
do
hash%nacc = hash%nacc + 1
if (hash%table(hk,1) == key) then
val = hash%table(hk,2)
return
end if
if (hash%table(hk,1) == HashFreeEntry) then
val = HashFreeEntry
!!$ info = HashNotFound
return
end if
hk = hk - hd
if (hk < 0) hk = hk + hsize
end do
end subroutine psb_hash_searchkey
end module psb_hash_mod
base/modules/psb_inter_desc_mod.f90
+19 -29
View File
@@ -365,76 +365,66 @@ contains
end function psb_is_ok_inter_desc
function psb_s_map_sizeof(map)
function psb_s_map_sizeof(map) result(val)
implicit none
type(psb_s_map_type), intent(in) :: map
Integer :: psb_s_map_sizeof
integer :: val
integer(psb_long_int_k_) :: val
val = 0
val = val + psb_sizeof(map%map_fw)
val = val + psb_sizeof(map%map_bk)
psb_s_map_sizeof = val
end function psb_s_map_sizeof
function psb_d_map_sizeof(map)
function psb_d_map_sizeof(map) result(val)
implicit none
type(psb_d_map_type), intent(in) :: map
Integer :: psb_d_map_sizeof
integer :: val
integer(psb_long_int_k_) :: val
val = 0
val = val + psb_sizeof(map%map_fw)
val = val + psb_sizeof(map%map_bk)
psb_d_map_sizeof = val
end function psb_d_map_sizeof
function psb_c_map_sizeof(map)
function psb_c_map_sizeof(map) result(val)
implicit none
type(psb_c_map_type), intent(in) :: map
Integer :: psb_c_map_sizeof
integer :: val
integer(psb_long_int_k_) :: val
val = 0
val = val + psb_sizeof(map%map_fw)
val = val + psb_sizeof(map%map_bk)
psb_c_map_sizeof = val
end function psb_c_map_sizeof
function psb_z_map_sizeof(map)
function psb_z_map_sizeof(map) result(val)
implicit none
type(psb_z_map_type), intent(in) :: map
Integer :: psb_z_map_sizeof
integer :: val
integer(psb_long_int_k_) :: val
val = 0
val = val + psb_sizeof(map%map_fw)
val = val + psb_sizeof(map%map_bk)
psb_z_map_sizeof = val
end function psb_z_map_sizeof
function psb_itd_sizeof(desc)
function psb_itd_sizeof(desc) result(val)
implicit none
type(psb_inter_desc_type), intent(in) :: desc
Integer :: psb_itd_sizeof
integer :: val
integer(psb_long_int_k_) :: val
val = 0
if (allocated(desc%itd_data)) val = val + 4*size(desc%itd_data)
if (allocated(desc%exch_fw_idx)) val = val + 4*size(desc%exch_fw_idx)
if (allocated(desc%exch_bk_idx)) val = val + 4*size(desc%exch_bk_idx)
if (allocated(desc%itd_data)) val = val + psb_sizeof_int*size(desc%itd_data)
if (allocated(desc%exch_fw_idx)) val = val + psb_sizeof_int*size(desc%exch_fw_idx)
if (allocated(desc%exch_bk_idx)) val = val + psb_sizeof_int*size(desc%exch_bk_idx)
val = val + psb_sizeof(desc%desc_fw)
val = val + psb_sizeof(desc%desc_bk)
val = val + psb_sizeof(desc%dmap)
val = val + psb_sizeof(desc%zmap)
psb_itd_sizeof = val
end function psb_itd_sizeof
!!$
base/modules/psb_penv_mod.F90
+219
View File
@@ -100,6 +100,7 @@ module psb_penv_mod
interface psb_max
module procedure psb_imaxs, psb_imaxv, psb_imaxm,&
& psb_i8maxs, &
& psb_smaxs, psb_smaxv, psb_smaxm,&
& psb_dmaxs, psb_dmaxv, psb_dmaxm
end interface
@@ -107,6 +108,7 @@ module psb_penv_mod
interface psb_min
module procedure psb_imins, psb_iminv, psb_iminm,&
& psb_i8mins, &
& psb_smins, psb_sminv, psb_sminm,&
& psb_dmins, psb_dminv, psb_dminm
end interface
@@ -114,6 +116,7 @@ module psb_penv_mod
interface psb_amx
module procedure psb_iamxs, psb_iamxv, psb_iamxm,&
& psb_i8amxs, &
& psb_samxs, psb_samxv, psb_samxm,&
& psb_camxs, psb_camxv, psb_camxm,&
& psb_damxs, psb_damxv, psb_damxm,&
@@ -122,6 +125,7 @@ module psb_penv_mod
interface psb_amn
module procedure psb_iamns, psb_iamnv, psb_iamnm,&
& psb_i8amns, &
& psb_samns, psb_samnv, psb_samnm,&
& psb_camns, psb_camnv, psb_camnm,&
& psb_damns, psb_damnv, psb_damnm,&
@@ -130,6 +134,7 @@ module psb_penv_mod
interface psb_sum
module procedure psb_isums, psb_isumv, psb_isumm,&
& psb_i8sums, &
& psb_ssums, psb_ssumv, psb_ssumm,&
& psb_csums, psb_csumv, psb_csumm,&
& psb_dsums, psb_dsumv, psb_dsumm,&
@@ -162,10 +167,12 @@ contains
real(psb_dpk_) :: dv(2)
real(psb_spk_) :: sv(2)
integer :: iv(2)
integer(psb_long_int_k_) :: ilv(2)
call psi_c_diffadd(sv(1),sv(2),psb_sizeof_sp)
call psi_c_diffadd(dv(1),dv(2),psb_sizeof_dp)
call psi_c_diffadd(iv(1),iv(2),psb_sizeof_int)
call psi_c_diffadd(ilv(1),ilv(2),psb_sizeof_long_int)
end subroutine psi_get_sizes
@@ -1147,6 +1154,7 @@ contains
endif
#endif
end subroutine psb_imins
subroutine psb_iminv(ictxt,dat,root)
use psb_realloc_mod
#ifdef MPI_MOD
@@ -2323,6 +2331,217 @@ contains
subroutine psb_i8sums(ictxt,dat,root)
#ifdef MPI_MOD
use mpi
#endif
#ifdef MPI_H
include 'mpif.h'
#endif
integer, intent(in) :: ictxt
integer(psb_long_int_k_), intent(inout) :: dat
integer, intent(in), optional :: root
integer :: mpi_int8_type, info, icomm
integer :: root_, iam, np
integer(psb_long_int_k_) :: dat_
if (present(root)) then
root_ = root
else
root_ = -1
endif
call psb_info(ictxt,iam,np)
call psb_get_mpicomm(ictxt,icomm)
mpi_int8_type = mpi_integer8
if (root_ == -1) then
dat_=dat
call mpi_allreduce(dat_,dat,1,mpi_int8_type,mpi_sum,icomm,info)
else
if (iam==root_) then
dat_=dat
call mpi_reduce(dat_,dat,1,mpi_int8_type,mpi_sum,root_,icomm,info)
else
call mpi_reduce(dat,dat_,1,mpi_int8_type,mpi_sum,root_,icomm,info)
end if
endif
end subroutine psb_i8sums
subroutine psb_i8amx_mpi_user(inv, outv,len,type)
integer(psb_long_int_k_) :: inv(*),outv(*)
integer :: len,type
integer :: i
do i=1, len
if (abs(inv(i)) > abs(outv(i))) then
outv(i) = inv(i)
end if
end do
end subroutine psb_i8amx_mpi_user
subroutine psb_i8amn_mpi_user(inv, outv,len,type)
#ifdef MPI_MOD
use mpi
#endif
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_long_int_k_) :: inv(*),outv(*)
integer :: len,type
integer :: i
if (type /= mpi_integer8) then
write(0,*) 'Invalid type !!!'
end if
do i=1, len
if (abs(inv(i)) < abs(outv(i))) then
outv(i) = inv(i)
end if
end do
end subroutine psb_i8amn_mpi_user
subroutine psb_i8amns(ictxt,dat,root)
#ifdef MPI_MOD
use mpi
#endif
#ifdef MPI_H
include 'mpif.h'
#endif
integer, intent(in) :: ictxt
integer(psb_long_int_k_), intent(inout) :: dat
integer, intent(in), optional :: root
integer :: root_
integer(psb_long_int_k_) :: dat_
integer :: iam, np, icomm,info, i8amn
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call psb_get_mpicomm(ictxt,icomm)
call mpi_op_create(psb_i8amn_mpi_user,.true.,i8amn,info)
if (present(root)) then
root_ = root
else
root_ = -1
endif
if (root_ == -1) then
call mpi_allreduce(dat,dat_,1,mpi_integer8,i8amn,icomm,info)
dat = dat_
else
call mpi_reduce(dat,dat_,1,mpi_integer8,i8amn,root_,icomm,info)
dat = dat_
endif
call mpi_op_free(i8amn,info)
#endif
end subroutine psb_i8amns
subroutine psb_i8amxs(ictxt,dat,root)
#ifdef MPI_MOD
use mpi
#endif
#ifdef MPI_H
include 'mpif.h'
#endif
integer, intent(in) :: ictxt
integer(psb_long_int_k_), intent(inout) :: dat
integer, intent(in), optional :: root
integer :: root_
integer(psb_long_int_k_) :: dat_
integer :: iam, np, icomm,info, i8amx
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call psb_get_mpicomm(ictxt,icomm)
call mpi_op_create(psb_i8amx_mpi_user,.true.,i8amx,info)
if (present(root)) then
root_ = root
else
root_ = -1
endif
if (root_ == -1) then
call mpi_allreduce(dat,dat_,1,mpi_integer8,i8amx,icomm,info)
dat = dat_
else
call mpi_reduce(dat,dat_,1,mpi_integer8,i8amx,root_,icomm,info)
dat = dat_
endif
call mpi_op_free(i8amx,info)
#endif
end subroutine psb_i8amxs
subroutine psb_i8mins(ictxt,dat,root)
#ifdef MPI_MOD
use mpi
#endif
#ifdef MPI_H
include 'mpif.h'
#endif
integer, intent(in) :: ictxt
integer(psb_long_int_k_), intent(inout) :: dat
integer, intent(in), optional :: root
integer :: root_
integer(psb_long_int_k_) :: dat_
integer :: iam, np, icomm,info
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call psb_get_mpicomm(ictxt,icomm)
if (present(root)) then
root_ = root
else
root_ = -1
endif
if (root_ == -1) then
call mpi_allreduce(dat,dat_,1,mpi_integer8,mpi_min,icomm,info)
dat = dat_
else
call mpi_reduce(dat,dat_,1,mpi_integer8,mpi_min,root_,icomm,info)
dat = dat_
endif
#endif
end subroutine psb_i8mins
subroutine psb_i8maxs(ictxt,dat,root)
#ifdef MPI_MOD
use mpi
#endif
#ifdef MPI_H
include 'mpif.h'
#endif
integer, intent(in) :: ictxt
integer(psb_long_int_k_), intent(inout) :: dat
integer, intent(in), optional :: root
integer :: root_
integer(psb_long_int_k_) :: dat_
integer :: iam, np, icomm,info
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call psb_get_mpicomm(ictxt,icomm)
if (present(root)) then
root_ = root
else
root_ = -1
endif
if (root_ == -1) then
call mpi_allreduce(dat,dat_,1,mpi_integer8,mpi_max,icomm,info)
dat = dat_
else
call mpi_reduce(dat,dat_,1,mpi_integer8,mpi_max,root_,icomm,info)
dat = dat_
endif
#endif
end subroutine psb_i8maxs
subroutine psb_isums(ictxt,dat,root)
integer, intent(in) :: ictxt
integer, intent(inout) :: dat
base/modules/psb_sort_mod.f90
+55 -6
View File
@@ -48,12 +48,12 @@ module psb_sort_mod
! The up/down constant are defined in pairs having
! opposite values. We make use of this fact in the heapsort routine.
!
integer, parameter :: psb_sort_up_=1, psb_sort_down_=-1
integer, parameter :: psb_lsort_up_=2, psb_lsort_down_=-2
integer, parameter :: psb_asort_up_=3, psb_asort_down_=-3
integer, parameter :: psb_alsort_up_=4, psb_alsort_down_=-4
integer, parameter :: psb_sort_ovw_idx_=0, psb_sort_keep_idx_=1
integer, parameter :: psb_heap_resize=200
integer, parameter :: psb_sort_up_ = 1, psb_sort_down_ = -1
integer, parameter :: psb_lsort_up_ = 2, psb_lsort_down_ = -2
integer, parameter :: psb_asort_up_ = 3, psb_asort_down_ = -3
integer, parameter :: psb_alsort_up_ = 4, psb_alsort_down_ = -4
integer, parameter :: psb_sort_ovw_idx_ = 0, psb_sort_keep_idx_ = 1
integer, parameter :: psb_heap_resize = 200
type psb_int_heap
integer :: last, dir
@@ -131,9 +131,58 @@ module psb_sort_mod
& psb_double_idx_heap_get_first, psb_dcomplex_idx_heap_get_first
end interface
interface psb_ibsrch
module procedure psb_ibsrch
end interface
interface psb_issrch
module procedure psb_issrch
end interface
contains
function psb_ibsrch(key,n,v) result(ipos)
implicit none
integer ipos, key, n
integer v(n)
integer lb, ub, m
lb = 1
ub = n
ipos = -1
do while (lb.le.ub)
m = (lb+ub)/2
if (key.eq.v(m)) then
ipos = m
lb = ub + 1
else if (key.lt.v(m)) then
ub = m-1
else
lb = m + 1
end if
enddo
return
end function psb_ibsrch
function psb_issrch(key,n,v) result(ipos)
implicit none
integer ipos, key, n
integer v(n)
integer i
ipos = -1
do i=1,n
if (key.eq.v(i)) then
ipos = i
return
end if
enddo
return
end function psb_issrch
subroutine imsort(x,ix,dir,flag)
use psb_error_mod
implicit none
base/modules/psb_spmat_type.f03
+33 -43
View File
@@ -140,6 +140,11 @@ module psb_spmat_type
type, extends(psb_base_spmat_type) :: psb_dspmat_type
real(psb_dpk_), allocatable :: aspk(:)
contains
procedure, pass(a) :: i_spmv => psb_dspmv_inner
procedure, pass(a) :: i_spmm => psb_dspmm_inner
generic, public :: spmm => i_spmv, i_spmm
end type psb_dspmat_type
type, extends(psb_base_spmat_type) :: psb_zspmat_type
@@ -242,10 +247,28 @@ module psb_spmat_type
& psb_dspinfo, psb_zspinfo
end interface
private psb_dspmm_inner, psb_dspmv_inner
contains
subroutine psb_dspmv_inner(alpha,a,x,beta,y,info)
type(psb_dspmat_type), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha,beta,x(:)
real(psb_dpk_), intent(inout) :: y(:)
integer, intent(out) :: info
write(0,*) 'Inner spmv was invoked!'
end subroutine psb_dspmv_inner
subroutine psb_dspmm_inner(alpha,a,x,beta,y,info)
type(psb_dspmat_type), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha,beta,x(:,:)
real(psb_dpk_), intent(inout) :: y(:,:)
integer, intent(out) :: info
write(0,*) 'Inner spmm was invoked!'
end subroutine psb_dspmm_inner
integer function psb_get_ssp_nrows(a)
type(psb_sspmat_type), intent(in) :: a
psb_get_ssp_nrows = a%m
@@ -926,15 +949,12 @@ contains
end function psb_ssp_getifld
function psb_sspsizeof(a)
function psb_sspsizeof(a) result(val)
implicit none
!....Parameters...
Type(psb_sspmat_type), intent(in) :: A
Integer :: psb_sspsizeof
!locals
integer :: val
integer(psb_long_int_k_) :: val
val = psb_sizeof_int*size(a%infoa)
@@ -955,10 +975,6 @@ contains
val = val + psb_sizeof_int * size(a%pr)
endif
psb_sspsizeof = val
Return
end function psb_sspsizeof
@@ -1462,22 +1478,17 @@ contains
end function psb_dsp_getifld
function psb_dspsizeof(a)
function psb_dspsizeof(a) result(val)
implicit none
!....Parameters...
Type(psb_dspmat_type), intent(in) :: A
Integer :: psb_dspsizeof
!locals
integer :: val
integer(psb_long_int_k_) :: val
val = psb_sizeof_int*size(a%infoa)
if (allocated(a%aspk)) then
val = val + psb_sizeof_dp * size(a%aspk)
endif
if (allocated(a%ia1)) then
val = val + psb_sizeof_int * size(a%ia1)
endif
@@ -1491,10 +1502,6 @@ contains
val = val + psb_sizeof_int * size(a%pr)
endif
psb_dspsizeof = val
Return
end function psb_dspsizeof
@@ -1971,20 +1978,15 @@ contains
end function psb_csp_getifld
function psb_cspsizeof(a)
function psb_cspsizeof(a) result(val)
implicit none
!....Parameters...
Type(psb_cspmat_type), intent(in) :: A
Integer :: psb_cspsizeof
!locals
integer :: val
integer(psb_long_int_k_) :: val
val = psb_sizeof_int*size(a%infoa)
if (allocated(a%aspk)) then
val = val + 2 * psb_sizeof_dp * size(a%aspk)
val = val + 2 * psb_sizeof_sp * size(a%aspk)
endif
if (allocated(a%ia1)) then
@@ -2000,10 +2002,6 @@ contains
val = val + psb_sizeof_int * size(a%pr)
endif
psb_cspsizeof = val
Return
end function psb_cspsizeof
@@ -2473,22 +2471,18 @@ contains
end function psb_zsp_getifld
function psb_zspsizeof(a)
function psb_zspsizeof(a) result(val)
implicit none
!....Parameters...
Type(psb_zspmat_type), intent(in) :: A
Integer :: psb_zspsizeof
!locals
integer :: val
integer(psb_long_int_k_) :: val
val = psb_sizeof_int*size(a%infoa)
if (allocated(a%aspk)) then
val = val + 2 * psb_sizeof_dp * size(a%aspk)
endif
if (allocated(a%ia1)) then
val = val + psb_sizeof_int * size(a%ia1)
endif
@@ -2502,10 +2496,6 @@ contains
val = val + psb_sizeof_int * size(a%pr)
endif
psb_zspsizeof = val
Return
end function psb_zspsizeof
base/modules/psb_string_mod.f90
+47 -129
View File
@@ -44,20 +44,56 @@ module psb_string_mod
module procedure psb_sub_toupperc
end interface
private lcase, ucase, upper1c, lower1c
private
character(len=*), parameter :: lcase='abcdefghijklmnopqrstuvwxyz'
character(len=*), parameter :: ucase='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
contains
function idx_bsrch(key,v) result(ipos)
implicit none
integer :: ipos
character key
character(len=*) v
integer lb, ub, m
lb = 1
ub = len(v)
ipos = 0
do
if (lb > ub) exit
m = (lb+ub)/2
if (key.eq.v(m:m)) then
ipos = m
exit
else if (key.lt.v(m:m)) then
ub = m-1
else
lb = m + 1
end if
enddo
return
end function idx_bsrch
function psb_tolowerc(string)
character(len=*), intent(in) :: string
character(len=len(string)) :: psb_tolowerc
integer :: i,k
do i=1,len(string)
psb_tolowerc(i:i) = lower1c(string(i:i))
k = idx_bsrch(string(i:i),ucase)
if (k /= 0) then
psb_tolowerc(i:i) = lcase(k:k)
else
psb_tolowerc(i:i) = string(i:i)
end if
enddo
end function psb_tolowerc
function psb_toupperc(string)
@@ -66,7 +102,12 @@ contains
integer :: i,k
do i=1,len(string)
psb_toupperc(i:i) = upper1c(string(i:i))
k = idx_bsrch(string(i:i),lcase)
if (k /= 0) then
psb_toupperc(i:i) = ucase(k:k)
else
psb_toupperc(i:i) = string(i:i)
end if
enddo
end function psb_toupperc
@@ -76,139 +117,16 @@ contains
integer :: i,k
do i=1,len(string)
k = index(lcase,string(i:i))
if (k /=0 ) then
k = idx_bsrch(string(i:i),lcase)
if (k /= 0) then
strout(i:i) = ucase(k:k)
else
strout(i:i) = string(i:i)
end if
enddo
end subroutine psb_sub_toupperc
function lower1c(ch)
character(len=1), intent(in) :: ch
character(len=1) :: lower1c
select case(ch)
case ('A')
lower1c = 'a'
case ('B')
lower1c = 'b'
case ('C')
lower1c = 'c'
case ('D')
lower1c = 'd'
case ('E')
lower1c = 'e'
case ('F')
lower1c = 'f'
case ('G')
lower1c = 'g'
case ('H')
lower1c = 'h'
case ('I')
lower1c = 'i'
case ('J')
lower1c = 'j'
case ('K')
lower1c = 'k'
case ('L')
lower1c = 'l'
case ('M')
lower1c = 'm'
case ('N')
lower1c = 'n'
case ('O')
lower1c = 'o'
case ('P')
lower1c = 'p'
case ('Q')
lower1c = 'q'
case ('R')
lower1c = 'r'
case ('S')
lower1c = 's'
case ('T')
lower1c = 't'
case ('U')
lower1c = 'u'
case ('V')
lower1c = 'v'
case ('W')
lower1c = 'w'
case ('X')
lower1c = 'x'
case ('Y')
lower1c = 'y'
case ('Z')
lower1c = 'z'
case default
lower1c = ch
end select
end function lower1c
function upper1c(ch)
character(len=1), intent(in) :: ch
character(len=1) :: upper1c
select case(ch)
case ('a')
upper1c = 'A'
case ('b')
upper1c = 'B'
case ('c')
upper1c = 'C'
case ('d')
upper1c = 'D'
case ('e')
upper1c = 'E'
case ('f')
upper1c = 'F'
case ('g')
upper1c = 'G'
case ('h')
upper1c = 'H'
case ('i')
upper1c = 'I'
case ('j')
upper1c = 'J'
case ('k')
upper1c = 'K'
case ('l')
upper1c = 'L'
case ('m')
upper1c = 'M'
case ('n')
upper1c = 'N'
case ('o')
upper1c = 'O'
case ('p')
upper1c = 'P'
case ('q')
upper1c = 'Q'
case ('r')
upper1c = 'R'
case ('s')
upper1c = 'S'
case ('t')
upper1c = 'T'
case ('u')
upper1c = 'U'
case ('v')
upper1c = 'V'
case ('w')
upper1c = 'W'
case ('x')
upper1c = 'X'
case ('y')
upper1c = 'Y'
case ('z')
upper1c = 'Z'
case default
upper1c = ch
end select
end function upper1c
end module psb_string_mod
base/modules/psb_tools_mod.f90
+23 -6
View File
@@ -34,6 +34,22 @@ Module psb_tools_mod
use psb_spmat_type
interface psb_cd_set_bld
subroutine psb_cd_set_bld(desc,info)
use psb_descriptor_type
type(psb_desc_type), intent(inout) :: desc
integer :: info
end subroutine psb_cd_set_bld
end interface
interface psb_cd_set_ovl_bld
subroutine psb_cd_set_ovl_bld(desc,info)
use psb_descriptor_type
type(psb_desc_type), intent(inout) :: desc
integer :: info
end subroutine psb_cd_set_ovl_bld
end interface
interface psb_cd_reinit
Subroutine psb_cd_reinit(desc,info)
use psb_descriptor_type
@@ -977,7 +993,7 @@ contains
end subroutine psb_get_boundary
subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl)
subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalcheck)
use psb_descriptor_type
use psb_serial_mod
use psb_const_mod
@@ -987,11 +1003,11 @@ contains
include 'parts.fh'
Integer, intent(in) :: mg,ng,ictxt, vg(:), vl(:),nl
integer, intent(in) :: flag
logical, intent(in) :: repl
logical, intent(in) :: repl, globalcheck
integer, intent(out) :: info
type(psb_desc_type), intent(out) :: desc
optional :: mg,ng,parts,vg,vl,flag,nl,repl
optional :: mg,ng,parts,vg,vl,flag,nl,repl, globalcheck
interface
subroutine psb_cdals(m, n, parts, ictxt, desc, info)
@@ -1008,12 +1024,13 @@ contains
integer, intent(out) :: info
Type(psb_desc_type), intent(out) :: desc
end subroutine psb_cdalv
subroutine psb_cd_inloc(v, ictxt, desc, info)
subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck)
use psb_descriptor_type
implicit None
Integer, intent(in) :: ictxt, v(:)
integer, intent(out) :: info
type(psb_desc_type), intent(out) :: desc
logical, intent(in), optional :: globalcheck
end subroutine psb_cd_inloc
subroutine psb_cdrep(m, ictxt, desc,info)
use psb_descriptor_type
@@ -1079,7 +1096,7 @@ contains
call psb_cdalv(vg, ictxt, desc, info, flag=flag_)
else if (present(vl)) then
call psb_cd_inloc(vl,ictxt,desc,info)
call psb_cd_inloc(vl,ictxt,desc,info, globalcheck=globalcheck)
else if (present(nl)) then
allocate(itmpsz(0:np-1),stat=info)
@@ -1096,7 +1113,7 @@ contains
do i=0, me-1
nlp = nlp + itmpsz(i)
end do
call psb_cd_inloc((/(i,i=nlp+1,nlp+nl)/),ictxt,desc,info)
call psb_cd_inloc((/(i,i=nlp+1,nlp+nl)/),ictxt,desc,info,globalcheck=.false.)
endif
base/modules/psi_mod.f90
+273 -97
View File
@@ -502,32 +502,40 @@ module psi_mod
interface psi_idx_cnv
subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned)
use psb_descriptor_type, only : psb_desc_type, psb_spk_, psb_dpk_
use psb_descriptor_type, only : psb_desc_type
integer, intent(in) :: nv
integer, intent(inout) :: idxin(:)
type(psb_desc_type), intent(in) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask(:)
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
end subroutine psi_idx_cnv1
subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned)
use psb_descriptor_type, only : psb_desc_type, psb_spk_, psb_dpk_
use psb_descriptor_type, only : psb_desc_type
integer, intent(in) :: nv, idxin(:)
integer, intent(out) :: idxout(:)
type(psb_desc_type), intent(in) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask(:)
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
end subroutine psi_idx_cnv2
subroutine psi_idx_cnvs(idxin,idxout,desc,info,mask,owned)
use psb_descriptor_type, only : psb_desc_type, psb_spk_, psb_dpk_
use psb_descriptor_type, only : psb_desc_type
integer, intent(in) :: idxin
integer, intent(out) :: idxout
type(psb_desc_type), intent(in) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
end subroutine psi_idx_cnvs
subroutine psi_idx_cnvs1(idxin,desc,info,mask,owned)
use psb_descriptor_type, only : psb_desc_type
integer, intent(inout) :: idxin
type(psb_desc_type), intent(in) :: desc
integer, intent(out) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
end subroutine psi_idx_cnvs1
end interface
interface psi_idx_ins_cnv
@@ -537,7 +545,7 @@ module psi_mod
integer, intent(inout) :: idxin(:)
type(psb_desc_type), intent(inout) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask(:)
logical, intent(in), optional :: mask(:)
end subroutine psi_idx_ins_cnv1
subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask)
use psb_descriptor_type, only : psb_desc_type, psb_spk_, psb_dpk_
@@ -545,16 +553,23 @@ module psi_mod
integer, intent(out) :: idxout(:)
type(psb_desc_type), intent(inout) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask(:)
logical, intent(in), optional :: mask(:)
end subroutine psi_idx_ins_cnv2
subroutine psi_idx_ins_cnvs(idxin,idxout,desc,info,mask)
subroutine psi_idx_ins_cnvs2(idxin,idxout,desc,info,mask)
use psb_descriptor_type, only : psb_desc_type, psb_spk_, psb_dpk_
integer, intent(in) :: idxin
integer, intent(out) :: idxout
type(psb_desc_type), intent(inout) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask
end subroutine psi_idx_ins_cnvs
logical, intent(in), optional :: mask
end subroutine psi_idx_ins_cnvs2
subroutine psi_idx_ins_cnvs1(idxin,desc,info,mask)
use psb_descriptor_type, only : psb_desc_type, psb_spk_, psb_dpk_
integer, intent(inout) :: idxin
type(psb_desc_type), intent(inout) :: desc
integer, intent(out) :: info
logical, intent(in), optional :: mask
end subroutine psi_idx_ins_cnvs1
end interface
interface psi_cnv_dsc
@@ -562,7 +577,9 @@ module psi_mod
end interface
interface psi_inner_cnv
module procedure psi_inner_cnv1, psi_inner_cnv2
module procedure psi_inner_cnv1, psi_inner_cnv2,&
& psi_inner_cnvs, psi_inner_cnvs2
! & psi_inner_cnv1_mask, psi_inner_cnv2_mask,&
end interface
interface psi_ovrl_upd
@@ -729,10 +746,9 @@ contains
end subroutine psi_cnv_dsc
subroutine psi_inner_cnv1(n,x,hashmask,hashv,glb_lc)
integer, intent(in) :: n,hashmask,hashv(0:),glb_lc(:,:)
integer, intent(inout) :: x(:)
subroutine psi_inner_cnvs(x,hashmask,hashv,glb_lc)
integer, intent(in) :: hashmask,hashv(0:),glb_lc(:,:)
integer, intent(inout) :: x
integer :: i, ih, key, idx,nh,tmp,lb,ub,lm
!
@@ -743,41 +759,164 @@ contains
! for a width of psb_hash_bits
!
do i=1, n
key = x(i)
ih = iand(key,hashmask)
idx = hashv(ih)
nh = hashv(ih+1) - hashv(ih)
if (nh > 0) then
tmp = -1
lb = idx
ub = idx+nh-1
do
if (lb>ub) exit
lm = (lb+ub)/2
if (key==glb_lc(lm,1)) then
tmp = lm
exit
else if (key<glb_lc(lm,1)) then
ub = lm - 1
else
lb = lm + 1
key = x
ih = iand(key,hashmask)
idx = hashv(ih)
nh = hashv(ih+1) - hashv(ih)
if (nh > 0) then
tmp = -1
lb = idx
ub = idx+nh-1
do
if (lb>ub) exit
lm = (lb+ub)/2
if (key==glb_lc(lm,1)) then
tmp = lm
exit
else if (key<glb_lc(lm,1)) then
ub = lm - 1
else
lb = lm + 1
end if
end do
else
tmp = -1
end if
if (tmp > 0) then
x = glb_lc(tmp,2)
else
x = tmp
end if
end subroutine psi_inner_cnvs
subroutine psi_inner_cnvs2(x,y,hashmask,hashv,glb_lc)
integer, intent(in) :: hashmask,hashv(0:),glb_lc(:,:)
integer, intent(in) :: x
integer, intent(out) :: y
integer :: i, ih, key, idx,nh,tmp,lb,ub,lm
!
! When a large descriptor is assembled the indices
! are kept in a (hashed) list of ordered lists.
! Thus we first hash the index, then we do a binary search on the
! ordered sublist. The hashing is based on the low-order bits
! for a width of psb_hash_bits
!
key = x
ih = iand(key,hashmask)
idx = hashv(ih)
nh = hashv(ih+1) - hashv(ih)
if (nh > 0) then
tmp = -1
lb = idx
ub = idx+nh-1
do
if (lb>ub) exit
lm = (lb+ub)/2
if (key==glb_lc(lm,1)) then
tmp = lm
exit
else if (key<glb_lc(lm,1)) then
ub = lm - 1
else
lb = lm + 1
end if
end do
else
tmp = -1
end if
if (tmp > 0) then
y = glb_lc(tmp,2)
else
y = tmp
end if
end subroutine psi_inner_cnvs2
subroutine psi_inner_cnv1(n,x,hashmask,hashv,glb_lc,mask)
integer, intent(in) :: n,hashmask,hashv(0:),glb_lc(:,:)
logical, intent(in), optional :: mask(:)
integer, intent(inout) :: x(:)
integer :: i, ih, key, idx,nh,tmp,lb,ub,lm
!
! When a large descriptor is assembled the indices
! are kept in a (hashed) list of ordered lists.
! Thus we first hash the index, then we do a binary search on the
! ordered sublist. The hashing is based on the low-order bits
! for a width of psb_hash_bits
!
if (present(mask)) then
do i=1, n
if (mask(i)) then
key = x(i)
ih = iand(key,hashmask)
idx = hashv(ih)
nh = hashv(ih+1) - hashv(ih)
if (nh > 0) then
tmp = -1
lb = idx
ub = idx+nh-1
do
if (lb>ub) exit
lm = (lb+ub)/2
if (key==glb_lc(lm,1)) then
tmp = lm
exit
else if (key<glb_lc(lm,1)) then
ub = lm - 1
else
lb = lm + 1
end if
end do
else
tmp = -1
end if
end do
else
tmp = -1
end if
if (tmp > 0) then
x(i) = glb_lc(tmp,2)
else
x(i) = tmp
end if
end do
if (tmp > 0) then
x(i) = glb_lc(tmp,2)
else
x(i) = tmp
end if
end if
end do
else
do i=1, n
key = x(i)
ih = iand(key,hashmask)
idx = hashv(ih)
nh = hashv(ih+1) - hashv(ih)
if (nh > 0) then
tmp = -1
lb = idx
ub = idx+nh-1
do
if (lb>ub) exit
lm = (lb+ub)/2
if (key==glb_lc(lm,1)) then
tmp = lm
exit
else if (key<glb_lc(lm,1)) then
ub = lm - 1
else
lb = lm + 1
end if
end do
else
tmp = -1
end if
if (tmp > 0) then
x(i) = glb_lc(tmp,2)
else
x(i) = tmp
end if
end do
end if
end subroutine psi_inner_cnv1
subroutine psi_inner_cnv2(n,x,y,hashmask,hashv,glb_lc)
subroutine psi_inner_cnv2(n,x,y,hashmask,hashv,glb_lc,mask)
integer, intent(in) :: n, hashmask,hashv(0:),glb_lc(:,:)
logical, intent(in),optional :: mask(:)
integer, intent(in) :: x(:)
integer, intent(out) :: y(:)
@@ -789,40 +928,77 @@ contains
! ordered sublist. The hashing is based on the low-order bits
! for a width of psb_hash_bits
!
do i=1, n
key = x(i)
ih = iand(key,hashmask)
if (ih > ubound(hashv,1) ) then
write(0,*) ' In inner cnv: ',ih,ubound(hashv)
end if
idx = hashv(ih)
nh = hashv(ih+1) - hashv(ih)
if (nh > 0) then
tmp = -1
lb = idx
ub = idx+nh-1
do
if (lb>ub) exit
lm = (lb+ub)/2
if (key==glb_lc(lm,1)) then
tmp = lm
exit
else if (key<glb_lc(lm,1)) then
ub = lm - 1
else
lb = lm + 1
if (present(mask)) then
do i=1, n
if (mask(i)) then
key = x(i)
ih = iand(key,hashmask)
if (ih > ubound(hashv,1) ) then
write(0,*) ' In inner cnv: ',ih,ubound(hashv)
end if
end do
else
tmp = -1
end if
if (tmp > 0) then
y(i) = glb_lc(tmp,2)
else
y(i) = tmp
end if
end do
idx = hashv(ih)
nh = hashv(ih+1) - hashv(ih)
if (nh > 0) then
tmp = -1
lb = idx
ub = idx+nh-1
do
if (lb>ub) exit
lm = (lb+ub)/2
if (key==glb_lc(lm,1)) then
tmp = lm
exit
else if (key<glb_lc(lm,1)) then
ub = lm - 1
else
lb = lm + 1
end if
end do
else
tmp = -1
end if
if (tmp > 0) then
y(i) = glb_lc(tmp,2)
else
y(i) = tmp
end if
end if
end do
else
do i=1, n
key = x(i)
ih = iand(key,hashmask)
if (ih > ubound(hashv,1) ) then
write(0,*) ' In inner cnv: ',ih,ubound(hashv)
end if
idx = hashv(ih)
nh = hashv(ih+1) - hashv(ih)
if (nh > 0) then
tmp = -1
lb = idx
ub = idx+nh-1
do
if (lb>ub) exit
lm = (lb+ub)/2
if (key==glb_lc(lm,1)) then
tmp = lm
exit
else if (key<glb_lc(lm,1)) then
ub = lm - 1
else
lb = lm + 1
end if
end do
else
tmp = -1
end if
if (tmp > 0) then
y(i) = glb_lc(tmp,2)
else
y(i) = tmp
end if
end do
end if
end subroutine psi_inner_cnv2
subroutine psi_sovrl_updr1(x,desc_a,update,info)
@@ -1688,14 +1864,14 @@ contains
call psb_errpush(info,name)
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = 4001
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
@@ -1892,14 +2068,14 @@ contains
call psb_errpush(info,name)
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = 4001
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
@@ -1975,7 +2151,7 @@ contains
subroutine psi_covrl_restrr1(x,xs,desc_a,info)
implicit none
complex(psb_spk_), intent(inout) :: x(:)
complex(psb_spk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
@@ -2095,14 +2271,14 @@ contains
call psb_errpush(info,name)
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = 4001
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
@@ -2180,7 +2356,7 @@ contains
subroutine psi_zovrl_restrr1(x,xs,desc_a,info)
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
complex(psb_dpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
@@ -2301,14 +2477,14 @@ contains
call psb_errpush(info,name)
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = 4001
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
@@ -2509,14 +2685,14 @@ contains
call psb_errpush(info,name)
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = 4001
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
base/psblas/psb_dspmm.f90
+2
View File
@@ -578,6 +578,8 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& dzero,x,desc_a,iwork,info,data=psb_comm_halo_)
end if
! Just for fun
call a%spmm(alpha,x,beta,y,info)
! local Matrix-vector product
call psb_csmm(alpha,a,x(iix:lldx),beta,y(iiy:lldy),info)
base/serial/f77/cswmm.f
+1
View File
@@ -170,6 +170,7 @@ C
NAME = 'CSWMM\0'
IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
WORK(1) = czero
IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN
C
base/serial/f77/cswsm.f
+1
View File
@@ -177,6 +177,7 @@ C .. Executable Statements ..
NAME = 'CSWSM\0'
IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
WORK(1) = czero
C
C Check for identity matrix
C
base/serial/f77/dswmm.f
+1 -1
View File
@@ -162,7 +162,7 @@ C
NAME = 'DSWMM\0'
IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
WORK(1) = dzero
C Switching on FIDA: proper sparse BLAS routine is selected
C according to data structure
C
base/serial/f77/dswsm.f
+1
View File
@@ -181,6 +181,7 @@ C .. Executable Statements ..
NAME = 'DSWSM'
IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
WORK(1) = dzero
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
base/serial/f77/sswmm.f
+1 -1
View File
@@ -161,7 +161,7 @@ C
NAME = 'DSWMM\0'
IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
WORK(1) = szero
C Switching on FIDA: proper sparse BLAS routine is selected
C according to data structure
C
base/serial/f77/sswsm.f
+1
View File
@@ -180,6 +180,7 @@ C .. Executable Statements ..
NAME = 'DSWSM'
IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
work(1) = szero
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
base/serial/f77/zswmm.f
+1 -1
View File
@@ -171,7 +171,7 @@ C
NAME = 'ZSWMM\0'
IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
WORK(1) = zzero
IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN
C
C A, IA1, IA2 ---> AR, JA, IA
base/serial/f77/zswsm.f
+1
View File
@@ -177,6 +177,7 @@ C .. Executable Statements ..
NAME = 'ZSWSM\0'
IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
WORK(1) = zzero
C
C Check for identity matrix
C
base/tools/Makefile
+1 -1
View File
@@ -18,7 +18,7 @@ FOBJS = psb_sallc.o psb_sasb.o \
psb_zspins.o psb_zsprn.o \
psb_cspalloc.o psb_cspasb.o psb_cspfree.o\
psb_callc.o psb_casb.o psb_cfree.o psb_cins.o \
psb_cspins.o psb_csprn.o psb_map.o psb_inter_desc.o
psb_cspins.o psb_csprn.o psb_map.o psb_inter_desc.o psb_cd_set_bld.o
MPFOBJS = psb_ssphalo.o psb_csphalo.o psb_dsphalo.o psb_zsphalo.o psb_icdasb.o \
psb_dcdbldext.o psb_zcdbldext.o psb_scdbldext.o psb_ccdbldext.o
base/tools/psb_ccdbldext.F90
+59 -46
View File
@@ -123,7 +123,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
Call psb_info(ictxt, me, np)
If (debug_level >= psb_debug_outer_) &
& Write(debug_unit,*) me,' ',trim(name),': start',novr
& Write(debug_unit,*) me,' ',trim(name),&
& ': start',novr
if (present(extype)) then
extype_ = extype
@@ -145,7 +146,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
endif
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),':Calling desccpy'
& write(debug_unit,*) me,' ',trim(name),&
& ':Calling desccpy'
call psb_cdcpy(desc_a,desc_ov,info)
if (info /= 0) then
info=4010
@@ -154,7 +156,9 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),':From desccpy'
& write(debug_unit,*) me,' ',trim(name),&
& ':From desccpy'
if (novr==0) then
!
! Just copy the input.
@@ -165,7 +169,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
If (debug_level >= psb_debug_outer_)then
Write(debug_unit,*) me,' ',trim(name),':BEGIN ',nhalo
Write(debug_unit,*) me,' ',trim(name),&
& ':BEGIN ',nhalo
call psb_barrier(ictxt)
endif
@@ -180,7 +185,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
lworks = ((nztot+m-1)/m)*nhalo
lworkr = ((nztot+m-1)/m)*nhalo
else
info=-1
info = -1
call psb_errpush(info,name)
goto 9999
endif
@@ -235,12 +240,12 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
tmp_ovr_idx(:) = -1
orig_ovr(:) = -1
tmp_halo(:) = -1
counter_e = 1
tot_recv = 0
counter_t = 1
counter_h = 1
counter_o = 1
cntov_o = 1
counter_e = 1
tot_recv = 0
counter_t = 1
counter_h = 1
counter_o = 1
cntov_o = 1
! Init overlap with desc_a%ovrlap (if any)
counter = 1
Do While (desc_a%ovrlap_index(counter) /= -1)
@@ -301,7 +306,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
Do i_ovr = 1, novr
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),':Running on overlap level ',i_ovr,' of ',novr
& write(debug_unit,*) me,' ',trim(name),&
& ':Running on overlap level ',i_ovr,' of ',novr
!
! At this point, halo contains a valid halo corresponding to the
@@ -333,7 +339,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
end If
tot_recv=tot_recv+n_elem_recv
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': tot_recv:',proc,n_elem_recv,tot_recv
& write(debug_unit,*) me,' ',trim(name),&
& ': tot_recv:',proc,n_elem_recv,tot_recv
!
!
! The format of the halo vector exists in two forms: 1. Temporary
@@ -368,10 +375,10 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
tmp_ovr_idx(counter_o)=proc
tmp_ovr_idx(counter_o+1)=1
tmp_ovr_idx(counter_o+2)=gidx
tmp_ovr_idx(counter_o+3)=-1
tmp_ovr_idx(counter_o) = proc
tmp_ovr_idx(counter_o+1) = 1
tmp_ovr_idx(counter_o+2) = gidx
tmp_ovr_idx(counter_o+3) = -1
counter_o=counter_o+3
call psb_ensure_size((counter_h+3),tmp_halo,info,pad=-1)
if (info /= 0) then
@@ -380,10 +387,10 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
tmp_halo(counter_h)=proc
tmp_halo(counter_h+1)=1
tmp_halo(counter_h+2)=idx
tmp_halo(counter_h+3)=-1
tmp_halo(counter_h) = proc
tmp_halo(counter_h+1) = 1
tmp_halo(counter_h+2) = idx
tmp_halo(counter_h+3) = -1
counter_h=counter_h+3
@@ -411,10 +418,10 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
tmp_ovr_idx(counter_o)=proc
tmp_ovr_idx(counter_o+1)=1
tmp_ovr_idx(counter_o+2)=gidx
tmp_ovr_idx(counter_o+3)=-1
tmp_ovr_idx(counter_o) = proc
tmp_ovr_idx(counter_o+1) = 1
tmp_ovr_idx(counter_o+2) = gidx
tmp_ovr_idx(counter_o+3) = -1
counter_o=counter_o+3
!
@@ -466,6 +473,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ':Checktmp_o_i Loop Mid2',tmp_ovr_idx(1:10)
sdsz(proc+1) = tot_elem
idxs = idxs + tot_elem
end if
@@ -517,7 +525,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
lworkr=max(iszr,1)
lworkr = max(iszr,1)
end if
call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,&
@@ -549,12 +557,15 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
works(j) = workr(i)
end if
end do
! Eliminate duplicates from request
call psb_msort_unique(works(1:j),iszs)
!
! fnd_owner on desc_a because we want the procs who
! owned the rows from the beginning!
!
call psi_fnd_owner(iszs,works,temp,desc_a,info)
n_col=psb_cd_get_local_cols(desc_ov)
n_col = psb_cd_get_local_cols(desc_ov)
do i=1,iszs
idx = works(i)
@@ -575,11 +586,11 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
t_halo_in(counter_t)=proc_id
t_halo_in(counter_t+1)=1
t_halo_in(counter_t+2)=lidx
t_halo_in(counter_t+3)=-1
counter_t=counter_t+3
t_halo_in(counter_t) = proc_id
t_halo_in(counter_t+1) = 1
t_halo_in(counter_t+2) = lidx
t_halo_in(counter_t+3) = -1
counter_t = counter_t+3
endif
end Do
n_col = psb_cd_get_local_cols(desc_ov)
@@ -596,8 +607,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
! we receive them guarantees that all indices for HALO(I)
! will be less than those for HALO(J) whenever I<J
!
n_col=n_col+1
proc_id=-desc_ov%glob_to_loc(idx)-np-1
n_col = n_col+1
proc_id = -desc_ov%glob_to_loc(idx)-np-1
call psb_ensure_size(n_col,desc_ov%loc_to_glob,info,pad=-1)
if (info /= 0) then
info=4010
@@ -605,8 +616,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
desc_ov%glob_to_loc(idx)=n_col
desc_ov%loc_to_glob(n_col)=idx
desc_ov%glob_to_loc(idx) = n_col
desc_ov%loc_to_glob(n_col) = idx
call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-1)
if (info /= 0) then
@@ -615,21 +626,23 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
t_halo_in(counter_t)=proc_id
t_halo_in(counter_t+1)=1
t_halo_in(counter_t+2)=n_col
t_halo_in(counter_t+3)=-1
t_halo_in(counter_t) = proc_id
t_halo_in(counter_t+1) = 1
t_halo_in(counter_t+2) = n_col
t_halo_in(counter_t+3) = -1
counter_t=counter_t+3
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': Added into t_halo_in from recv',&
&proc_id,n_col,idx
& write(debug_unit,*) me,' ',trim(name),&
& ': Added into t_halo_in from recv',&
& proc_id,n_col,idx
else if (desc_ov%glob_to_loc(idx) < 0) Then
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),':Wrong input to cdbldextbld?',&
&idx,desc_ov%glob_to_loc(idx)
& write(debug_unit,*) me,' ',trim(name),&
& ':Wrong input to cdbldextbld?',&
& idx,desc_ov%glob_to_loc(idx)
End If
End Do
desc_ov%matrix_data(psb_n_col_)=n_col
desc_ov%matrix_data(psb_n_col_) = n_col
end if
@@ -692,7 +705,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
call psb_errpush(4010,name,a_err='deallocate')
goto 9999
end if
case(psb_ovt_asov_)
!
! Build an overlapped descriptor for Additive Schwarz
base/tools/psb_cd_inloc.f90
+251 -127
View File
@@ -41,7 +41,7 @@
! ictxt - integer. The communication context.
! desc - type(psb_desc_type). The communication descriptor.
! info - integer. Eventually returns an error code
subroutine psb_cd_inloc(v, ictxt, desc, info)
subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck)
use psb_descriptor_type
use psb_serial_mod
use psb_const_mod
@@ -53,14 +53,18 @@ subroutine psb_cd_inloc(v, ictxt, desc, info)
Integer, intent(in) :: ictxt, v(:)
integer, intent(out) :: info
type(psb_desc_type), intent(out) :: desc
logical, intent(in), optional :: globalcheck
!locals
Integer :: counter,i,j,np,me,loc_row,err,&
& loc_col,nprocs,n,itmpov, k,glx,&
& l_ov_ix,l_ov_el,idx, flag_, err_act,m
Integer :: i,j,np,me,loc_row,err,&
& loc_col,nprocs,n, k,glx,nlu,&
& idx, flag_, err_act,m, novrl, norphan,&
& npr_ov, itmpov, i_pnt, nrt
integer :: int_err(5),exch(3)
Integer, allocatable :: temp_ovrlap(:), tmpgidx(:,:)
Integer, allocatable :: temp_ovrlap(:), tmpgidx(:,:), vl(:),&
& nov(:), ov_idx(:,:)
integer :: debug_level, debug_unit
logical :: check_, islarge
character(len=20) :: name
if(psb_get_errstatus() /= 0) return
@@ -74,18 +78,25 @@ subroutine psb_cd_inloc(v, ictxt, desc, info)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': start',np
loc_row = size(v)
if (.false.) then
m = loc_row
call psb_sum(ictxt,m)
else
m = maxval(v)
nrt = loc_row
call psb_sum(ictxt,nrt)
call psb_max(ictxt,m)
end if
if (present(globalcheck)) then
check_ = globalcheck
else
check_ = .true.
end if
n = m
!... check m and n parameters....
if (m < 1) then
info = 10
@@ -124,35 +135,86 @@ subroutine psb_cd_inloc(v, ictxt, desc, info)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': doing global checks'
allocate(tmpgidx(m,2),stat=info)
islarge = psb_cd_choose_large_state(ictxt,m)
allocate(vl(loc_row),stat=info)
if (info /=0) then
info=4000
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
!
! Checks for valid input:
! 1. legal range
! 2. no orphans
! 3. any overlap?
! Checks 2 and 3 are controlled by globalcheck
!
if (check_.or.(.not.islarge)) then
allocate(tmpgidx(m,2),stat=info)
if (info /=0) then
info=4000
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
tmpgidx = 0
flag_ = 1
do i=1,loc_row
if ((v(i)<1).or.(v(i)>m)) then
info = 551
int_err(1) = i
int_err(2) = v(i)
int_err(3) = loc_row
int_err(4) = m
else
tmpgidx(v(i),1) = me+flag_
tmpgidx(v(i),2) = 1
endif
vl(i) = v(i)
end do
tmpgidx=0
flag_=1
do i=1,loc_row
if ((v(i)<1).or.(v(i)>m)) then
info = 551
int_err(1) = i
int_err(2) = v(i)
int_err(3) = loc_row
int_err(4) = m
else
tmpgidx(v(i),1) = me+flag_
tmpgidx(v(i),2) = 1
endif
end do
call psb_amx(ictxt,tmpgidx)
if (info ==0) then
int_err(1) = count(tmpgidx(:,2) == 0)
int_err(2) = m
if (int_err(1)>0) then
info = 552
if (info ==0) then
call psb_amx(ictxt,tmpgidx(:,1))
call psb_sum(ictxt,tmpgidx(:,2))
novrl = 0
npr_ov = 0
norphan = 0
do i=1, m
if (tmpgidx(i,2) < 1) then
norphan = norphan + 1
else if (tmpgidx(i,2) > 1) then
novrl = novrl + 1
npr_ov = npr_ov + tmpgidx(i,2)
end if
end do
if (norphan > 0) then
int_err(1) = norphan
int_err(2) = m
info = 552
end if
end if
else
novrl = 0
norphan = 0
npr_ov = 0
do i=1,loc_row
if ((v(i)<1).or.(v(i)>m)) then
info = 551
int_err(1) = i
int_err(2) = v(i)
int_err(3) = loc_row
int_err(4) = m
exit
endif
vl(i) = v(i)
end do
if ((m /= nrt).and.(me==psb_root_)) then
write(0,*) trim(name),' Warning: globalcheck=.false., but there is a mismatch'
write(0,*) trim(name),' : in the global sizes!',m,nrt
end if
end if
@@ -161,22 +223,82 @@ subroutine psb_cd_inloc(v, ictxt, desc, info)
goto 9999
end if
!
! Now sort the input items, and eliminate duplicates
! (unlikely, but possible)
!
call psb_msort_unique(vl,nlu)
loc_row = nlu
call psb_nullify_desc(desc)
!
! Figure out overlap in the input
!
if (novrl > 0) then
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': code for NOVRL>0',novrl,npr_ov
allocate(nov(0:np),ov_idx(npr_ov,2),stat=info)
if (info /= 0) then
info=4025
int_err(1)=np + 2*npr_ov
call psb_errpush(info,name,i_err=int_err,a_err='integer')
goto 9999
endif
nov=0
do i=1, nlu
k = vl(i)
if (tmpgidx(k,2) > 1) then
nov(me) = nov(me) + 1
end if
end do
call psb_sum(ictxt,nov)
nov(1:np) = nov(0:np-1)
nov(0) = 1
do i=1, np
nov(i) = nov(i) + nov(i-1)
end do
ov_idx = 0
j = nov(me)
do i=1, nlu
k = vl(i)
if (tmpgidx(k,2) > 1) then
ov_idx(j,1) = k
ov_idx(j,2) = me
j = j + 1
end if
end do
if (j /= nov(me+1)) then
info=4001
call psb_errpush(info,name,a_err='overlap count')
goto 9999
end if
call psb_max(ictxt,ov_idx)
call psb_msort(ov_idx(:,1),ix=ov_idx(:,2),flag=psb_sort_keep_idx_)
end if
!count local rows number
! allocate work vector
if (psb_cd_choose_large_state(ictxt,m)) then
if (islarge) then
allocate(desc%matrix_data(psb_mdata_size_),&
&temp_ovrlap(m),stat=info)
desc%matrix_data(:) = 0
desc%matrix_data(psb_desc_size_) = psb_desc_large_
&temp_ovrlap(2*loc_row),desc%lprm(1),&
& stat=info)
if (info == 0) then
desc%lprm(1) = 0
desc%matrix_data(:) = 0
desc%matrix_data(psb_desc_size_) = psb_desc_large_
end if
else
allocate(desc%glob_to_loc(m),desc%matrix_data(psb_mdata_size_),&
&temp_ovrlap(m),stat=info)
desc%matrix_data(:) = 0
desc%matrix_data(psb_desc_size_) = psb_desc_normal_
&temp_ovrlap(2*loc_row),desc%lprm(1),&
& stat=info)
if (info == 0) then
desc%lprm(1) = 0
desc%matrix_data(:) = 0
desc%matrix_data(psb_desc_size_) = psb_desc_normal_
end if
end if
if (info /= 0) then
info=4025
@@ -185,6 +307,18 @@ subroutine psb_cd_inloc(v, ictxt, desc, info)
goto 9999
endif
! estimate local cols number
loc_col = min(2*loc_row,m)
allocate(desc%loc_to_glob(loc_col),stat=info)
if (info /= 0) then
info=4025
int_err(1)=loc_col
call psb_errpush(info,name,i_err=int_err,a_err='integer')
goto 9999
end if
desc%loc_to_glob(:) = -1
temp_ovrlap(:) = -1
desc%matrix_data(psb_m_) = m
desc%matrix_data(psb_n_) = n
! This has to be set BEFORE any call to SET_BLD
@@ -194,14 +328,11 @@ subroutine psb_cd_inloc(v, ictxt, desc, info)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': starting main loop' ,info
counter = 0
itmpov = 0
temp_ovrlap(:) = -1
!
! We have to decide whether we have a "large" index space.
!
if (psb_cd_choose_large_state(ictxt,m)) then
if (islarge) then
!
! Yes, we do have a large index space. Therefore we are
! keeping on the local process a map of only the global
@@ -211,41 +342,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info)
! is transferred to a series of ordered linear lists,
! hashed by the low order bits of the entries.
!
do i=1,m
if (((tmpgidx(i,1)-flag_) > np-1).or.((tmpgidx(i,1)-flag_) < 0)) then
info=580
int_err(1)=3
int_err(2)=tmpgidx(i,1) - flag_
int_err(3)=i
exit
end if
if ((tmpgidx(i,1)-flag_) == me) then
! this point belongs to me
counter=counter+1
end if
enddo
loc_row=counter
! check on parts function
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': End main loop:' ,loc_row,itmpov,info
if (info /= 0) then
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': error check:' ,err
! estimate local cols number
loc_col = min(2*loc_row,m)
allocate(desc%loc_to_glob(loc_col), desc%lprm(1),&
& stat=info)
if (info == 0) call InitSearchTree(desc%avltree,info)
if (info /= 0) then
info=4025
int_err(1)=loc_col
@@ -253,24 +350,45 @@ subroutine psb_cd_inloc(v, ictxt, desc, info)
goto 9999
end if
! set LOC_TO_GLOB array to all "-1" values
desc%lprm(1) = 0
desc%loc_to_glob(:) = -1
k = 0
do i=1,m
if ((tmpgidx(i,1)-flag_) == me) then
k = k + 1
desc%loc_to_glob(k) = i
call SearchInsKey(desc%avltree,i,glx,k,info)
endif
! Use sorted indices to fill in loc_to_glob
j = 1
itmpov = 0
do k=1, loc_row
i = vl(k)
desc%loc_to_glob(k) = i
if (check_) then
nprocs = tmpgidx(i,2)
if (nprocs > 1) then
do
if (j > size(ov_idx,dim=1)) then
info=4001
call psb_errpush(info,name,a_err='search ov_idx')
goto 9999
end if
if (ov_idx(j,1) == i) exit
j = j + 1
end do
call psb_ensure_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-1)
if (info /= 0) then
info=4010
call psb_errpush(info,name,a_err='psb_ensure_size')
goto 9999
end if
itmpov = itmpov + 1
temp_ovrlap(itmpov) = i
itmpov = itmpov + 1
temp_ovrlap(itmpov) = nprocs
temp_ovrlap(itmpov+1:itmpov+nprocs) = ov_idx(j:j+nprocs-1,2)
itmpov = itmpov + nprocs
end if
end if
enddo
if (k /= loc_row) then
write(0,*) 'Large cd init: ',k,loc_row
end if
if (info /= 0) then
info=4000
call psb_errpush(info,name)
info=4001
call psb_errpush(info,name,a_err='insert loop')
goto 9999
endif
@@ -296,56 +414,57 @@ subroutine psb_cd_inloc(v, ictxt, desc, info)
exit
end if
if ((tmpgidx(i,1)-flag_) == me) then
! this point belongs to me
counter=counter+1
desc%glob_to_loc(i) = counter
else
desc%glob_to_loc(i) = -(np+(tmpgidx(i,1)-flag_)+1)
end if
desc%glob_to_loc(i) = -(np+(tmpgidx(i,1)-flag_)+1)
enddo
loc_row=counter
! check on parts function
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': End main loop:' ,loc_row,itmpov,info
if (info /= 0) then
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': error check:' ,err
! estimate local cols number
loc_col = min(2*loc_row,m)
! Use sorted indices to fill in loc_to_glob
j = 1
itmpov = 0
do k=1, loc_row
i = vl(k)
desc%loc_to_glob(k) = i
desc%glob_to_loc(i) = k
allocate(desc%loc_to_glob(loc_col),&
&desc%lprm(1),stat=info)
if (info /= 0) then
info=4025
int_err(1)=loc_col
call psb_errpush(info,name,i_err=int_err,a_err='integer')
goto 9999
end if
! set LOC_TO_GLOB array to all "-1" values
desc%lprm(1) = 0
desc%loc_to_glob(:) = -1
do i=1,m
k = desc%glob_to_loc(i)
if (k > 0) then
desc%loc_to_glob(k) = i
endif
nprocs = tmpgidx(i,2)
if (nprocs > 1) then
do
if (j > size(ov_idx,dim=1)) then
info=4001
call psb_errpush(info,name,a_err='search ov_idx')
goto 9999
end if
if (ov_idx(j,1) == i) exit
j = j + 1
end do
call psb_ensure_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-1)
if (info /= 0) then
info=4010
call psb_errpush(info,name,a_err='psb_ensure_size')
goto 9999
end if
itmpov = itmpov + 1
temp_ovrlap(itmpov) = i
itmpov = itmpov + 1
temp_ovrlap(itmpov) = nprocs
temp_ovrlap(itmpov+1:itmpov+nprocs) = ov_idx(j:j+nprocs-1,2)
itmpov = itmpov + nprocs
end if
enddo
end if
call psi_bld_tmpovrl(temp_ovrlap,desc,info)
deallocate(temp_ovrlap,stat=info)
if (info == 0) deallocate(temp_ovrlap,vl,stat=info)
if ((info == 0).and.(allocated(tmpgidx)))&
& deallocate(tmpgidx,stat=info)
if ((info == 0) .and.(allocated(ov_idx))) &
& deallocate(ov_idx,nov,stat=info)
if (info /= 0) then
info=4000
call psb_errpush(info,name)
@@ -371,6 +490,11 @@ subroutine psb_cd_inloc(v, ictxt, desc, info)
& write(debug_unit,*) me,' ',trim(name),': end'
call psb_cd_set_bld(desc,info)
if (info /= 0) then
info=4010
call psb_errpush(info,name,a_err='psb_cd_set_bld')
Goto 9999
end if
call psb_erractionrestore(err_act)
return
base/tools/psb_cd_set_bld.f90
+123
View File
@@ -0,0 +1,123 @@
!!$
!!$ Parallel Sparse BLAS version 2.2
!!$ (C) Copyright 2006/2007/2008
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_cd_set_ovl_bld(desc,info)
!
! Change state of a descriptor into ovl_build.
use psb_const_mod
use psb_error_mod
use psb_penv_mod
use psi_mod
use psb_descriptor_type
use psb_tools_mod, psb_protect_name => psb_cd_set_ovl_bld
implicit none
type(psb_desc_type), intent(inout) :: desc
integer :: info
call psb_cd_set_bld(desc,info)
if (info == 0) desc%matrix_data(psb_dec_type_) = psb_cd_ovl_bld_
end subroutine psb_cd_set_ovl_bld
subroutine psb_cd_set_bld(desc,info)
!
! Change state of a descriptor into BUILD.
! If the descriptor is LARGE, check the AVL search tree
! and initialize it if necessary.
!
use psb_const_mod
use psb_error_mod
use psb_penv_mod
use psi_mod
use psb_descriptor_type
use psb_tools_mod, psb_protect_name => psb_cd_set_bld
implicit none
type(psb_desc_type), intent(inout) :: desc
integer :: info
!locals
integer :: np,me,ictxt, err_act,idx,gidx,lidx,nc
logical, parameter :: debug=.false.,debugprt=.false.
character(len=20) :: name
if (debug) write(0,*) me,'Entered CDCPY'
if (psb_get_errstatus() /= 0) return
info = 0
call psb_erractionsave(err_act)
name = 'psb_cd_set_bld'
ictxt = psb_cd_get_context(desc)
if (debug) write(0,*)'Entered CDSETBLD',ictxt
! check on blacs grid
call psb_info(ictxt, me, np)
if (debug) write(0,*) me,'Entered CDSETBLD'
if (psb_is_asb_desc(desc)) then
end if
desc%matrix_data(psb_dec_type_) = psb_desc_bld_
if (psb_is_large_desc(desc)) then
!
! The idea: first build glb_lc with the info on
! rows we already have, then leave space in
! hash for newcomers (halo indices).
! The policy is to allocate for as many entries
! as there are rows; if we ever fill them up, we can
! try and enlarge again, but by the time the hash
! fills up it means we have as many halo as internals,
! therefore there are much worse problems ahead than
! the hash occupancy.
!
nc = psb_cd_get_local_cols(desc)
if (.not.associated(desc%hash)) allocate(desc%hash,stat=info)
if (info == 0)&
& call psb_hash_init(nc,desc%hash,info)
if (info == 0) call psi_bld_hash(desc,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='hashInit')
goto 9999
end if
end if
if (debug) write(0,*) me,'SET_BLD: done'
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_cd_set_bld
base/tools/psb_cdals.f90
+22 -15
View File
@@ -51,7 +51,6 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
use psb_const_mod
use psi_mod
use psb_penv_mod
use psb_avl_mod
implicit None
include 'parts.fh'
!....Parameters...
@@ -74,7 +73,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_ext_) &
@@ -125,18 +124,23 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
call psb_nullify_desc(desc)
!count local rows number
! count local rows number
loc_row = max(1,(m+np-1)/np)
! allocate work vector
if (psb_cd_choose_large_state(ictxt,m)) then
allocate(desc%matrix_data(psb_mdata_size_),&
& temp_ovrlap(m),prc_v(np),stat=info)
desc%matrix_data(:) = 0
desc%matrix_data(psb_desc_size_) = psb_desc_large_
& temp_ovrlap(2*loc_row),prc_v(np),stat=info)
if (info == 0) then
desc%matrix_data(:) = 0
desc%matrix_data(psb_desc_size_) = psb_desc_large_
end if
else
allocate(desc%glob_to_loc(m),desc%matrix_data(psb_mdata_size_),&
& temp_ovrlap(m),prc_v(np),stat=info)
desc%matrix_data(:) = 0
desc%matrix_data(psb_desc_size_) = psb_desc_normal_
& temp_ovrlap(2*loc_row),prc_v(np),stat=info)
if (info == 0) then
desc%matrix_data(:) = 0
desc%matrix_data(psb_desc_size_) = psb_desc_normal_
end if
end if
if (info /= 0) then
info=4025
@@ -170,11 +174,10 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
! is transferred to a series of ordered linear lists,
! hashed by the low order bits of the entries.
!
loc_col = (m+np-1)/np
loc_col = max(1,(m+np-1)/np)
loc_col = min(2*loc_col,m)
allocate(desc%loc_to_glob(loc_col), desc%lprm(1),&
& stat=info)
if (info == 0) call InitSearchTree(desc%avltree,info)
if (info /= 0) then
info=4025
int_err(1)=loc_col
@@ -225,7 +228,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
if (prc_v(j) == me) exit
j=j+1
enddo
if (j <= nprocs) then
if (prc_v(j) == me) then
! this point belongs to me
@@ -237,7 +240,6 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
goto 9999
end if
desc%loc_to_glob(k) = i
call SearchInsKey(desc%avltree,i,glx,k,info)
if (nprocs > 1) then
call psb_ensure_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-1)
if (info /= 0) then
@@ -253,7 +255,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
itmpov = itmpov + nprocs
endif
end if
end if
end if
end if
enddo
if (info /= 0) then
@@ -371,7 +373,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
call psi_bld_tmpovrl(temp_ovrlap,desc,info)
if (info == 0) deallocate(prc_v,temp_ovrlap,stat=info)
if (info /= psb_no_err_) then
info=4000
@@ -396,6 +398,11 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
desc%ext_index(:) = -1
call psb_cd_set_bld(desc,info)
if (info /= 0) then
info=4010
call psb_errpush(info,name,a_err='psb_cd_set_bld')
Goto 9999
end if
if (debug_level >= psb_debug_ext_) &
base/tools/psb_cdalv.f90
+17 -10
View File
@@ -50,7 +50,6 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag)
use psb_error_mod
use psi_mod
use psb_penv_mod
use psb_avl_mod
implicit None
!....Parameters...
Integer, intent(in) :: ictxt, v(:)
@@ -136,18 +135,23 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag)
goto 9999
end if
!count local rows number
! count local rows number
loc_row = max(1,(m+np-1)/np)
! allocate work vector
if (psb_cd_choose_large_state(ictxt,m)) then
allocate(desc%matrix_data(psb_mdata_size_),&
&temp_ovrlap(m),stat=info)
desc%matrix_data(:) = 0
desc%matrix_data(psb_desc_size_) = psb_desc_large_
&temp_ovrlap(2*loc_row),stat=info)
if (info == 0) then
desc%matrix_data(:) = 0
desc%matrix_data(psb_desc_size_) = psb_desc_large_
end if
else
allocate(desc%glob_to_loc(m),desc%matrix_data(psb_mdata_size_),&
&temp_ovrlap(m),stat=info)
desc%matrix_data(:) = 0
desc%matrix_data(psb_desc_size_) = psb_desc_normal_
&temp_ovrlap(2*loc_row),stat=info)
if (info == 0) then
desc%matrix_data(:) = 0
desc%matrix_data(psb_desc_size_) = psb_desc_normal_
end if
end if
if (info /= 0) then
info=4025
@@ -215,7 +219,6 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag)
allocate(desc%loc_to_glob(loc_col), desc%lprm(1),&
& stat=info)
if (info == 0) call InitSearchTree(desc%avltree,info)
if (info /= 0) then
info=4025
int_err(1)=loc_col
@@ -231,7 +234,6 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag)
if ((v(i)-flag_) == me) then
k = k + 1
desc%loc_to_glob(k) = i
call SearchInsKey(desc%avltree,i,glx,k,info)
endif
enddo
@@ -328,6 +330,11 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag)
desc%ext_index(:) = -1
call psb_cd_set_bld(desc,info)
if (info /= 0) then
info=4010
call psb_errpush(info,name,a_err='psb_cd_set_bld')
Goto 9999
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
base/tools/psb_cdcpy.f90
+3 -6
View File
@@ -84,14 +84,11 @@ subroutine psb_cdcpy(desc_in, desc_out, info)
if (info == 0) call psb_safe_ab_cpy(desc_in%glob_to_loc,desc_out%glob_to_loc,info)
if (info == 0) call psb_safe_ab_cpy(desc_in%lprm,desc_out%lprm,info)
if (info == 0) call psb_safe_ab_cpy(desc_in%idx_space,desc_out%idx_space,info)
desc_out%hashvsize = desc_in%hashvsize
desc_out%hashvmask = desc_in%hashvmask
if (info == 0) call psb_safe_ab_cpy(desc_in%hashv,desc_out%hashv,info)
if (info == 0) call psb_safe_ab_cpy(desc_in%glb_lc,desc_out%glb_lc,info)
if (info == 0) then
if (associated(desc_in%avltree)) then
call CloneSearchTree(desc_in%avltree,desc_out%avltree)
end if
end if
if (info == 0) call CloneHashTable(desc_in%hash,desc_out%hash,info)
if (info /= 0) then
info = 4010
base/tools/psb_dcdbldext.F90
+3
View File
@@ -556,6 +556,9 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
works(j) = workr(i)
end if
end do
! Eliminate duplicates from request
call psb_msort_unique(works(1:j),iszs)
!
! fnd_owner on desc_a because we want the procs who
! owned the rows from the beginning!
base/tools/psb_icdasb.F90
+9 -12
View File
@@ -49,7 +49,6 @@ subroutine psb_icdasb(desc_a,info,ext_hv)
use psi_mod
use psb_error_mod
use psb_penv_mod
use psb_avl_mod
#ifdef MPI_MOD
use mpi
#endif
@@ -113,7 +112,11 @@ subroutine psb_icdasb(desc_a,info,ext_hv)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': Checking rows insertion'
!
! check if all local row are inserted
! Note: this may still be useful for the case of
! cdall(..., vl=vl, globalcheck=.false.)
!
do i=1,psb_cd_get_local_cols(desc_a)
if (desc_a%loc_to_glob(i) < 0) then
info=3100
@@ -134,6 +137,10 @@ subroutine psb_icdasb(desc_a,info,ext_hv)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': Large descriptor, calling ldsc_pre_halo'
call psi_ldsc_pre_halo(desc_a,ext_hv_,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='ldsc_pre_halo')
goto 9999
end if
end if
! Take out the lists for ovrlap, halo and ext...
@@ -150,23 +157,13 @@ subroutine psb_icdasb(desc_a,info,ext_hv)
goto 9999
end if
deallocate(ovrlap_index, halo_index, ext_index, stat=info)
if (info /= 0) then
info =4000
call psb_errpush(info,name)
goto 9999
end if
! Finally, cleanup the AVL tree of indices, if any, as it is
! only needed while in the build state.
if (associated(desc_a%avltree)) then
call FreeSearchTree(desc_a%avltree,info)
if (info /= 0) then
info=2059
call psb_errpush(info,name)
goto 9999
end if
end if
! Ok, register into MATRIX_DATA
desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_
else
base/tools/psb_scdbldext.F90
+57 -44
View File
@@ -122,7 +122,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
Call psb_info(ictxt, me, np)
If (debug_level >= psb_debug_outer_) &
& Write(debug_unit,*) me,' ',trim(name),': start',novr
& Write(debug_unit,*) me,' ',trim(name),&
& ': start',novr
if (present(extype)) then
extype_ = extype
@@ -144,7 +145,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
endif
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),':Calling desccpy'
& write(debug_unit,*) me,' ',trim(name),&
& ':Calling desccpy'
call psb_cdcpy(desc_a,desc_ov,info)
if (info /= 0) then
info=4010
@@ -153,7 +155,9 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),':From desccpy'
& write(debug_unit,*) me,' ',trim(name),&
& ':From desccpy'
if (novr==0) then
!
! Just copy the input.
@@ -164,7 +168,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
If (debug_level >= psb_debug_outer_)then
Write(debug_unit,*) me,' ',trim(name),':BEGIN ',nhalo
Write(debug_unit,*) me,' ',trim(name),&
& ':BEGIN ',nhalo
call psb_barrier(ictxt)
endif
@@ -179,7 +184,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
lworks = ((nztot+m-1)/m)*nhalo
lworkr = ((nztot+m-1)/m)*nhalo
else
info=-1
info = -1
call psb_errpush(info,name)
goto 9999
endif
@@ -234,12 +239,12 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
tmp_ovr_idx(:) = -1
orig_ovr(:) = -1
tmp_halo(:) = -1
counter_e = 1
tot_recv = 0
counter_t = 1
counter_h = 1
counter_o = 1
cntov_o = 1
counter_e = 1
tot_recv = 0
counter_t = 1
counter_h = 1
counter_o = 1
cntov_o = 1
! Init overlap with desc_a%ovrlap (if any)
counter = 1
Do While (desc_a%ovrlap_index(counter) /= -1)
@@ -300,7 +305,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
Do i_ovr = 1, novr
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),':Running on overlap level ',i_ovr,' of ',novr
& write(debug_unit,*) me,' ',trim(name),&
& ':Running on overlap level ',i_ovr,' of ',novr
!
! At this point, halo contains a valid halo corresponding to the
@@ -332,7 +338,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
end If
tot_recv=tot_recv+n_elem_recv
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': tot_recv:',proc,n_elem_recv,tot_recv
& write(debug_unit,*) me,' ',trim(name),&
& ': tot_recv:',proc,n_elem_recv,tot_recv
!
!
! The format of the halo vector exists in two forms: 1. Temporary
@@ -367,10 +374,10 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
tmp_ovr_idx(counter_o)=proc
tmp_ovr_idx(counter_o+1)=1
tmp_ovr_idx(counter_o+2)=gidx
tmp_ovr_idx(counter_o+3)=-1
tmp_ovr_idx(counter_o) = proc
tmp_ovr_idx(counter_o+1) = 1
tmp_ovr_idx(counter_o+2) = gidx
tmp_ovr_idx(counter_o+3) = -1
counter_o=counter_o+3
call psb_ensure_size((counter_h+3),tmp_halo,info,pad=-1)
if (info /= 0) then
@@ -379,10 +386,10 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
tmp_halo(counter_h)=proc
tmp_halo(counter_h+1)=1
tmp_halo(counter_h+2)=idx
tmp_halo(counter_h+3)=-1
tmp_halo(counter_h) = proc
tmp_halo(counter_h+1) = 1
tmp_halo(counter_h+2) = idx
tmp_halo(counter_h+3) = -1
counter_h=counter_h+3
@@ -410,10 +417,10 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
tmp_ovr_idx(counter_o)=proc
tmp_ovr_idx(counter_o+1)=1
tmp_ovr_idx(counter_o+2)=gidx
tmp_ovr_idx(counter_o+3)=-1
tmp_ovr_idx(counter_o) = proc
tmp_ovr_idx(counter_o+1) = 1
tmp_ovr_idx(counter_o+2) = gidx
tmp_ovr_idx(counter_o+3) = -1
counter_o=counter_o+3
!
@@ -465,6 +472,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ':Checktmp_o_i Loop Mid2',tmp_ovr_idx(1:10)
sdsz(proc+1) = tot_elem
idxs = idxs + tot_elem
end if
@@ -516,7 +524,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
lworkr=max(iszr,1)
lworkr = max(iszr,1)
end if
call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,&
@@ -548,6 +556,9 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
works(j) = workr(i)
end if
end do
! Eliminate duplicates from request
call psb_msort_unique(works(1:j),iszs)
!
! fnd_owner on desc_a because we want the procs who
! owned the rows from the beginning!
@@ -574,11 +585,11 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
t_halo_in(counter_t)=proc_id
t_halo_in(counter_t+1)=1
t_halo_in(counter_t+2)=lidx
t_halo_in(counter_t+3)=-1
counter_t=counter_t+3
t_halo_in(counter_t) = proc_id
t_halo_in(counter_t+1) = 1
t_halo_in(counter_t+2) = lidx
t_halo_in(counter_t+3) = -1
counter_t = counter_t+3
endif
end Do
n_col = psb_cd_get_local_cols(desc_ov)
@@ -595,8 +606,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
! we receive them guarantees that all indices for HALO(I)
! will be less than those for HALO(J) whenever I<J
!
n_col=n_col+1
proc_id=-desc_ov%glob_to_loc(idx)-np-1
n_col = n_col+1
proc_id = -desc_ov%glob_to_loc(idx)-np-1
call psb_ensure_size(n_col,desc_ov%loc_to_glob,info,pad=-1)
if (info /= 0) then
info=4010
@@ -604,8 +615,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
desc_ov%glob_to_loc(idx)=n_col
desc_ov%loc_to_glob(n_col)=idx
desc_ov%glob_to_loc(idx) = n_col
desc_ov%loc_to_glob(n_col) = idx
call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-1)
if (info /= 0) then
@@ -614,21 +625,23 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
t_halo_in(counter_t)=proc_id
t_halo_in(counter_t+1)=1
t_halo_in(counter_t+2)=n_col
t_halo_in(counter_t+3)=-1
t_halo_in(counter_t) = proc_id
t_halo_in(counter_t+1) = 1
t_halo_in(counter_t+2) = n_col
t_halo_in(counter_t+3) = -1
counter_t=counter_t+3
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': Added into t_halo_in from recv',&
&proc_id,n_col,idx
& write(debug_unit,*) me,' ',trim(name),&
& ': Added into t_halo_in from recv',&
& proc_id,n_col,idx
else if (desc_ov%glob_to_loc(idx) < 0) Then
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),':Wrong input to cdbldextbld?',&
&idx,desc_ov%glob_to_loc(idx)
& write(debug_unit,*) me,' ',trim(name),&
& ':Wrong input to cdbldextbld?',&
& idx,desc_ov%glob_to_loc(idx)
End If
End Do
desc_ov%matrix_data(psb_n_col_)=n_col
desc_ov%matrix_data(psb_n_col_) = n_col
end if
base/tools/psb_zcdbldext.F90
+59 -46
View File
@@ -122,7 +122,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
Call psb_info(ictxt, me, np)
If (debug_level >= psb_debug_outer_) &
& Write(debug_unit,*) me,' ',trim(name),': start',novr
& Write(debug_unit,*) me,' ',trim(name),&
& ': start',novr
if (present(extype)) then
extype_ = extype
@@ -144,7 +145,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
endif
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),':Calling desccpy'
& write(debug_unit,*) me,' ',trim(name),&
& ':Calling desccpy'
call psb_cdcpy(desc_a,desc_ov,info)
if (info /= 0) then
info=4010
@@ -153,7 +155,9 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),':From desccpy'
& write(debug_unit,*) me,' ',trim(name),&
& ':From desccpy'
if (novr==0) then
!
! Just copy the input.
@@ -164,7 +168,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
If (debug_level >= psb_debug_outer_)then
Write(debug_unit,*) me,' ',trim(name),':BEGIN ',nhalo
Write(debug_unit,*) me,' ',trim(name),&
& ':BEGIN ',nhalo
call psb_barrier(ictxt)
endif
@@ -179,7 +184,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
lworks = ((nztot+m-1)/m)*nhalo
lworkr = ((nztot+m-1)/m)*nhalo
else
info=-1
info = -1
call psb_errpush(info,name)
goto 9999
endif
@@ -234,12 +239,12 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
tmp_ovr_idx(:) = -1
orig_ovr(:) = -1
tmp_halo(:) = -1
counter_e = 1
tot_recv = 0
counter_t = 1
counter_h = 1
counter_o = 1
cntov_o = 1
counter_e = 1
tot_recv = 0
counter_t = 1
counter_h = 1
counter_o = 1
cntov_o = 1
! Init overlap with desc_a%ovrlap (if any)
counter = 1
Do While (desc_a%ovrlap_index(counter) /= -1)
@@ -300,7 +305,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
Do i_ovr = 1, novr
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),':Running on overlap level ',i_ovr,' of ',novr
& write(debug_unit,*) me,' ',trim(name),&
& ':Running on overlap level ',i_ovr,' of ',novr
!
! At this point, halo contains a valid halo corresponding to the
@@ -332,7 +338,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
end If
tot_recv=tot_recv+n_elem_recv
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': tot_recv:',proc,n_elem_recv,tot_recv
& write(debug_unit,*) me,' ',trim(name),&
& ': tot_recv:',proc,n_elem_recv,tot_recv
!
!
! The format of the halo vector exists in two forms: 1. Temporary
@@ -367,10 +374,10 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
tmp_ovr_idx(counter_o)=proc
tmp_ovr_idx(counter_o+1)=1
tmp_ovr_idx(counter_o+2)=gidx
tmp_ovr_idx(counter_o+3)=-1
tmp_ovr_idx(counter_o) = proc
tmp_ovr_idx(counter_o+1) = 1
tmp_ovr_idx(counter_o+2) = gidx
tmp_ovr_idx(counter_o+3) = -1
counter_o=counter_o+3
call psb_ensure_size((counter_h+3),tmp_halo,info,pad=-1)
if (info /= 0) then
@@ -379,10 +386,10 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
tmp_halo(counter_h)=proc
tmp_halo(counter_h+1)=1
tmp_halo(counter_h+2)=idx
tmp_halo(counter_h+3)=-1
tmp_halo(counter_h) = proc
tmp_halo(counter_h+1) = 1
tmp_halo(counter_h+2) = idx
tmp_halo(counter_h+3) = -1
counter_h=counter_h+3
@@ -410,10 +417,10 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
tmp_ovr_idx(counter_o)=proc
tmp_ovr_idx(counter_o+1)=1
tmp_ovr_idx(counter_o+2)=gidx
tmp_ovr_idx(counter_o+3)=-1
tmp_ovr_idx(counter_o) = proc
tmp_ovr_idx(counter_o+1) = 1
tmp_ovr_idx(counter_o+2) = gidx
tmp_ovr_idx(counter_o+3) = -1
counter_o=counter_o+3
!
@@ -465,6 +472,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ':Checktmp_o_i Loop Mid2',tmp_ovr_idx(1:10)
sdsz(proc+1) = tot_elem
idxs = idxs + tot_elem
end if
@@ -516,7 +524,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
lworkr=max(iszr,1)
lworkr = max(iszr,1)
end if
call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,&
@@ -548,12 +556,15 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
works(j) = workr(i)
end if
end do
! Eliminate duplicates from request
call psb_msort_unique(works(1:j),iszs)
!
! fnd_owner on desc_a because we want the procs who
! owned the rows from the beginning!
!
call psi_fnd_owner(iszs,works,temp,desc_a,info)
n_col=psb_cd_get_local_cols(desc_ov)
n_col = psb_cd_get_local_cols(desc_ov)
do i=1,iszs
idx = works(i)
@@ -574,11 +585,11 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
t_halo_in(counter_t)=proc_id
t_halo_in(counter_t+1)=1
t_halo_in(counter_t+2)=lidx
t_halo_in(counter_t+3)=-1
counter_t=counter_t+3
t_halo_in(counter_t) = proc_id
t_halo_in(counter_t+1) = 1
t_halo_in(counter_t+2) = lidx
t_halo_in(counter_t+3) = -1
counter_t = counter_t+3
endif
end Do
n_col = psb_cd_get_local_cols(desc_ov)
@@ -595,8 +606,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
! we receive them guarantees that all indices for HALO(I)
! will be less than those for HALO(J) whenever I<J
!
n_col=n_col+1
proc_id=-desc_ov%glob_to_loc(idx)-np-1
n_col = n_col+1
proc_id = -desc_ov%glob_to_loc(idx)-np-1
call psb_ensure_size(n_col,desc_ov%loc_to_glob,info,pad=-1)
if (info /= 0) then
info=4010
@@ -604,8 +615,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
desc_ov%glob_to_loc(idx)=n_col
desc_ov%loc_to_glob(n_col)=idx
desc_ov%glob_to_loc(idx) = n_col
desc_ov%loc_to_glob(n_col) = idx
call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-1)
if (info /= 0) then
@@ -614,21 +625,23 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
t_halo_in(counter_t)=proc_id
t_halo_in(counter_t+1)=1
t_halo_in(counter_t+2)=n_col
t_halo_in(counter_t+3)=-1
t_halo_in(counter_t) = proc_id
t_halo_in(counter_t+1) = 1
t_halo_in(counter_t+2) = n_col
t_halo_in(counter_t+3) = -1
counter_t=counter_t+3
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': Added into t_halo_in from recv',&
&proc_id,n_col,idx
& write(debug_unit,*) me,' ',trim(name),&
& ': Added into t_halo_in from recv',&
& proc_id,n_col,idx
else if (desc_ov%glob_to_loc(idx) < 0) Then
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),':Wrong input to cdbldextbld?',&
&idx,desc_ov%glob_to_loc(idx)
& write(debug_unit,*) me,' ',trim(name),&
& ':Wrong input to cdbldextbld?',&
& idx,desc_ov%glob_to_loc(idx)
End If
End Do
desc_ov%matrix_data(psb_n_col_)=n_col
desc_ov%matrix_data(psb_n_col_) = n_col
end if
@@ -691,7 +704,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
call psb_errpush(4010,name,a_err='deallocate')
goto 9999
end if
case(psb_ovt_asov_)
!
! Build an overlapped descriptor for Additive Schwarz
configure
Vendored
+10 -3
View File
@@ -728,6 +728,7 @@ INSTALL
INSTALL_DIR
INSTALL_LIBDIR
INSTALL_INCLUDEDIR
INSTALL_DOCSDIR
BLACS_LIBS
METIS_LIBS
CINCLUDES
@@ -1988,8 +1989,12 @@ case $includedir in
\/* ) eval "INSTALL_INCLUDEDIR=$includedir";;
* ) eval "INSTALL_INCLUDEDIR=$INSTALL_DIR/include";;
esac
{ echo "$as_me:$LINENO: result: $INSTALL_DIR $INSTALL_INCLUDEDIR $INSTALL_LIBDIR" >&5
echo "${ECHO_T}$INSTALL_DIR $INSTALL_INCLUDEDIR $INSTALL_LIBDIR" >&6; }
case $docsdir in
\/* ) eval "INSTALL_DOCSDIR=$docsdir";;
* ) eval "INSTALL_DOCSDIR=$INSTALL_DIR/docs";;
esac
{ echo "$as_me:$LINENO: result: $INSTALL_DIR $INSTALL_INCLUDEDIR $INSTALL_LIBDIR $INSTALL_DOCSDIR" >&5
echo "${ECHO_T}$INSTALL_DIR $INSTALL_INCLUDEDIR $INSTALL_LIBDIR $INSTALL_DOCSDIR" >&6; }
# Note that the following line won't save from troubles.
# AC_PROG_FC([mpxlf95 mpxlf90 mpxlf pgf95 pgf90 mpif95 mpif90 gfortran f95 f90 ifc])
@@ -10603,6 +10608,7 @@ UTILLIBNAME=libpsb_util.a
if test "X$psblas_make_gnumake" == "Xyes" ; then
@@ -11501,6 +11507,7 @@ INSTALL!$INSTALL$ac_delim
INSTALL_DIR!$INSTALL_DIR$ac_delim
INSTALL_LIBDIR!$INSTALL_LIBDIR$ac_delim
INSTALL_INCLUDEDIR!$INSTALL_INCLUDEDIR$ac_delim
INSTALL_DOCSDIR!$INSTALL_DOCSDIR$ac_delim
BLACS_LIBS!$BLACS_LIBS$ac_delim
METIS_LIBS!$METIS_LIBS$ac_delim
CINCLUDES!$CINCLUDES$ac_delim
@@ -11514,7 +11521,7 @@ LIBOBJS!$LIBOBJS$ac_delim
LTLIBOBJS!$LTLIBOBJS$ac_delim
_ACEOF
if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 27; then
if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 28; then
break
elif $ac_last_try; then
{ { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5
configure.ac
+6 -1
View File
@@ -89,7 +89,11 @@ case $includedir in
\/* ) eval "INSTALL_INCLUDEDIR=$includedir";;
* ) eval "INSTALL_INCLUDEDIR=$INSTALL_DIR/include";;
esac
AC_MSG_RESULT([$INSTALL_DIR $INSTALL_INCLUDEDIR $INSTALL_LIBDIR])
case $docsdir in
\/* ) eval "INSTALL_DOCSDIR=$docsdir";;
* ) eval "INSTALL_DOCSDIR=$INSTALL_DIR/docs";;
esac
AC_MSG_RESULT([$INSTALL_DIR $INSTALL_INCLUDEDIR $INSTALL_LIBDIR $INSTALL_DOCSDIR])
# Note that the following line won't save from troubles.
# AC_PROG_FC([mpxlf95 mpxlf90 mpxlf pgf95 pgf90 mpif95 mpif90 gfortran f95 f90 ifc])
@@ -643,6 +647,7 @@ AC_SUBST(INSTALL_DATA)
AC_SUBST(INSTALL_DIR)
AC_SUBST(INSTALL_LIBDIR)
AC_SUBST(INSTALL_INCLUDEDIR)
AC_SUBST(INSTALL_DOCSDIR)
AC_SUBST(BLAS_LIBS)
AC_SUBST(BLACS_LIBS)
docs/html/footnode.html
+3 -3
View File
@@ -25,7 +25,7 @@ original version by: Nikos Drakos, CBLU, University of Leeds
<BODY >
<DL>
<DT><A NAME="foot164">...
<DT><A NAME="foot165">...
explicitly</A><A
HREF="node3.html#tex2html2"><SUP>1</SUP></A></DT>
<DD>In our prototype implementation we provide
@@ -63,7 +63,7 @@ sample scatter/gather routines.
.
</PRE>
</DD>
<DT><A NAME="foot173">... domain</A><A
<DT><A NAME="foot174">... domain</A><A
HREF="node4.html#tex2html3"><SUP>2</SUP></A></DT>
<DD>This is
the normal situation when the pattern of the sparse matrix is
@@ -104,7 +104,7 @@ sample scatter/gather routines.
.
</PRE>
</DD>
<DT><A NAME="foot6689">... follows</A><A
<DT><A NAME="foot6717">... follows</A><A
HREF="node99.html#tex2html28"><SUP>3</SUP></A></DT>
<DD>The string is case-insensitive
docs/html/img10.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 544 B

After

Width:  |  Height:  |  Size: 393 B

docs/html/img100.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 255 B

After

Width:  |  Height:  |  Size: 341 B

docs/html/img101.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 387 B

After

Width:  |  Height:  |  Size: 258 B

docs/html/img102.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 250 B

After

Width:  |  Height:  |  Size: 193 B

docs/html/img103.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 244 B

After

Width:  |  Height:  |  Size: 134 B

docs/html/img104.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 276 B

After

Width:  |  Height:  |  Size: 255 B

docs/html/img105.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 374 B

After

Width:  |  Height:  |  Size: 387 B

docs/html/img106.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 222 B

After

Width:  |  Height:  |  Size: 250 B

docs/html/img107.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 259 B

After

Width:  |  Height:  |  Size: 244 B

docs/html/img108.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 804 B

After

Width:  |  Height:  |  Size: 276 B

docs/html/img109.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 408 B

After

Width:  |  Height:  |  Size: 374 B

docs/html/img11.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 131 B

After

Width:  |  Height:  |  Size: 544 B

docs/html/img110.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 419 B

After

Width:  |  Height:  |  Size: 222 B

docs/html/img111.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 354 B

After

Width:  |  Height:  |  Size: 259 B

docs/html/img112.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 310 B

After

Width:  |  Height:  |  Size: 804 B

docs/html/img113.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 835 B

After

Width:  |  Height:  |  Size: 408 B

docs/html/img114.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 335 B

After

Width:  |  Height:  |  Size: 419 B

docs/html/img115.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 497 B

After

Width:  |  Height:  |  Size: 354 B

docs/html/img116.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 403 B

After

Width:  |  Height:  |  Size: 310 B

docs/html/img117.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 266 B

After

Width:  |  Height:  |  Size: 835 B

docs/html/img118.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 533 B

After

Width:  |  Height:  |  Size: 335 B

docs/html/img119.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 544 B

After

Width:  |  Height:  |  Size: 497 B

docs/html/img12.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 240 B

After

Width:  |  Height:  |  Size: 129 B

docs/html/img120.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 334 B

After

Width:  |  Height:  |  Size: 403 B

docs/html/img121.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 231 B

After

Width:  |  Height:  |  Size: 266 B

docs/html/img122.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 519 B

After

Width:  |  Height:  |  Size: 533 B

docs/html/img123.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 604 B

After

Width:  |  Height:  |  Size: 544 B

docs/html/img124.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 577 B

After

Width:  |  Height:  |  Size: 334 B

docs/html/img125.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 210 B

After

Width:  |  Height:  |  Size: 231 B

docs/html/img126.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 568 B

After

Width:  |  Height:  |  Size: 519 B

docs/html/img127.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 743 B

After

Width:  |  Height:  |  Size: 604 B

docs/html/img128.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 276 B

After

Width:  |  Height:  |  Size: 577 B

docs/html/img129.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 521 B

After

Width:  |  Height:  |  Size: 210 B

docs/html/img13.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 192 B

After

Width:  |  Height:  |  Size: 3.1 KiB

docs/html/img130.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 267 B

After

Width:  |  Height:  |  Size: 568 B

docs/html/img131.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 568 B

After

Width:  |  Height:  |  Size: 743 B

docs/html/img132.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 239 B

After

Width:  |  Height:  |  Size: 276 B

docs/html/img133.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 0 B

After

Width:  |  Height:  |  Size: 521 B

docs/html/img134.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 0 B

After

Width:  |  Height:  |  Size: 267 B

docs/html/img135.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 371 B

After

Width:  |  Height:  |  Size: 568 B

docs/html/img136.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 431 B

After

Width:  |  Height:  |  Size: 239 B

docs/html/img137.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 916 B

After

Width:  |  Height:  |  Size: 0 B

docs/html/img138.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 677 B

After

Width:  |  Height:  |  Size: 0 B

docs/html/img139.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 234 B

After

Width:  |  Height:  |  Size: 371 B

Some files were not shown because too many files have changed in this diff Show More