removed lapack-3.5.0
This commit is contained in:
Werner Saar
parent
0d22551a6b
commit
64db4576e6
|
|
@ -1,9 +0,0 @@
|
|||
add_subdirectory(SRC)
|
||||
if(BUILD_TESTING)
|
||||
add_subdirectory(TESTING)
|
||||
endif(BUILD_TESTING)
|
||||
configure_file(${CMAKE_CURRENT_SOURCE_DIR}/blas.pc.in ${CMAKE_CURRENT_BINARY_DIR}/blas.pc)
|
||||
install(FILES
|
||||
${CMAKE_CURRENT_BINARY_DIR}/blas.pc
|
||||
DESTINATION ${PKG_CONFIG_DIR}
|
||||
)
|
||||
|
|
@ -1,144 +0,0 @@
|
|||
#######################################################################
|
||||
# This is the makefile to create a library for the BLAS.
|
||||
# The files are grouped as follows:
|
||||
#
|
||||
# SBLAS1 -- Single precision real BLAS routines
|
||||
# CBLAS1 -- Single precision complex BLAS routines
|
||||
# DBLAS1 -- Double precision real BLAS routines
|
||||
# ZBLAS1 -- Double precision complex BLAS routines
|
||||
#
|
||||
# CB1AUX -- Real BLAS routines called by complex routines
|
||||
# ZB1AUX -- D.P. real BLAS routines called by d.p. complex
|
||||
# routines
|
||||
#
|
||||
# ALLBLAS -- Auxiliary routines for Level 2 and 3 BLAS
|
||||
#
|
||||
# SBLAS2 -- Single precision real BLAS2 routines
|
||||
# CBLAS2 -- Single precision complex BLAS2 routines
|
||||
# DBLAS2 -- Double precision real BLAS2 routines
|
||||
# ZBLAS2 -- Double precision complex BLAS2 routines
|
||||
#
|
||||
# SBLAS3 -- Single precision real BLAS3 routines
|
||||
# CBLAS3 -- Single precision complex BLAS3 routines
|
||||
# DBLAS3 -- Double precision real BLAS3 routines
|
||||
# ZBLAS3 -- Double precision complex BLAS3 routines
|
||||
#
|
||||
# The library can be set up to include routines for any combination
|
||||
# of the four precisions. To create or add to the library, enter make
|
||||
# followed by one or more of the precisions desired. Some examples:
|
||||
# make single
|
||||
# make single complex
|
||||
# make single double complex complex16
|
||||
# Note that these commands are not safe for parallel builds.
|
||||
#
|
||||
# Alternatively, the commands
|
||||
# make all
|
||||
# or
|
||||
# make
|
||||
# without any arguments creates a library of all four precisions.
|
||||
# The name of the library is held in BLASLIB, which is set in the
|
||||
# top-level make.inc
|
||||
#
|
||||
# To remove the object files after the library is created, enter
|
||||
# make clean
|
||||
# To force the source files to be recompiled, enter, for example,
|
||||
# make single FRC=FRC
|
||||
#
|
||||
#---------------------------------------------------------------------
|
||||
#
|
||||
# Edward Anderson, University of Tennessee
|
||||
# March 26, 1990
|
||||
# Susan Ostrouchov, Last updated September 30, 1994
|
||||
# ejr, May 2006.
|
||||
#
|
||||
#######################################################################
|
||||
|
||||
#---------------------------------------------------------
|
||||
# Comment out the next 6 definitions if you already have
|
||||
# the Level 1 BLAS.
|
||||
#---------------------------------------------------------
|
||||
set(SBLAS1 isamax.f sasum.f saxpy.f scopy.f sdot.f snrm2.f
|
||||
srot.f srotg.f sscal.f sswap.f sdsdot.f srotmg.f srotm.f)
|
||||
|
||||
set(CBLAS1 scabs1.f scasum.f scnrm2.f icamax.f caxpy.f ccopy.f
|
||||
cdotc.f cdotu.f csscal.f crotg.f cscal.f cswap.f csrot.f)
|
||||
|
||||
set(DBLAS1 idamax.f dasum.f daxpy.f dcopy.f ddot.f dnrm2.f
|
||||
drot.f drotg.f dscal.f dsdot.f dswap.f drotmg.f drotm.f)
|
||||
|
||||
set(ZBLAS1 dcabs1.f dzasum.f dznrm2.f izamax.f zaxpy.f zcopy.f
|
||||
zdotc.f zdotu.f zdscal.f zrotg.f zscal.f zswap.f zdrot.f)
|
||||
|
||||
set(CB1AUX isamax.f sasum.f saxpy.f scopy.f snrm2.f sscal.f)
|
||||
|
||||
set(ZB1AUX idamax.f dasum.f daxpy.f dcopy.f dnrm2.f dscal.f)
|
||||
|
||||
#---------------------------------------------------------------------
|
||||
# The following line defines auxiliary routines needed by both the
|
||||
# Level 2 and Level 3 BLAS. Comment it out only if you already have
|
||||
# both the Level 2 and 3 BLAS.
|
||||
#---------------------------------------------------------------------
|
||||
set(ALLBLAS lsame.f xerbla.f xerbla_array.f)
|
||||
|
||||
#---------------------------------------------------------
|
||||
# Comment out the next 4 definitions if you already have
|
||||
# the Level 2 BLAS.
|
||||
#---------------------------------------------------------
|
||||
set(SBLAS2 sgemv.f sgbmv.f ssymv.f ssbmv.f sspmv.f
|
||||
strmv.f stbmv.f stpmv.f strsv.f stbsv.f stpsv.f
|
||||
sger.f ssyr.f sspr.f ssyr2.f sspr2.f)
|
||||
|
||||
set(CBLAS2 cgemv.f cgbmv.f chemv.f chbmv.f chpmv.f
|
||||
ctrmv.f ctbmv.f ctpmv.f ctrsv.f ctbsv.f ctpsv.f
|
||||
cgerc.f cgeru.f cher.f chpr.f cher2.f chpr2.f)
|
||||
|
||||
set(DBLAS2 dgemv.f dgbmv.f dsymv.f dsbmv.f dspmv.f
|
||||
dtrmv.f dtbmv.f dtpmv.f dtrsv.f dtbsv.f dtpsv.f
|
||||
dger.f dsyr.f dspr.f dsyr2.f dspr2.f)
|
||||
|
||||
set(ZBLAS2 zgemv.f zgbmv.f zhemv.f zhbmv.f zhpmv.f
|
||||
ztrmv.f ztbmv.f ztpmv.f ztrsv.f ztbsv.f ztpsv.f
|
||||
zgerc.f zgeru.f zher.f zhpr.f zher2.f zhpr2.f)
|
||||
|
||||
#---------------------------------------------------------
|
||||
# Comment out the next 4 definitions if you already have
|
||||
# the Level 3 BLAS.
|
||||
#---------------------------------------------------------
|
||||
set(SBLAS3 sgemm.f ssymm.f ssyrk.f ssyr2k.f strmm.f strsm.f )
|
||||
|
||||
set(CBLAS3 cgemm.f csymm.f csyrk.f csyr2k.f ctrmm.f ctrsm.f
|
||||
chemm.f cherk.f cher2k.f)
|
||||
|
||||
set(DBLAS3 dgemm.f dsymm.f dsyrk.f dsyr2k.f dtrmm.f dtrsm.f)
|
||||
|
||||
set(ZBLAS3 zgemm.f zsymm.f zsyrk.f zsyr2k.f ztrmm.f ztrsm.f
|
||||
zhemm.f zherk.f zher2k.f)
|
||||
# default build all of it
|
||||
set(ALLOBJ ${SBLAS1} ${SBLAS2} ${SBLAS3} ${DBLAS1} ${DBLAS2} ${DBLAS3}
|
||||
${CBLAS1} ${CBLAS2} ${CBLAS3} ${ZBLAS1}
|
||||
${ZBLAS2} ${ZBLAS3} ${ALLBLAS})
|
||||
|
||||
if(BLAS_SINGLE)
|
||||
set(ALLOBJ ${SBLAS1} ${ALLBLAS}
|
||||
${SBLAS2} ${SBLAS3})
|
||||
endif()
|
||||
if(BLAS_DOUBLE)
|
||||
set(ALLOBJ ${DBLAS1} ${ALLBLAS}
|
||||
${DBLAS2} ${DBLAS3})
|
||||
endif()
|
||||
if(BLAS_COMPLEX)
|
||||
set(ALLOBJ ${BLASLIB} ${CBLAS1} ${CB1AUX}
|
||||
${ALLBLAS} ${CBLAS2})
|
||||
endif()
|
||||
if(BLAS_COMPLEX16)
|
||||
set(ALLOBJ ${BLASLIB} ${ZBLAS1} ${ZB1AUX}
|
||||
${ALLBLAS} ${ZBLAS2} ${ZBLAS3})
|
||||
endif()
|
||||
|
||||
|
||||
add_library(blas ${ALLOBJ})
|
||||
if(UNIX)
|
||||
target_link_libraries(blas m)
|
||||
endif()
|
||||
target_link_libraries(blas)
|
||||
lapack_install_library(blas)
|
||||
|
|
@ -1,171 +0,0 @@
|
|||
include ../../make.inc
|
||||
|
||||
#######################################################################
|
||||
# This is the makefile to create a library for the BLAS.
|
||||
# The files are grouped as follows:
|
||||
#
|
||||
# SBLAS1 -- Single precision real BLAS routines
|
||||
# CBLAS1 -- Single precision complex BLAS routines
|
||||
# DBLAS1 -- Double precision real BLAS routines
|
||||
# ZBLAS1 -- Double precision complex BLAS routines
|
||||
#
|
||||
# CB1AUX -- Real BLAS routines called by complex routines
|
||||
# ZB1AUX -- D.P. real BLAS routines called by d.p. complex
|
||||
# routines
|
||||
#
|
||||
# ALLBLAS -- Auxiliary routines for Level 2 and 3 BLAS
|
||||
#
|
||||
# SBLAS2 -- Single precision real BLAS2 routines
|
||||
# CBLAS2 -- Single precision complex BLAS2 routines
|
||||
# DBLAS2 -- Double precision real BLAS2 routines
|
||||
# ZBLAS2 -- Double precision complex BLAS2 routines
|
||||
#
|
||||
# SBLAS3 -- Single precision real BLAS3 routines
|
||||
# CBLAS3 -- Single precision complex BLAS3 routines
|
||||
# DBLAS3 -- Double precision real BLAS3 routines
|
||||
# ZBLAS3 -- Double precision complex BLAS3 routines
|
||||
#
|
||||
# The library can be set up to include routines for any combination
|
||||
# of the four precisions. To create or add to the library, enter make
|
||||
# followed by one or more of the precisions desired. Some examples:
|
||||
# make single
|
||||
# make single complex
|
||||
# make single double complex complex16
|
||||
# Note that these commands are not safe for parallel builds.
|
||||
#
|
||||
# Alternatively, the commands
|
||||
# make all
|
||||
# or
|
||||
# make
|
||||
# without any arguments creates a library of all four precisions.
|
||||
# The name of the library is held in BLASLIB, which is set in the
|
||||
# top-level make.inc
|
||||
#
|
||||
# To remove the object files after the library is created, enter
|
||||
# make clean
|
||||
# To force the source files to be recompiled, enter, for example,
|
||||
# make single FRC=FRC
|
||||
#
|
||||
#---------------------------------------------------------------------
|
||||
#
|
||||
# Edward Anderson, University of Tennessee
|
||||
# March 26, 1990
|
||||
# Susan Ostrouchov, Last updated September 30, 1994
|
||||
# ejr, May 2006.
|
||||
#
|
||||
#######################################################################
|
||||
|
||||
all: $(BLASLIB)
|
||||
|
||||
#---------------------------------------------------------
|
||||
# Comment out the next 6 definitions if you already have
|
||||
# the Level 1 BLAS.
|
||||
#---------------------------------------------------------
|
||||
SBLAS1 = isamax.o sasum.o saxpy.o scopy.o sdot.o snrm2.o \
|
||||
srot.o srotg.o sscal.o sswap.o sdsdot.o srotmg.o srotm.o
|
||||
$(SBLAS1): $(FRC)
|
||||
|
||||
CBLAS1 = scabs1.o scasum.o scnrm2.o icamax.o caxpy.o ccopy.o \
|
||||
cdotc.o cdotu.o csscal.o crotg.o cscal.o cswap.o csrot.o
|
||||
$(CBLAS1): $(FRC)
|
||||
|
||||
DBLAS1 = idamax.o dasum.o daxpy.o dcopy.o ddot.o dnrm2.o \
|
||||
drot.o drotg.o dscal.o dsdot.o dswap.o drotmg.o drotm.o
|
||||
$(DBLAS1): $(FRC)
|
||||
|
||||
ZBLAS1 = dcabs1.o dzasum.o dznrm2.o izamax.o zaxpy.o zcopy.o \
|
||||
zdotc.o zdotu.o zdscal.o zrotg.o zscal.o zswap.o zdrot.o
|
||||
$(ZBLAS1): $(FRC)
|
||||
|
||||
CB1AUX = isamax.o sasum.o saxpy.o scopy.o snrm2.o sscal.o
|
||||
$(CB1AUX): $(FRC)
|
||||
|
||||
ZB1AUX = idamax.o dasum.o daxpy.o dcopy.o dnrm2.o dscal.o
|
||||
$(ZB1AUX): $(FRC)
|
||||
|
||||
#---------------------------------------------------------------------
|
||||
# The following line defines auxiliary routines needed by both the
|
||||
# Level 2 and Level 3 BLAS. Comment it out only if you already have
|
||||
# both the Level 2 and 3 BLAS.
|
||||
#---------------------------------------------------------------------
|
||||
ALLBLAS = lsame.o xerbla.o xerbla_array.o
|
||||
$(ALLBLAS) : $(FRC)
|
||||
|
||||
#---------------------------------------------------------
|
||||
# Comment out the next 4 definitions if you already have
|
||||
# the Level 2 BLAS.
|
||||
#---------------------------------------------------------
|
||||
SBLAS2 = sgemv.o sgbmv.o ssymv.o ssbmv.o sspmv.o \
|
||||
strmv.o stbmv.o stpmv.o strsv.o stbsv.o stpsv.o \
|
||||
sger.o ssyr.o sspr.o ssyr2.o sspr2.o
|
||||
$(SBLAS2): $(FRC)
|
||||
|
||||
CBLAS2 = cgemv.o cgbmv.o chemv.o chbmv.o chpmv.o \
|
||||
ctrmv.o ctbmv.o ctpmv.o ctrsv.o ctbsv.o ctpsv.o \
|
||||
cgerc.o cgeru.o cher.o chpr.o cher2.o chpr2.o
|
||||
$(CBLAS2): $(FRC)
|
||||
|
||||
DBLAS2 = dgemv.o dgbmv.o dsymv.o dsbmv.o dspmv.o \
|
||||
dtrmv.o dtbmv.o dtpmv.o dtrsv.o dtbsv.o dtpsv.o \
|
||||
dger.o dsyr.o dspr.o dsyr2.o dspr2.o
|
||||
$(DBLAS2): $(FRC)
|
||||
|
||||
ZBLAS2 = zgemv.o zgbmv.o zhemv.o zhbmv.o zhpmv.o \
|
||||
ztrmv.o ztbmv.o ztpmv.o ztrsv.o ztbsv.o ztpsv.o \
|
||||
zgerc.o zgeru.o zher.o zhpr.o zher2.o zhpr2.o
|
||||
$(ZBLAS2): $(FRC)
|
||||
|
||||
#---------------------------------------------------------
|
||||
# Comment out the next 4 definitions if you already have
|
||||
# the Level 3 BLAS.
|
||||
#---------------------------------------------------------
|
||||
SBLAS3 = sgemm.o ssymm.o ssyrk.o ssyr2k.o strmm.o strsm.o
|
||||
$(SBLAS3): $(FRC)
|
||||
|
||||
CBLAS3 = cgemm.o csymm.o csyrk.o csyr2k.o ctrmm.o ctrsm.o \
|
||||
chemm.o cherk.o cher2k.o
|
||||
$(CBLAS3): $(FRC)
|
||||
|
||||
DBLAS3 = dgemm.o dsymm.o dsyrk.o dsyr2k.o dtrmm.o dtrsm.o
|
||||
$(DBLAS3): $(FRC)
|
||||
|
||||
ZBLAS3 = zgemm.o zsymm.o zsyrk.o zsyr2k.o ztrmm.o ztrsm.o \
|
||||
zhemm.o zherk.o zher2k.o
|
||||
$(ZBLAS3): $(FRC)
|
||||
|
||||
ALLOBJ=$(SBLAS1) $(SBLAS2) $(SBLAS3) $(DBLAS1) $(DBLAS2) $(DBLAS3) \
|
||||
$(CBLAS1) $(CBLAS2) $(CBLAS3) $(ZBLAS1) \
|
||||
$(ZBLAS2) $(ZBLAS3) $(ALLBLAS)
|
||||
|
||||
$(BLASLIB): $(ALLOBJ)
|
||||
$(ARCH) $(ARCHFLAGS) $@ $(ALLOBJ)
|
||||
$(RANLIB) $@
|
||||
|
||||
single: $(SBLAS1) $(ALLBLAS) $(SBLAS2) $(SBLAS3)
|
||||
$(ARCH) $(ARCHFLAGS) $(BLASLIB) $(SBLAS1) $(ALLBLAS) \
|
||||
$(SBLAS2) $(SBLAS3)
|
||||
$(RANLIB) $(BLASLIB)
|
||||
|
||||
double: $(DBLAS1) $(ALLBLAS) $(DBLAS2) $(DBLAS3)
|
||||
$(ARCH) $(ARCHFLAGS) $(BLASLIB) $(DBLAS1) $(ALLBLAS) \
|
||||
$(DBLAS2) $(DBLAS3)
|
||||
$(RANLIB) $(BLASLIB)
|
||||
|
||||
complex: $(CBLAS1) $(CB1AUX) $(ALLBLAS) $(CBLAS2) $(CBLAS3)
|
||||
$(ARCH) $(ARCHFLAGS) $(BLASLIB) $(CBLAS1) $(CB1AUX) \
|
||||
$(ALLBLAS) $(CBLAS2) $(CBLAS3)
|
||||
$(RANLIB) $(BLASLIB)
|
||||
|
||||
complex16: $(ZBLAS1) $(ZB1AUX) $(ALLBLAS) $(ZBLAS2) $(ZBLAS3)
|
||||
$(ARCH) $(ARCHFLAGS) $(BLASLIB) $(ZBLAS1) $(ZB1AUX) \
|
||||
$(ALLBLAS) $(ZBLAS2) $(ZBLAS3)
|
||||
$(RANLIB) $(BLASLIB)
|
||||
|
||||
FRC:
|
||||
@FRC=$(FRC)
|
||||
|
||||
clean:
|
||||
rm -f *.o
|
||||
|
||||
.f.o:
|
||||
$(FORTRAN) $(OPTS) -c $< -o $@
|
||||
|
|
@ -1,102 +0,0 @@
|
|||
*> \brief \b CAXPY
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CAXPY(N,CA,CX,INCX,CY,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX CA
|
||||
* INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX CX(*),CY(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CAXPY constant times a vector plus a vector.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CAXPY(N,CA,CX,INCX,CY,INCY)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX CA
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX CX(*),CY(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I,IX,IY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
REAL SCABS1
|
||||
EXTERNAL SCABS1
|
||||
* ..
|
||||
IF (N.LE.0) RETURN
|
||||
IF (SCABS1(CA).EQ.0.0E+0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
DO I = 1,N
|
||||
CY(I) = CY(I) + CA*CX(I)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments
|
||||
* not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
CY(IY) = CY(IY) + CA*CX(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,94 +0,0 @@
|
|||
*> \brief \b CCOPY
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CCOPY(N,CX,INCX,CY,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX CX(*),CY(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CCOPY copies a vector x to a vector y.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CCOPY(N,CX,INCX,CY,INCY)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX CX(*),CY(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I,IX,IY
|
||||
* ..
|
||||
IF (N.LE.0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
DO I = 1,N
|
||||
CY(I) = CX(I)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments
|
||||
* not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
CY(IY) = CX(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,102 +0,0 @@
|
|||
*> \brief \b CDOTC
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* COMPLEX FUNCTION CDOTC(N,CX,INCX,CY,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX CX(*),CY(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> forms the dot product of two vectors, conjugating the first
|
||||
*> vector.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
COMPLEX FUNCTION CDOTC(N,CX,INCX,CY,INCY)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX CX(*),CY(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
COMPLEX CTEMP
|
||||
INTEGER I,IX,IY
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG
|
||||
* ..
|
||||
CTEMP = (0.0,0.0)
|
||||
CDOTC = (0.0,0.0)
|
||||
IF (N.LE.0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
DO I = 1,N
|
||||
CTEMP = CTEMP + CONJG(CX(I))*CY(I)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments
|
||||
* not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
CTEMP = CTEMP + CONJG(CX(IX))*CY(IY)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
CDOTC = CTEMP
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,98 +0,0 @@
|
|||
*> \brief \b CDOTU
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* COMPLEX FUNCTION CDOTU(N,CX,INCX,CY,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX CX(*),CY(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CDOTU forms the dot product of two vectors.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
COMPLEX FUNCTION CDOTU(N,CX,INCX,CY,INCY)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX CX(*),CY(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
COMPLEX CTEMP
|
||||
INTEGER I,IX,IY
|
||||
* ..
|
||||
CTEMP = (0.0,0.0)
|
||||
CDOTU = (0.0,0.0)
|
||||
IF (N.LE.0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
DO I = 1,N
|
||||
CTEMP = CTEMP + CX(I)*CY(I)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments
|
||||
* not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
CTEMP = CTEMP + CX(IX)*CY(IY)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
CDOTU = CTEMP
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,394 +0,0 @@
|
|||
*> \brief \b CGBMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX ALPHA,BETA
|
||||
* INTEGER INCX,INCY,KL,KU,LDA,M,N
|
||||
* CHARACTER TRANS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CGBMV performs one of the matrix-vector operations
|
||||
*>
|
||||
*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or
|
||||
*>
|
||||
*> y := alpha*A**H*x + beta*y,
|
||||
*>
|
||||
*> where alpha and beta are scalars, x and y are vectors and A is an
|
||||
*> m by n band matrix, with kl sub-diagonals and ku super-diagonals.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the operation to be performed as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' y := alpha*A**H*x + beta*y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of the matrix A.
|
||||
*> M must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KL
|
||||
*> \verbatim
|
||||
*> KL is INTEGER
|
||||
*> On entry, KL specifies the number of sub-diagonals of the
|
||||
*> matrix A. KL must satisfy 0 .le. KL.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KU
|
||||
*> \verbatim
|
||||
*> KU is INTEGER
|
||||
*> On entry, KU specifies the number of super-diagonals of the
|
||||
*> matrix A. KU must satisfy 0 .le. KU.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array of DIMENSION ( LDA, n ).
|
||||
*> Before entry, the leading ( kl + ku + 1 ) by n part of the
|
||||
*> array A must contain the matrix of coefficients, supplied
|
||||
*> column by column, with the leading diagonal of the matrix in
|
||||
*> row ( ku + 1 ) of the array, the first super-diagonal
|
||||
*> starting at position 2 in row ku, the first sub-diagonal
|
||||
*> starting at position 1 in row ( ku + 2 ), and so on.
|
||||
*> Elements in the array A that do not correspond to elements
|
||||
*> in the band matrix (such as the top left ku by ku triangle)
|
||||
*> are not referenced.
|
||||
*> The following program segment will transfer a band matrix
|
||||
*> from conventional full matrix storage to band storage:
|
||||
*>
|
||||
*> DO 20, J = 1, N
|
||||
*> K = KU + 1 - J
|
||||
*> DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL )
|
||||
*> A( K + I, J ) = matrix( I, J )
|
||||
*> 10 CONTINUE
|
||||
*> 20 CONTINUE
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> ( kl + ku + 1 ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array of DIMENSION at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
|
||||
*> and at least
|
||||
*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
|
||||
*> Before entry, the incremented array X must contain the
|
||||
*> vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is COMPLEX
|
||||
*> On entry, BETA specifies the scalar beta. When BETA is
|
||||
*> supplied as zero then Y need not be set on input.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] Y
|
||||
*> \verbatim
|
||||
*> Y is COMPLEX array of DIMENSION at least
|
||||
*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
|
||||
*> and at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
|
||||
*> Before entry, the incremented array Y must contain the
|
||||
*> vector y. On exit, Y is overwritten by the updated vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX ALPHA,BETA
|
||||
INTEGER INCX,INCY,KL,KU,LDA,M,N
|
||||
CHARACTER TRANS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ONE
|
||||
PARAMETER (ONE= (1.0E+0,0.0E+0))
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,K,KUP1,KX,KY,LENX,LENY
|
||||
LOGICAL NOCONJ
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG,MAX,MIN
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (KL.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (KU.LT.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (LDA.LT. (KL+KU+1)) THEN
|
||||
INFO = 8
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 10
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 13
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CGBMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
|
||||
+ ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
NOCONJ = LSAME(TRANS,'T')
|
||||
*
|
||||
* Set LENX and LENY, the lengths of the vectors x and y, and set
|
||||
* up the start points in X and Y.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
LENX = N
|
||||
LENY = M
|
||||
ELSE
|
||||
LENX = M
|
||||
LENY = N
|
||||
END IF
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (LENX-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (LENY-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through the band part of A.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,LENY
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,LENY
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,LENY
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,LENY
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
KUP1 = KU + 1
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form y := alpha*A*x + y.
|
||||
*
|
||||
JX = KX
|
||||
IF (INCY.EQ.1) THEN
|
||||
DO 60 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
K = KUP1 - J
|
||||
DO 50 I = MAX(1,J-KU),MIN(M,J+KL)
|
||||
Y(I) = Y(I) + TEMP*A(K+I,J)
|
||||
50 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
IY = KY
|
||||
K = KUP1 - J
|
||||
DO 70 I = MAX(1,J-KU),MIN(M,J+KL)
|
||||
Y(IY) = Y(IY) + TEMP*A(K+I,J)
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
IF (J.GT.KU) KY = KY + INCY
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y := alpha*A**T*x + y or y := alpha*A**H*x + y.
|
||||
*
|
||||
JY = KY
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 110 J = 1,N
|
||||
TEMP = ZERO
|
||||
K = KUP1 - J
|
||||
IF (NOCONJ) THEN
|
||||
DO 90 I = MAX(1,J-KU),MIN(M,J+KL)
|
||||
TEMP = TEMP + A(K+I,J)*X(I)
|
||||
90 CONTINUE
|
||||
ELSE
|
||||
DO 100 I = MAX(1,J-KU),MIN(M,J+KL)
|
||||
TEMP = TEMP + CONJG(A(K+I,J))*X(I)
|
||||
100 CONTINUE
|
||||
END IF
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP
|
||||
JY = JY + INCY
|
||||
110 CONTINUE
|
||||
ELSE
|
||||
DO 140 J = 1,N
|
||||
TEMP = ZERO
|
||||
IX = KX
|
||||
K = KUP1 - J
|
||||
IF (NOCONJ) THEN
|
||||
DO 120 I = MAX(1,J-KU),MIN(M,J+KL)
|
||||
TEMP = TEMP + A(K+I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
120 CONTINUE
|
||||
ELSE
|
||||
DO 130 I = MAX(1,J-KU),MIN(M,J+KL)
|
||||
TEMP = TEMP + CONJG(A(K+I,J))*X(IX)
|
||||
IX = IX + INCX
|
||||
130 CONTINUE
|
||||
END IF
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP
|
||||
JY = JY + INCY
|
||||
IF (J.GT.KU) KX = KX + INCX
|
||||
140 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CGBMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,489 +0,0 @@
|
|||
*> \brief \b CGEMM
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX ALPHA,BETA
|
||||
* INTEGER K,LDA,LDB,LDC,M,N
|
||||
* CHARACTER TRANSA,TRANSB
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CGEMM performs one of the matrix-matrix operations
|
||||
*>
|
||||
*> C := alpha*op( A )*op( B ) + beta*C,
|
||||
*>
|
||||
*> where op( X ) is one of
|
||||
*>
|
||||
*> op( X ) = X or op( X ) = X**T or op( X ) = X**H,
|
||||
*>
|
||||
*> alpha and beta are scalars, and A, B and C are matrices, with op( A )
|
||||
*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] TRANSA
|
||||
*> \verbatim
|
||||
*> TRANSA is CHARACTER*1
|
||||
*> On entry, TRANSA specifies the form of op( A ) to be used in
|
||||
*> the matrix multiplication as follows:
|
||||
*>
|
||||
*> TRANSA = 'N' or 'n', op( A ) = A.
|
||||
*>
|
||||
*> TRANSA = 'T' or 't', op( A ) = A**T.
|
||||
*>
|
||||
*> TRANSA = 'C' or 'c', op( A ) = A**H.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANSB
|
||||
*> \verbatim
|
||||
*> TRANSB is CHARACTER*1
|
||||
*> On entry, TRANSB specifies the form of op( B ) to be used in
|
||||
*> the matrix multiplication as follows:
|
||||
*>
|
||||
*> TRANSB = 'N' or 'n', op( B ) = B.
|
||||
*>
|
||||
*> TRANSB = 'T' or 't', op( B ) = B**T.
|
||||
*>
|
||||
*> TRANSB = 'C' or 'c', op( B ) = B**H.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of the matrix
|
||||
*> op( A ) and of the matrix C. M must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of the matrix
|
||||
*> op( B ) and the number of columns of the matrix C. N must be
|
||||
*> at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> On entry, K specifies the number of columns of the matrix
|
||||
*> op( A ) and the number of rows of the matrix op( B ). K must
|
||||
*> be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array of DIMENSION ( LDA, ka ), where ka is
|
||||
*> k when TRANSA = 'N' or 'n', and is m otherwise.
|
||||
*> Before entry with TRANSA = 'N' or 'n', the leading m by k
|
||||
*> part of the array A must contain the matrix A, otherwise
|
||||
*> the leading k by m part of the array A must contain the
|
||||
*> matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. When TRANSA = 'N' or 'n' then
|
||||
*> LDA must be at least max( 1, m ), otherwise LDA must be at
|
||||
*> least max( 1, k ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> B is COMPLEX array of DIMENSION ( LDB, kb ), where kb is
|
||||
*> n when TRANSB = 'N' or 'n', and is k otherwise.
|
||||
*> Before entry with TRANSB = 'N' or 'n', the leading k by n
|
||||
*> part of the array B must contain the matrix B, otherwise
|
||||
*> the leading n by k part of the array B must contain the
|
||||
*> matrix B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> On entry, LDB specifies the first dimension of B as declared
|
||||
*> in the calling (sub) program. When TRANSB = 'N' or 'n' then
|
||||
*> LDB must be at least max( 1, k ), otherwise LDB must be at
|
||||
*> least max( 1, n ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is COMPLEX
|
||||
*> On entry, BETA specifies the scalar beta. When BETA is
|
||||
*> supplied as zero then C need not be set on input.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is COMPLEX array of DIMENSION ( LDC, n ).
|
||||
*> Before entry, the leading m by n part of the array C must
|
||||
*> contain the matrix C, except when beta is zero, in which
|
||||
*> case C need not be set on entry.
|
||||
*> On exit, the array C is overwritten by the m by n matrix
|
||||
*> ( alpha*op( A )*op( B ) + beta*C ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> On entry, LDC specifies the first dimension of C as declared
|
||||
*> in the calling (sub) program. LDC must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level3
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 3 Blas routine.
|
||||
*>
|
||||
*> -- Written on 8-February-1989.
|
||||
*> Jack Dongarra, Argonne National Laboratory.
|
||||
*> Iain Duff, AERE Harwell.
|
||||
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
*> Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* -- Reference BLAS level3 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX ALPHA,BETA
|
||||
INTEGER K,LDA,LDB,LDC,M,N
|
||||
CHARACTER TRANSA,TRANSB
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG,MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP
|
||||
INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB
|
||||
LOGICAL CONJA,CONJB,NOTA,NOTB
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
COMPLEX ONE
|
||||
PARAMETER (ONE= (1.0E+0,0.0E+0))
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
*
|
||||
* Set NOTA and NOTB as true if A and B respectively are not
|
||||
* conjugated or transposed, set CONJA and CONJB as true if A and
|
||||
* B respectively are to be transposed but not conjugated and set
|
||||
* NROWA, NCOLA and NROWB as the number of rows and columns of A
|
||||
* and the number of rows of B respectively.
|
||||
*
|
||||
NOTA = LSAME(TRANSA,'N')
|
||||
NOTB = LSAME(TRANSB,'N')
|
||||
CONJA = LSAME(TRANSA,'C')
|
||||
CONJB = LSAME(TRANSB,'C')
|
||||
IF (NOTA) THEN
|
||||
NROWA = M
|
||||
NCOLA = K
|
||||
ELSE
|
||||
NROWA = K
|
||||
NCOLA = M
|
||||
END IF
|
||||
IF (NOTB) THEN
|
||||
NROWB = K
|
||||
ELSE
|
||||
NROWB = N
|
||||
END IF
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.NOTA) .AND. (.NOT.CONJA) .AND.
|
||||
+ (.NOT.LSAME(TRANSA,'T'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND.
|
||||
+ (.NOT.LSAME(TRANSB,'T'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 8
|
||||
ELSE IF (LDB.LT.MAX(1,NROWB)) THEN
|
||||
INFO = 10
|
||||
ELSE IF (LDC.LT.MAX(1,M)) THEN
|
||||
INFO = 13
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CGEMM ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
|
||||
+ (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* And when alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
DO 30 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
END IF
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (NOTB) THEN
|
||||
IF (NOTA) THEN
|
||||
*
|
||||
* Form C := alpha*A*B + beta*C.
|
||||
*
|
||||
DO 90 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 50 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
50 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 60 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
60 CONTINUE
|
||||
END IF
|
||||
DO 80 L = 1,K
|
||||
IF (B(L,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(L,J)
|
||||
DO 70 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
70 CONTINUE
|
||||
END IF
|
||||
80 CONTINUE
|
||||
90 CONTINUE
|
||||
ELSE IF (CONJA) THEN
|
||||
*
|
||||
* Form C := alpha*A**H*B + beta*C.
|
||||
*
|
||||
DO 120 J = 1,N
|
||||
DO 110 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 100 L = 1,K
|
||||
TEMP = TEMP + CONJG(A(L,I))*B(L,J)
|
||||
100 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
110 CONTINUE
|
||||
120 CONTINUE
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**T*B + beta*C
|
||||
*
|
||||
DO 150 J = 1,N
|
||||
DO 140 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 130 L = 1,K
|
||||
TEMP = TEMP + A(L,I)*B(L,J)
|
||||
130 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
140 CONTINUE
|
||||
150 CONTINUE
|
||||
END IF
|
||||
ELSE IF (NOTA) THEN
|
||||
IF (CONJB) THEN
|
||||
*
|
||||
* Form C := alpha*A*B**H + beta*C.
|
||||
*
|
||||
DO 200 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 160 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
160 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 170 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
170 CONTINUE
|
||||
END IF
|
||||
DO 190 L = 1,K
|
||||
IF (B(J,L).NE.ZERO) THEN
|
||||
TEMP = ALPHA*CONJG(B(J,L))
|
||||
DO 180 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
180 CONTINUE
|
||||
END IF
|
||||
190 CONTINUE
|
||||
200 CONTINUE
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A*B**T + beta*C
|
||||
*
|
||||
DO 250 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 210 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
210 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 220 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
220 CONTINUE
|
||||
END IF
|
||||
DO 240 L = 1,K
|
||||
IF (B(J,L).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(J,L)
|
||||
DO 230 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
230 CONTINUE
|
||||
END IF
|
||||
240 CONTINUE
|
||||
250 CONTINUE
|
||||
END IF
|
||||
ELSE IF (CONJA) THEN
|
||||
IF (CONJB) THEN
|
||||
*
|
||||
* Form C := alpha*A**H*B**H + beta*C.
|
||||
*
|
||||
DO 280 J = 1,N
|
||||
DO 270 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 260 L = 1,K
|
||||
TEMP = TEMP + CONJG(A(L,I))*CONJG(B(J,L))
|
||||
260 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
270 CONTINUE
|
||||
280 CONTINUE
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**H*B**T + beta*C
|
||||
*
|
||||
DO 310 J = 1,N
|
||||
DO 300 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 290 L = 1,K
|
||||
TEMP = TEMP + CONJG(A(L,I))*B(J,L)
|
||||
290 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
300 CONTINUE
|
||||
310 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (CONJB) THEN
|
||||
*
|
||||
* Form C := alpha*A**T*B**H + beta*C
|
||||
*
|
||||
DO 340 J = 1,N
|
||||
DO 330 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 320 L = 1,K
|
||||
TEMP = TEMP + A(L,I)*CONJG(B(J,L))
|
||||
320 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
330 CONTINUE
|
||||
340 CONTINUE
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**T*B**T + beta*C
|
||||
*
|
||||
DO 370 J = 1,N
|
||||
DO 360 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 350 L = 1,K
|
||||
TEMP = TEMP + A(L,I)*B(J,L)
|
||||
350 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
360 CONTINUE
|
||||
370 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CGEMM .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,354 +0,0 @@
|
|||
*> \brief \b CGEMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX ALPHA,BETA
|
||||
* INTEGER INCX,INCY,LDA,M,N
|
||||
* CHARACTER TRANS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CGEMV performs one of the matrix-vector operations
|
||||
*>
|
||||
*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or
|
||||
*>
|
||||
*> y := alpha*A**H*x + beta*y,
|
||||
*>
|
||||
*> where alpha and beta are scalars, x and y are vectors and A is an
|
||||
*> m by n matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the operation to be performed as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' y := alpha*A**H*x + beta*y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of the matrix A.
|
||||
*> M must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array of DIMENSION ( LDA, n ).
|
||||
*> Before entry, the leading m by n part of the array A must
|
||||
*> contain the matrix of coefficients.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array of DIMENSION at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
|
||||
*> and at least
|
||||
*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
|
||||
*> Before entry, the incremented array X must contain the
|
||||
*> vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is COMPLEX
|
||||
*> On entry, BETA specifies the scalar beta. When BETA is
|
||||
*> supplied as zero then Y need not be set on input.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] Y
|
||||
*> \verbatim
|
||||
*> Y is COMPLEX array of DIMENSION at least
|
||||
*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
|
||||
*> and at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
|
||||
*> Before entry with BETA non-zero, the incremented array Y
|
||||
*> must contain the vector y. On exit, Y is overwritten by the
|
||||
*> updated vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX ALPHA,BETA
|
||||
INTEGER INCX,INCY,LDA,M,N
|
||||
CHARACTER TRANS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ONE
|
||||
PARAMETER (ONE= (1.0E+0,0.0E+0))
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY
|
||||
LOGICAL NOCONJ
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG,MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (LDA.LT.MAX(1,M)) THEN
|
||||
INFO = 6
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 8
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 11
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CGEMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
|
||||
+ ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
NOCONJ = LSAME(TRANS,'T')
|
||||
*
|
||||
* Set LENX and LENY, the lengths of the vectors x and y, and set
|
||||
* up the start points in X and Y.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
LENX = N
|
||||
LENY = M
|
||||
ELSE
|
||||
LENX = M
|
||||
LENY = N
|
||||
END IF
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (LENX-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (LENY-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,LENY
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,LENY
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,LENY
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,LENY
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form y := alpha*A*x + y.
|
||||
*
|
||||
JX = KX
|
||||
IF (INCY.EQ.1) THEN
|
||||
DO 60 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
DO 50 I = 1,M
|
||||
Y(I) = Y(I) + TEMP*A(I,J)
|
||||
50 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
IY = KY
|
||||
DO 70 I = 1,M
|
||||
Y(IY) = Y(IY) + TEMP*A(I,J)
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y := alpha*A**T*x + y or y := alpha*A**H*x + y.
|
||||
*
|
||||
JY = KY
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 110 J = 1,N
|
||||
TEMP = ZERO
|
||||
IF (NOCONJ) THEN
|
||||
DO 90 I = 1,M
|
||||
TEMP = TEMP + A(I,J)*X(I)
|
||||
90 CONTINUE
|
||||
ELSE
|
||||
DO 100 I = 1,M
|
||||
TEMP = TEMP + CONJG(A(I,J))*X(I)
|
||||
100 CONTINUE
|
||||
END IF
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP
|
||||
JY = JY + INCY
|
||||
110 CONTINUE
|
||||
ELSE
|
||||
DO 140 J = 1,N
|
||||
TEMP = ZERO
|
||||
IX = KX
|
||||
IF (NOCONJ) THEN
|
||||
DO 120 I = 1,M
|
||||
TEMP = TEMP + A(I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
120 CONTINUE
|
||||
ELSE
|
||||
DO 130 I = 1,M
|
||||
TEMP = TEMP + CONJG(A(I,J))*X(IX)
|
||||
IX = IX + INCX
|
||||
130 CONTINUE
|
||||
END IF
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP
|
||||
JY = JY + INCY
|
||||
140 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CGEMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,227 +0,0 @@
|
|||
*> \brief \b CGERC
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX ALPHA
|
||||
* INTEGER INCX,INCY,LDA,M,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CGERC performs the rank 1 operation
|
||||
*>
|
||||
*> A := alpha*x*y**H + A,
|
||||
*>
|
||||
*> where alpha is a scalar, x is an m element vector, y is an n element
|
||||
*> vector and A is an m by n matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of the matrix A.
|
||||
*> M must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array of dimension at least
|
||||
*> ( 1 + ( m - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the m
|
||||
*> element vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] Y
|
||||
*> \verbatim
|
||||
*> Y is COMPLEX array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
*> Before entry, the incremented array Y must contain the n
|
||||
*> element vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array of DIMENSION ( LDA, n ).
|
||||
*> Before entry, the leading m by n part of the array A must
|
||||
*> contain the matrix of coefficients. On exit, A is
|
||||
*> overwritten by the updated matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX ALPHA
|
||||
INTEGER INCX,INCY,LDA,M,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP
|
||||
INTEGER I,INFO,IX,J,JY,KX
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG,MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (M.LT.0) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDA.LT.MAX(1,M)) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CGERC ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
IF (INCY.GT.0) THEN
|
||||
JY = 1
|
||||
ELSE
|
||||
JY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = 1,N
|
||||
IF (Y(JY).NE.ZERO) THEN
|
||||
TEMP = ALPHA*CONJG(Y(JY))
|
||||
DO 10 I = 1,M
|
||||
A(I,J) = A(I,J) + X(I)*TEMP
|
||||
10 CONTINUE
|
||||
END IF
|
||||
JY = JY + INCY
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (M-1)*INCX
|
||||
END IF
|
||||
DO 40 J = 1,N
|
||||
IF (Y(JY).NE.ZERO) THEN
|
||||
TEMP = ALPHA*CONJG(Y(JY))
|
||||
IX = KX
|
||||
DO 30 I = 1,M
|
||||
A(I,J) = A(I,J) + X(IX)*TEMP
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JY = JY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CGERC .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,227 +0,0 @@
|
|||
*> \brief \b CGERU
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX ALPHA
|
||||
* INTEGER INCX,INCY,LDA,M,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CGERU performs the rank 1 operation
|
||||
*>
|
||||
*> A := alpha*x*y**T + A,
|
||||
*>
|
||||
*> where alpha is a scalar, x is an m element vector, y is an n element
|
||||
*> vector and A is an m by n matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of the matrix A.
|
||||
*> M must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array of dimension at least
|
||||
*> ( 1 + ( m - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the m
|
||||
*> element vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] Y
|
||||
*> \verbatim
|
||||
*> Y is COMPLEX array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
*> Before entry, the incremented array Y must contain the n
|
||||
*> element vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array of DIMENSION ( LDA, n ).
|
||||
*> Before entry, the leading m by n part of the array A must
|
||||
*> contain the matrix of coefficients. On exit, A is
|
||||
*> overwritten by the updated matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX ALPHA
|
||||
INTEGER INCX,INCY,LDA,M,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP
|
||||
INTEGER I,INFO,IX,J,JY,KX
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (M.LT.0) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDA.LT.MAX(1,M)) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CGERU ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
IF (INCY.GT.0) THEN
|
||||
JY = 1
|
||||
ELSE
|
||||
JY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = 1,N
|
||||
IF (Y(JY).NE.ZERO) THEN
|
||||
TEMP = ALPHA*Y(JY)
|
||||
DO 10 I = 1,M
|
||||
A(I,J) = A(I,J) + X(I)*TEMP
|
||||
10 CONTINUE
|
||||
END IF
|
||||
JY = JY + INCY
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (M-1)*INCX
|
||||
END IF
|
||||
DO 40 J = 1,N
|
||||
IF (Y(JY).NE.ZERO) THEN
|
||||
TEMP = ALPHA*Y(JY)
|
||||
IX = KX
|
||||
DO 30 I = 1,M
|
||||
A(I,J) = A(I,J) + X(IX)*TEMP
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JY = JY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CGERU .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,380 +0,0 @@
|
|||
*> \brief \b CHBMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX ALPHA,BETA
|
||||
* INTEGER INCX,INCY,K,LDA,N
|
||||
* CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CHBMV performs the matrix-vector operation
|
||||
*>
|
||||
*> y := alpha*A*x + beta*y,
|
||||
*>
|
||||
*> where alpha and beta are scalars, x and y are n element vectors and
|
||||
*> A is an n by n hermitian band matrix, with k super-diagonals.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the band matrix A is being supplied as
|
||||
*> follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' The upper triangular part of A is
|
||||
*> being supplied.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' The lower triangular part of A is
|
||||
*> being supplied.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> On entry, K specifies the number of super-diagonals of the
|
||||
*> matrix A. K must satisfy 0 .le. K.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array of DIMENSION ( LDA, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
|
||||
*> by n part of the array A must contain the upper triangular
|
||||
*> band part of the hermitian matrix, supplied column by
|
||||
*> column, with the leading diagonal of the matrix in row
|
||||
*> ( k + 1 ) of the array, the first super-diagonal starting at
|
||||
*> position 2 in row k, and so on. The top left k by k triangle
|
||||
*> of the array A is not referenced.
|
||||
*> The following program segment will transfer the upper
|
||||
*> triangular part of a hermitian band matrix from conventional
|
||||
*> full matrix storage to band storage:
|
||||
*>
|
||||
*> DO 20, J = 1, N
|
||||
*> M = K + 1 - J
|
||||
*> DO 10, I = MAX( 1, J - K ), J
|
||||
*> A( M + I, J ) = matrix( I, J )
|
||||
*> 10 CONTINUE
|
||||
*> 20 CONTINUE
|
||||
*>
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
|
||||
*> by n part of the array A must contain the lower triangular
|
||||
*> band part of the hermitian matrix, supplied column by
|
||||
*> column, with the leading diagonal of the matrix in row 1 of
|
||||
*> the array, the first sub-diagonal starting at position 1 in
|
||||
*> row 2, and so on. The bottom right k by k triangle of the
|
||||
*> array A is not referenced.
|
||||
*> The following program segment will transfer the lower
|
||||
*> triangular part of a hermitian band matrix from conventional
|
||||
*> full matrix storage to band storage:
|
||||
*>
|
||||
*> DO 20, J = 1, N
|
||||
*> M = 1 - J
|
||||
*> DO 10, I = J, MIN( N, J + K )
|
||||
*> A( M + I, J ) = matrix( I, J )
|
||||
*> 10 CONTINUE
|
||||
*> 20 CONTINUE
|
||||
*>
|
||||
*> Note that the imaginary parts of the diagonal elements need
|
||||
*> not be set and are assumed to be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> ( k + 1 ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array of DIMENSION at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the
|
||||
*> vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is COMPLEX
|
||||
*> On entry, BETA specifies the scalar beta.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] Y
|
||||
*> \verbatim
|
||||
*> Y is COMPLEX array of DIMENSION at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
*> Before entry, the incremented array Y must contain the
|
||||
*> vector y. On exit, Y is overwritten by the updated vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX ALPHA,BETA
|
||||
INTEGER INCX,INCY,K,LDA,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ONE
|
||||
PARAMETER (ONE= (1.0E+0,0.0E+0))
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,KPLUS1,KX,KY,L
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG,MAX,MIN,REAL
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (LDA.LT. (K+1)) THEN
|
||||
INFO = 6
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 8
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 11
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CHBMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* Set up the start points in X and Y.
|
||||
*
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (N-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of the array A
|
||||
* are accessed sequentially with one pass through A.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,N
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,N
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,N
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,N
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form y when upper triangle of A is stored.
|
||||
*
|
||||
KPLUS1 = K + 1
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 60 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
L = KPLUS1 - J
|
||||
DO 50 I = MAX(1,J-K),J - 1
|
||||
Y(I) = Y(I) + TEMP1*A(L+I,J)
|
||||
TEMP2 = TEMP2 + CONJG(A(L+I,J))*X(I)
|
||||
50 CONTINUE
|
||||
Y(J) = Y(J) + TEMP1*REAL(A(KPLUS1,J)) + ALPHA*TEMP2
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 80 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
IX = KX
|
||||
IY = KY
|
||||
L = KPLUS1 - J
|
||||
DO 70 I = MAX(1,J-K),J - 1
|
||||
Y(IY) = Y(IY) + TEMP1*A(L+I,J)
|
||||
TEMP2 = TEMP2 + CONJG(A(L+I,J))*X(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
Y(JY) = Y(JY) + TEMP1*REAL(A(KPLUS1,J)) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
IF (J.GT.K) THEN
|
||||
KX = KX + INCX
|
||||
KY = KY + INCY
|
||||
END IF
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y when lower triangle of A is stored.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
Y(J) = Y(J) + TEMP1*REAL(A(1,J))
|
||||
L = 1 - J
|
||||
DO 90 I = J + 1,MIN(N,J+K)
|
||||
Y(I) = Y(I) + TEMP1*A(L+I,J)
|
||||
TEMP2 = TEMP2 + CONJG(A(L+I,J))*X(I)
|
||||
90 CONTINUE
|
||||
Y(J) = Y(J) + ALPHA*TEMP2
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 120 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
Y(JY) = Y(JY) + TEMP1*REAL(A(1,J))
|
||||
L = 1 - J
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 110 I = J + 1,MIN(N,J+K)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
Y(IY) = Y(IY) + TEMP1*A(L+I,J)
|
||||
TEMP2 = TEMP2 + CONJG(A(L+I,J))*X(IX)
|
||||
110 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CHBMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,371 +0,0 @@
|
|||
*> \brief \b CHEMM
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX ALPHA,BETA
|
||||
* INTEGER LDA,LDB,LDC,M,N
|
||||
* CHARACTER SIDE,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CHEMM performs one of the matrix-matrix operations
|
||||
*>
|
||||
*> C := alpha*A*B + beta*C,
|
||||
*>
|
||||
*> or
|
||||
*>
|
||||
*> C := alpha*B*A + beta*C,
|
||||
*>
|
||||
*> where alpha and beta are scalars, A is an hermitian matrix and B and
|
||||
*> C are m by n matrices.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> On entry, SIDE specifies whether the hermitian matrix A
|
||||
*> appears on the left or right in the operation as follows:
|
||||
*>
|
||||
*> SIDE = 'L' or 'l' C := alpha*A*B + beta*C,
|
||||
*>
|
||||
*> SIDE = 'R' or 'r' C := alpha*B*A + beta*C,
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the hermitian matrix A is to be
|
||||
*> referenced as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' Only the upper triangular part of the
|
||||
*> hermitian matrix is to be referenced.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' Only the lower triangular part of the
|
||||
*> hermitian matrix is to be referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of the matrix C.
|
||||
*> M must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of the matrix C.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array of DIMENSION ( LDA, ka ), where ka is
|
||||
*> m when SIDE = 'L' or 'l' and is n otherwise.
|
||||
*> Before entry with SIDE = 'L' or 'l', the m by m part of
|
||||
*> the array A must contain the hermitian matrix, such that
|
||||
*> when UPLO = 'U' or 'u', the leading m by m upper triangular
|
||||
*> part of the array A must contain the upper triangular part
|
||||
*> of the hermitian matrix and the strictly lower triangular
|
||||
*> part of A is not referenced, and when UPLO = 'L' or 'l',
|
||||
*> the leading m by m lower triangular part of the array A
|
||||
*> must contain the lower triangular part of the hermitian
|
||||
*> matrix and the strictly upper triangular part of A is not
|
||||
*> referenced.
|
||||
*> Before entry with SIDE = 'R' or 'r', the n by n part of
|
||||
*> the array A must contain the hermitian matrix, such that
|
||||
*> when UPLO = 'U' or 'u', the leading n by n upper triangular
|
||||
*> part of the array A must contain the upper triangular part
|
||||
*> of the hermitian matrix and the strictly lower triangular
|
||||
*> part of A is not referenced, and when UPLO = 'L' or 'l',
|
||||
*> the leading n by n lower triangular part of the array A
|
||||
*> must contain the lower triangular part of the hermitian
|
||||
*> matrix and the strictly upper triangular part of A is not
|
||||
*> referenced.
|
||||
*> Note that the imaginary parts of the diagonal elements need
|
||||
*> not be set, they are assumed to be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. When SIDE = 'L' or 'l' then
|
||||
*> LDA must be at least max( 1, m ), otherwise LDA must be at
|
||||
*> least max( 1, n ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> B is COMPLEX array of DIMENSION ( LDB, n ).
|
||||
*> Before entry, the leading m by n part of the array B must
|
||||
*> contain the matrix B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> On entry, LDB specifies the first dimension of B as declared
|
||||
*> in the calling (sub) program. LDB must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is COMPLEX
|
||||
*> On entry, BETA specifies the scalar beta. When BETA is
|
||||
*> supplied as zero then C need not be set on input.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is COMPLEX array of DIMENSION ( LDC, n ).
|
||||
*> Before entry, the leading m by n part of the array C must
|
||||
*> contain the matrix C, except when beta is zero, in which
|
||||
*> case C need not be set on entry.
|
||||
*> On exit, the array C is overwritten by the m by n updated
|
||||
*> matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> On entry, LDC specifies the first dimension of C as declared
|
||||
*> in the calling (sub) program. LDC must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level3
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 3 Blas routine.
|
||||
*>
|
||||
*> -- Written on 8-February-1989.
|
||||
*> Jack Dongarra, Argonne National Laboratory.
|
||||
*> Iain Duff, AERE Harwell.
|
||||
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
*> Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* -- Reference BLAS level3 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX ALPHA,BETA
|
||||
INTEGER LDA,LDB,LDC,M,N
|
||||
CHARACTER SIDE,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG,MAX,REAL
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP1,TEMP2
|
||||
INTEGER I,INFO,J,K,NROWA
|
||||
LOGICAL UPPER
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
COMPLEX ONE
|
||||
PARAMETER (ONE= (1.0E+0,0.0E+0))
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
*
|
||||
* Set NROWA as the number of rows of A.
|
||||
*
|
||||
IF (LSAME(SIDE,'L')) THEN
|
||||
NROWA = M
|
||||
ELSE
|
||||
NROWA = N
|
||||
END IF
|
||||
UPPER = LSAME(UPLO,'U')
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.LSAME(SIDE,'L')) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDB.LT.MAX(1,M)) THEN
|
||||
INFO = 9
|
||||
ELSE IF (LDC.LT.MAX(1,M)) THEN
|
||||
INFO = 12
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CHEMM ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
|
||||
+ ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* And when alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
DO 30 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
END IF
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (LSAME(SIDE,'L')) THEN
|
||||
*
|
||||
* Form C := alpha*A*B + beta*C.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 70 J = 1,N
|
||||
DO 60 I = 1,M
|
||||
TEMP1 = ALPHA*B(I,J)
|
||||
TEMP2 = ZERO
|
||||
DO 50 K = 1,I - 1
|
||||
C(K,J) = C(K,J) + TEMP1*A(K,I)
|
||||
TEMP2 = TEMP2 + B(K,J)*CONJG(A(K,I))
|
||||
50 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = TEMP1*REAL(A(I,I)) + ALPHA*TEMP2
|
||||
ELSE
|
||||
C(I,J) = BETA*C(I,J) + TEMP1*REAL(A(I,I)) +
|
||||
+ ALPHA*TEMP2
|
||||
END IF
|
||||
60 CONTINUE
|
||||
70 CONTINUE
|
||||
ELSE
|
||||
DO 100 J = 1,N
|
||||
DO 90 I = M,1,-1
|
||||
TEMP1 = ALPHA*B(I,J)
|
||||
TEMP2 = ZERO
|
||||
DO 80 K = I + 1,M
|
||||
C(K,J) = C(K,J) + TEMP1*A(K,I)
|
||||
TEMP2 = TEMP2 + B(K,J)*CONJG(A(K,I))
|
||||
80 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = TEMP1*REAL(A(I,I)) + ALPHA*TEMP2
|
||||
ELSE
|
||||
C(I,J) = BETA*C(I,J) + TEMP1*REAL(A(I,I)) +
|
||||
+ ALPHA*TEMP2
|
||||
END IF
|
||||
90 CONTINUE
|
||||
100 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*B*A + beta*C.
|
||||
*
|
||||
DO 170 J = 1,N
|
||||
TEMP1 = ALPHA*REAL(A(J,J))
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 110 I = 1,M
|
||||
C(I,J) = TEMP1*B(I,J)
|
||||
110 CONTINUE
|
||||
ELSE
|
||||
DO 120 I = 1,M
|
||||
C(I,J) = BETA*C(I,J) + TEMP1*B(I,J)
|
||||
120 CONTINUE
|
||||
END IF
|
||||
DO 140 K = 1,J - 1
|
||||
IF (UPPER) THEN
|
||||
TEMP1 = ALPHA*A(K,J)
|
||||
ELSE
|
||||
TEMP1 = ALPHA*CONJG(A(J,K))
|
||||
END IF
|
||||
DO 130 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP1*B(I,K)
|
||||
130 CONTINUE
|
||||
140 CONTINUE
|
||||
DO 160 K = J + 1,N
|
||||
IF (UPPER) THEN
|
||||
TEMP1 = ALPHA*CONJG(A(J,K))
|
||||
ELSE
|
||||
TEMP1 = ALPHA*A(K,J)
|
||||
END IF
|
||||
DO 150 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP1*B(I,K)
|
||||
150 CONTINUE
|
||||
160 CONTINUE
|
||||
170 CONTINUE
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CHEMM .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,337 +0,0 @@
|
|||
*> \brief \b CHEMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX ALPHA,BETA
|
||||
* INTEGER INCX,INCY,LDA,N
|
||||
* CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CHEMV performs the matrix-vector operation
|
||||
*>
|
||||
*> y := alpha*A*x + beta*y,
|
||||
*>
|
||||
*> where alpha and beta are scalars, x and y are n element vectors and
|
||||
*> A is an n by n hermitian matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the array A is to be referenced as
|
||||
*> follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' Only the upper triangular part of A
|
||||
*> is to be referenced.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' Only the lower triangular part of A
|
||||
*> is to be referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array of DIMENSION ( LDA, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
*> upper triangular part of the array A must contain the upper
|
||||
*> triangular part of the hermitian matrix and the strictly
|
||||
*> lower triangular part of A is not referenced.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
*> lower triangular part of the array A must contain the lower
|
||||
*> triangular part of the hermitian matrix and the strictly
|
||||
*> upper triangular part of A is not referenced.
|
||||
*> Note that the imaginary parts of the diagonal elements need
|
||||
*> not be set and are assumed to be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, n ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is COMPLEX
|
||||
*> On entry, BETA specifies the scalar beta. When BETA is
|
||||
*> supplied as zero then Y need not be set on input.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] Y
|
||||
*> \verbatim
|
||||
*> Y is COMPLEX array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
*> Before entry, the incremented array Y must contain the n
|
||||
*> element vector y. On exit, Y is overwritten by the updated
|
||||
*> vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX ALPHA,BETA
|
||||
INTEGER INCX,INCY,LDA,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ONE
|
||||
PARAMETER (ONE= (1.0E+0,0.0E+0))
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG,MAX,REAL
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (LDA.LT.MAX(1,N)) THEN
|
||||
INFO = 5
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 7
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 10
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CHEMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* Set up the start points in X and Y.
|
||||
*
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (N-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through the triangular part
|
||||
* of A.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,N
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,N
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,N
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,N
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form y when A is stored in upper triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 60 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
DO 50 I = 1,J - 1
|
||||
Y(I) = Y(I) + TEMP1*A(I,J)
|
||||
TEMP2 = TEMP2 + CONJG(A(I,J))*X(I)
|
||||
50 CONTINUE
|
||||
Y(J) = Y(J) + TEMP1*REAL(A(J,J)) + ALPHA*TEMP2
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 80 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
IX = KX
|
||||
IY = KY
|
||||
DO 70 I = 1,J - 1
|
||||
Y(IY) = Y(IY) + TEMP1*A(I,J)
|
||||
TEMP2 = TEMP2 + CONJG(A(I,J))*X(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
Y(JY) = Y(JY) + TEMP1*REAL(A(J,J)) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y when A is stored in lower triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
Y(J) = Y(J) + TEMP1*REAL(A(J,J))
|
||||
DO 90 I = J + 1,N
|
||||
Y(I) = Y(I) + TEMP1*A(I,J)
|
||||
TEMP2 = TEMP2 + CONJG(A(I,J))*X(I)
|
||||
90 CONTINUE
|
||||
Y(J) = Y(J) + ALPHA*TEMP2
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 120 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
Y(JY) = Y(JY) + TEMP1*REAL(A(J,J))
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 110 I = J + 1,N
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
Y(IY) = Y(IY) + TEMP1*A(I,J)
|
||||
TEMP2 = TEMP2 + CONJG(A(I,J))*X(IX)
|
||||
110 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CHEMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,278 +0,0 @@
|
|||
*> \brief \b CHER
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CHER(UPLO,N,ALPHA,X,INCX,A,LDA)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* REAL ALPHA
|
||||
* INTEGER INCX,LDA,N
|
||||
* CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CHER performs the hermitian rank 1 operation
|
||||
*>
|
||||
*> A := alpha*x*x**H + A,
|
||||
*>
|
||||
*> where alpha is a real scalar, x is an n element vector and A is an
|
||||
*> n by n hermitian matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the array A is to be referenced as
|
||||
*> follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' Only the upper triangular part of A
|
||||
*> is to be referenced.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' Only the lower triangular part of A
|
||||
*> is to be referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is REAL
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array of DIMENSION ( LDA, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
*> upper triangular part of the array A must contain the upper
|
||||
*> triangular part of the hermitian matrix and the strictly
|
||||
*> lower triangular part of A is not referenced. On exit, the
|
||||
*> upper triangular part of the array A is overwritten by the
|
||||
*> upper triangular part of the updated matrix.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
*> lower triangular part of the array A must contain the lower
|
||||
*> triangular part of the hermitian matrix and the strictly
|
||||
*> upper triangular part of A is not referenced. On exit, the
|
||||
*> lower triangular part of the array A is overwritten by the
|
||||
*> lower triangular part of the updated matrix.
|
||||
*> Note that the imaginary parts of the diagonal elements need
|
||||
*> not be set, they are assumed to be zero, and on exit they
|
||||
*> are set to zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, n ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CHER(UPLO,N,ALPHA,X,INCX,A,LDA)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL ALPHA
|
||||
INTEGER INCX,LDA,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP
|
||||
INTEGER I,INFO,IX,J,JX,KX
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG,MAX,REAL
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (LDA.LT.MAX(1,N)) THEN
|
||||
INFO = 7
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CHER ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. (ALPHA.EQ.REAL(ZERO))) RETURN
|
||||
*
|
||||
* Set the start point in X if the increment is not unity.
|
||||
*
|
||||
IF (INCX.LE.0) THEN
|
||||
KX = 1 - (N-1)*INCX
|
||||
ELSE IF (INCX.NE.1) THEN
|
||||
KX = 1
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through the triangular part
|
||||
* of A.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form A when A is stored in upper triangle.
|
||||
*
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*CONJG(X(J))
|
||||
DO 10 I = 1,J - 1
|
||||
A(I,J) = A(I,J) + X(I)*TEMP
|
||||
10 CONTINUE
|
||||
A(J,J) = REAL(A(J,J)) + REAL(X(J)*TEMP)
|
||||
ELSE
|
||||
A(J,J) = REAL(A(J,J))
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 40 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*CONJG(X(JX))
|
||||
IX = KX
|
||||
DO 30 I = 1,J - 1
|
||||
A(I,J) = A(I,J) + X(IX)*TEMP
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
A(J,J) = REAL(A(J,J)) + REAL(X(JX)*TEMP)
|
||||
ELSE
|
||||
A(J,J) = REAL(A(J,J))
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form A when A is stored in lower triangle.
|
||||
*
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 60 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*CONJG(X(J))
|
||||
A(J,J) = REAL(A(J,J)) + REAL(TEMP*X(J))
|
||||
DO 50 I = J + 1,N
|
||||
A(I,J) = A(I,J) + X(I)*TEMP
|
||||
50 CONTINUE
|
||||
ELSE
|
||||
A(J,J) = REAL(A(J,J))
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 80 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*CONJG(X(JX))
|
||||
A(J,J) = REAL(A(J,J)) + REAL(TEMP*X(JX))
|
||||
IX = JX
|
||||
DO 70 I = J + 1,N
|
||||
IX = IX + INCX
|
||||
A(I,J) = A(I,J) + X(IX)*TEMP
|
||||
70 CONTINUE
|
||||
ELSE
|
||||
A(J,J) = REAL(A(J,J))
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CHER .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,317 +0,0 @@
|
|||
*> \brief \b CHER2
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX ALPHA
|
||||
* INTEGER INCX,INCY,LDA,N
|
||||
* CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CHER2 performs the hermitian rank 2 operation
|
||||
*>
|
||||
*> A := alpha*x*y**H + conjg( alpha )*y*x**H + A,
|
||||
*>
|
||||
*> where alpha is a scalar, x and y are n element vectors and A is an n
|
||||
*> by n hermitian matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the array A is to be referenced as
|
||||
*> follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' Only the upper triangular part of A
|
||||
*> is to be referenced.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' Only the lower triangular part of A
|
||||
*> is to be referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] Y
|
||||
*> \verbatim
|
||||
*> Y is COMPLEX array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
*> Before entry, the incremented array Y must contain the n
|
||||
*> element vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array of DIMENSION ( LDA, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
*> upper triangular part of the array A must contain the upper
|
||||
*> triangular part of the hermitian matrix and the strictly
|
||||
*> lower triangular part of A is not referenced. On exit, the
|
||||
*> upper triangular part of the array A is overwritten by the
|
||||
*> upper triangular part of the updated matrix.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
*> lower triangular part of the array A must contain the lower
|
||||
*> triangular part of the hermitian matrix and the strictly
|
||||
*> upper triangular part of A is not referenced. On exit, the
|
||||
*> lower triangular part of the array A is overwritten by the
|
||||
*> lower triangular part of the updated matrix.
|
||||
*> Note that the imaginary parts of the diagonal elements need
|
||||
*> not be set, they are assumed to be zero, and on exit they
|
||||
*> are set to zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, n ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX ALPHA
|
||||
INTEGER INCX,INCY,LDA,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG,MAX,REAL
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDA.LT.MAX(1,N)) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CHER2 ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
|
||||
*
|
||||
* Set up the start points in X and Y if the increments are not both
|
||||
* unity.
|
||||
*
|
||||
IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (N-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
JX = KX
|
||||
JY = KY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through the triangular part
|
||||
* of A.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form A when A is stored in the upper triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 20 J = 1,N
|
||||
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*CONJG(Y(J))
|
||||
TEMP2 = CONJG(ALPHA*X(J))
|
||||
DO 10 I = 1,J - 1
|
||||
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
|
||||
10 CONTINUE
|
||||
A(J,J) = REAL(A(J,J)) +
|
||||
+ REAL(X(J)*TEMP1+Y(J)*TEMP2)
|
||||
ELSE
|
||||
A(J,J) = REAL(A(J,J))
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*CONJG(Y(JY))
|
||||
TEMP2 = CONJG(ALPHA*X(JX))
|
||||
IX = KX
|
||||
IY = KY
|
||||
DO 30 I = 1,J - 1
|
||||
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
A(J,J) = REAL(A(J,J)) +
|
||||
+ REAL(X(JX)*TEMP1+Y(JY)*TEMP2)
|
||||
ELSE
|
||||
A(J,J) = REAL(A(J,J))
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form A when A is stored in the lower triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 60 J = 1,N
|
||||
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*CONJG(Y(J))
|
||||
TEMP2 = CONJG(ALPHA*X(J))
|
||||
A(J,J) = REAL(A(J,J)) +
|
||||
+ REAL(X(J)*TEMP1+Y(J)*TEMP2)
|
||||
DO 50 I = J + 1,N
|
||||
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
|
||||
50 CONTINUE
|
||||
ELSE
|
||||
A(J,J) = REAL(A(J,J))
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*CONJG(Y(JY))
|
||||
TEMP2 = CONJG(ALPHA*X(JX))
|
||||
A(J,J) = REAL(A(J,J)) +
|
||||
+ REAL(X(JX)*TEMP1+Y(JY)*TEMP2)
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 70 I = J + 1,N
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
|
||||
70 CONTINUE
|
||||
ELSE
|
||||
A(J,J) = REAL(A(J,J))
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CHER2 .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,442 +0,0 @@
|
|||
*> \brief \b CHER2K
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX ALPHA
|
||||
* REAL BETA
|
||||
* INTEGER K,LDA,LDB,LDC,N
|
||||
* CHARACTER TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CHER2K performs one of the hermitian rank 2k operations
|
||||
*>
|
||||
*> C := alpha*A*B**H + conjg( alpha )*B*A**H + beta*C,
|
||||
*>
|
||||
*> or
|
||||
*>
|
||||
*> C := alpha*A**H*B + conjg( alpha )*B**H*A + beta*C,
|
||||
*>
|
||||
*> where alpha and beta are scalars with beta real, C is an n by n
|
||||
*> hermitian matrix and A and B are n by k matrices in the first case
|
||||
*> and k by n matrices in the second case.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the array C is to be referenced as
|
||||
*> follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' Only the upper triangular part of C
|
||||
*> is to be referenced.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' Only the lower triangular part of C
|
||||
*> is to be referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the operation to be performed as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' C := alpha*A*B**H +
|
||||
*> conjg( alpha )*B*A**H +
|
||||
*> beta*C.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' C := alpha*A**H*B +
|
||||
*> conjg( alpha )*B**H*A +
|
||||
*> beta*C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix C. N must be
|
||||
*> at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> On entry with TRANS = 'N' or 'n', K specifies the number
|
||||
*> of columns of the matrices A and B, and on entry with
|
||||
*> TRANS = 'C' or 'c', K specifies the number of rows of the
|
||||
*> matrices A and B. K must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array of DIMENSION ( LDA, ka ), where ka is
|
||||
*> k when TRANS = 'N' or 'n', and is n otherwise.
|
||||
*> Before entry with TRANS = 'N' or 'n', the leading n by k
|
||||
*> part of the array A must contain the matrix A, otherwise
|
||||
*> the leading k by n part of the array A must contain the
|
||||
*> matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. When TRANS = 'N' or 'n'
|
||||
*> then LDA must be at least max( 1, n ), otherwise LDA must
|
||||
*> be at least max( 1, k ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> B is COMPLEX array of DIMENSION ( LDB, kb ), where kb is
|
||||
*> k when TRANS = 'N' or 'n', and is n otherwise.
|
||||
*> Before entry with TRANS = 'N' or 'n', the leading n by k
|
||||
*> part of the array B must contain the matrix B, otherwise
|
||||
*> the leading k by n part of the array B must contain the
|
||||
*> matrix B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> On entry, LDB specifies the first dimension of B as declared
|
||||
*> in the calling (sub) program. When TRANS = 'N' or 'n'
|
||||
*> then LDB must be at least max( 1, n ), otherwise LDB must
|
||||
*> be at least max( 1, k ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is REAL
|
||||
*> On entry, BETA specifies the scalar beta.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is COMPLEX array of DIMENSION ( LDC, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
*> upper triangular part of the array C must contain the upper
|
||||
*> triangular part of the hermitian matrix and the strictly
|
||||
*> lower triangular part of C is not referenced. On exit, the
|
||||
*> upper triangular part of the array C is overwritten by the
|
||||
*> upper triangular part of the updated matrix.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
*> lower triangular part of the array C must contain the lower
|
||||
*> triangular part of the hermitian matrix and the strictly
|
||||
*> upper triangular part of C is not referenced. On exit, the
|
||||
*> lower triangular part of the array C is overwritten by the
|
||||
*> lower triangular part of the updated matrix.
|
||||
*> Note that the imaginary parts of the diagonal elements need
|
||||
*> not be set, they are assumed to be zero, and on exit they
|
||||
*> are set to zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> On entry, LDC specifies the first dimension of C as declared
|
||||
*> in the calling (sub) program. LDC must be at least
|
||||
*> max( 1, n ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level3
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 3 Blas routine.
|
||||
*>
|
||||
*> -- Written on 8-February-1989.
|
||||
*> Jack Dongarra, Argonne National Laboratory.
|
||||
*> Iain Duff, AERE Harwell.
|
||||
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
*> Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*>
|
||||
*> -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1.
|
||||
*> Ed Anderson, Cray Research Inc.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* -- Reference BLAS level3 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX ALPHA
|
||||
REAL BETA
|
||||
INTEGER K,LDA,LDB,LDC,N
|
||||
CHARACTER TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG,MAX,REAL
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP1,TEMP2
|
||||
INTEGER I,INFO,J,L,NROWA
|
||||
LOGICAL UPPER
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
REAL ONE
|
||||
PARAMETER (ONE=1.0E+0)
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
NROWA = N
|
||||
ELSE
|
||||
NROWA = K
|
||||
END IF
|
||||
UPPER = LSAME(UPLO,'U')
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
|
||||
+ (.NOT.LSAME(TRANS,'C'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDB.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 9
|
||||
ELSE IF (LDC.LT.MAX(1,N)) THEN
|
||||
INFO = 12
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CHER2K',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
|
||||
+ (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* And when alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
IF (UPPER) THEN
|
||||
IF (BETA.EQ.REAL(ZERO)) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,J
|
||||
C(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
DO 30 I = 1,J - 1
|
||||
C(I,J) = BETA*C(I,J)
|
||||
30 CONTINUE
|
||||
C(J,J) = BETA*REAL(C(J,J))
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (BETA.EQ.REAL(ZERO)) THEN
|
||||
DO 60 J = 1,N
|
||||
DO 50 I = J,N
|
||||
C(I,J) = ZERO
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
C(J,J) = BETA*REAL(C(J,J))
|
||||
DO 70 I = J + 1,N
|
||||
C(I,J) = BETA*C(I,J)
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form C := alpha*A*B**H + conjg( alpha )*B*A**H +
|
||||
* C.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 130 J = 1,N
|
||||
IF (BETA.EQ.REAL(ZERO)) THEN
|
||||
DO 90 I = 1,J
|
||||
C(I,J) = ZERO
|
||||
90 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 100 I = 1,J - 1
|
||||
C(I,J) = BETA*C(I,J)
|
||||
100 CONTINUE
|
||||
C(J,J) = BETA*REAL(C(J,J))
|
||||
ELSE
|
||||
C(J,J) = REAL(C(J,J))
|
||||
END IF
|
||||
DO 120 L = 1,K
|
||||
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*CONJG(B(J,L))
|
||||
TEMP2 = CONJG(ALPHA*A(J,L))
|
||||
DO 110 I = 1,J - 1
|
||||
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
|
||||
+ B(I,L)*TEMP2
|
||||
110 CONTINUE
|
||||
C(J,J) = REAL(C(J,J)) +
|
||||
+ REAL(A(J,L)*TEMP1+B(J,L)*TEMP2)
|
||||
END IF
|
||||
120 CONTINUE
|
||||
130 CONTINUE
|
||||
ELSE
|
||||
DO 180 J = 1,N
|
||||
IF (BETA.EQ.REAL(ZERO)) THEN
|
||||
DO 140 I = J,N
|
||||
C(I,J) = ZERO
|
||||
140 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 150 I = J + 1,N
|
||||
C(I,J) = BETA*C(I,J)
|
||||
150 CONTINUE
|
||||
C(J,J) = BETA*REAL(C(J,J))
|
||||
ELSE
|
||||
C(J,J) = REAL(C(J,J))
|
||||
END IF
|
||||
DO 170 L = 1,K
|
||||
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*CONJG(B(J,L))
|
||||
TEMP2 = CONJG(ALPHA*A(J,L))
|
||||
DO 160 I = J + 1,N
|
||||
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
|
||||
+ B(I,L)*TEMP2
|
||||
160 CONTINUE
|
||||
C(J,J) = REAL(C(J,J)) +
|
||||
+ REAL(A(J,L)*TEMP1+B(J,L)*TEMP2)
|
||||
END IF
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**H*B + conjg( alpha )*B**H*A +
|
||||
* C.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 210 J = 1,N
|
||||
DO 200 I = 1,J
|
||||
TEMP1 = ZERO
|
||||
TEMP2 = ZERO
|
||||
DO 190 L = 1,K
|
||||
TEMP1 = TEMP1 + CONJG(A(L,I))*B(L,J)
|
||||
TEMP2 = TEMP2 + CONJG(B(L,I))*A(L,J)
|
||||
190 CONTINUE
|
||||
IF (I.EQ.J) THEN
|
||||
IF (BETA.EQ.REAL(ZERO)) THEN
|
||||
C(J,J) = REAL(ALPHA*TEMP1+
|
||||
+ CONJG(ALPHA)*TEMP2)
|
||||
ELSE
|
||||
C(J,J) = BETA*REAL(C(J,J)) +
|
||||
+ REAL(ALPHA*TEMP1+
|
||||
+ CONJG(ALPHA)*TEMP2)
|
||||
END IF
|
||||
ELSE
|
||||
IF (BETA.EQ.REAL(ZERO)) THEN
|
||||
C(I,J) = ALPHA*TEMP1 + CONJG(ALPHA)*TEMP2
|
||||
ELSE
|
||||
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
|
||||
+ CONJG(ALPHA)*TEMP2
|
||||
END IF
|
||||
END IF
|
||||
200 CONTINUE
|
||||
210 CONTINUE
|
||||
ELSE
|
||||
DO 240 J = 1,N
|
||||
DO 230 I = J,N
|
||||
TEMP1 = ZERO
|
||||
TEMP2 = ZERO
|
||||
DO 220 L = 1,K
|
||||
TEMP1 = TEMP1 + CONJG(A(L,I))*B(L,J)
|
||||
TEMP2 = TEMP2 + CONJG(B(L,I))*A(L,J)
|
||||
220 CONTINUE
|
||||
IF (I.EQ.J) THEN
|
||||
IF (BETA.EQ.REAL(ZERO)) THEN
|
||||
C(J,J) = REAL(ALPHA*TEMP1+
|
||||
+ CONJG(ALPHA)*TEMP2)
|
||||
ELSE
|
||||
C(J,J) = BETA*REAL(C(J,J)) +
|
||||
+ REAL(ALPHA*TEMP1+
|
||||
+ CONJG(ALPHA)*TEMP2)
|
||||
END IF
|
||||
ELSE
|
||||
IF (BETA.EQ.REAL(ZERO)) THEN
|
||||
C(I,J) = ALPHA*TEMP1 + CONJG(ALPHA)*TEMP2
|
||||
ELSE
|
||||
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
|
||||
+ CONJG(ALPHA)*TEMP2
|
||||
END IF
|
||||
END IF
|
||||
230 CONTINUE
|
||||
240 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CHER2K.
|
||||
*
|
||||
END
|
||||
|
|
@ -1,396 +0,0 @@
|
|||
*> \brief \b CHERK
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* REAL ALPHA,BETA
|
||||
* INTEGER K,LDA,LDC,N
|
||||
* CHARACTER TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A(LDA,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CHERK performs one of the hermitian rank k operations
|
||||
*>
|
||||
*> C := alpha*A*A**H + beta*C,
|
||||
*>
|
||||
*> or
|
||||
*>
|
||||
*> C := alpha*A**H*A + beta*C,
|
||||
*>
|
||||
*> where alpha and beta are real scalars, C is an n by n hermitian
|
||||
*> matrix and A is an n by k matrix in the first case and a k by n
|
||||
*> matrix in the second case.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the array C is to be referenced as
|
||||
*> follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' Only the upper triangular part of C
|
||||
*> is to be referenced.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' Only the lower triangular part of C
|
||||
*> is to be referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the operation to be performed as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' C := alpha*A*A**H + beta*C.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' C := alpha*A**H*A + beta*C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix C. N must be
|
||||
*> at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> On entry with TRANS = 'N' or 'n', K specifies the number
|
||||
*> of columns of the matrix A, and on entry with
|
||||
*> TRANS = 'C' or 'c', K specifies the number of rows of the
|
||||
*> matrix A. K must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is REAL
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array of DIMENSION ( LDA, ka ), where ka is
|
||||
*> k when TRANS = 'N' or 'n', and is n otherwise.
|
||||
*> Before entry with TRANS = 'N' or 'n', the leading n by k
|
||||
*> part of the array A must contain the matrix A, otherwise
|
||||
*> the leading k by n part of the array A must contain the
|
||||
*> matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. When TRANS = 'N' or 'n'
|
||||
*> then LDA must be at least max( 1, n ), otherwise LDA must
|
||||
*> be at least max( 1, k ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is REAL
|
||||
*> On entry, BETA specifies the scalar beta.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is COMPLEX array of DIMENSION ( LDC, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
*> upper triangular part of the array C must contain the upper
|
||||
*> triangular part of the hermitian matrix and the strictly
|
||||
*> lower triangular part of C is not referenced. On exit, the
|
||||
*> upper triangular part of the array C is overwritten by the
|
||||
*> upper triangular part of the updated matrix.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
*> lower triangular part of the array C must contain the lower
|
||||
*> triangular part of the hermitian matrix and the strictly
|
||||
*> upper triangular part of C is not referenced. On exit, the
|
||||
*> lower triangular part of the array C is overwritten by the
|
||||
*> lower triangular part of the updated matrix.
|
||||
*> Note that the imaginary parts of the diagonal elements need
|
||||
*> not be set, they are assumed to be zero, and on exit they
|
||||
*> are set to zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> On entry, LDC specifies the first dimension of C as declared
|
||||
*> in the calling (sub) program. LDC must be at least
|
||||
*> max( 1, n ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level3
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 3 Blas routine.
|
||||
*>
|
||||
*> -- Written on 8-February-1989.
|
||||
*> Jack Dongarra, Argonne National Laboratory.
|
||||
*> Iain Duff, AERE Harwell.
|
||||
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
*> Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*>
|
||||
*> -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1.
|
||||
*> Ed Anderson, Cray Research Inc.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
|
||||
*
|
||||
* -- Reference BLAS level3 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL ALPHA,BETA
|
||||
INTEGER K,LDA,LDC,N
|
||||
CHARACTER TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CMPLX,CONJG,MAX,REAL
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP
|
||||
REAL RTEMP
|
||||
INTEGER I,INFO,J,L,NROWA
|
||||
LOGICAL UPPER
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
REAL ONE,ZERO
|
||||
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
NROWA = N
|
||||
ELSE
|
||||
NROWA = K
|
||||
END IF
|
||||
UPPER = LSAME(UPLO,'U')
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
|
||||
+ (.NOT.LSAME(TRANS,'C'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDC.LT.MAX(1,N)) THEN
|
||||
INFO = 10
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CHERK ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
|
||||
+ (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* And when alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
IF (UPPER) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,J
|
||||
C(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
DO 30 I = 1,J - 1
|
||||
C(I,J) = BETA*C(I,J)
|
||||
30 CONTINUE
|
||||
C(J,J) = BETA*REAL(C(J,J))
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 60 J = 1,N
|
||||
DO 50 I = J,N
|
||||
C(I,J) = ZERO
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
C(J,J) = BETA*REAL(C(J,J))
|
||||
DO 70 I = J + 1,N
|
||||
C(I,J) = BETA*C(I,J)
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form C := alpha*A*A**H + beta*C.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 130 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 90 I = 1,J
|
||||
C(I,J) = ZERO
|
||||
90 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 100 I = 1,J - 1
|
||||
C(I,J) = BETA*C(I,J)
|
||||
100 CONTINUE
|
||||
C(J,J) = BETA*REAL(C(J,J))
|
||||
ELSE
|
||||
C(J,J) = REAL(C(J,J))
|
||||
END IF
|
||||
DO 120 L = 1,K
|
||||
IF (A(J,L).NE.CMPLX(ZERO)) THEN
|
||||
TEMP = ALPHA*CONJG(A(J,L))
|
||||
DO 110 I = 1,J - 1
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
110 CONTINUE
|
||||
C(J,J) = REAL(C(J,J)) + REAL(TEMP*A(I,L))
|
||||
END IF
|
||||
120 CONTINUE
|
||||
130 CONTINUE
|
||||
ELSE
|
||||
DO 180 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 140 I = J,N
|
||||
C(I,J) = ZERO
|
||||
140 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
C(J,J) = BETA*REAL(C(J,J))
|
||||
DO 150 I = J + 1,N
|
||||
C(I,J) = BETA*C(I,J)
|
||||
150 CONTINUE
|
||||
ELSE
|
||||
C(J,J) = REAL(C(J,J))
|
||||
END IF
|
||||
DO 170 L = 1,K
|
||||
IF (A(J,L).NE.CMPLX(ZERO)) THEN
|
||||
TEMP = ALPHA*CONJG(A(J,L))
|
||||
C(J,J) = REAL(C(J,J)) + REAL(TEMP*A(J,L))
|
||||
DO 160 I = J + 1,N
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
160 CONTINUE
|
||||
END IF
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**H*A + beta*C.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 220 J = 1,N
|
||||
DO 200 I = 1,J - 1
|
||||
TEMP = ZERO
|
||||
DO 190 L = 1,K
|
||||
TEMP = TEMP + CONJG(A(L,I))*A(L,J)
|
||||
190 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
200 CONTINUE
|
||||
RTEMP = ZERO
|
||||
DO 210 L = 1,K
|
||||
RTEMP = RTEMP + CONJG(A(L,J))*A(L,J)
|
||||
210 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(J,J) = ALPHA*RTEMP
|
||||
ELSE
|
||||
C(J,J) = ALPHA*RTEMP + BETA*REAL(C(J,J))
|
||||
END IF
|
||||
220 CONTINUE
|
||||
ELSE
|
||||
DO 260 J = 1,N
|
||||
RTEMP = ZERO
|
||||
DO 230 L = 1,K
|
||||
RTEMP = RTEMP + CONJG(A(L,J))*A(L,J)
|
||||
230 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(J,J) = ALPHA*RTEMP
|
||||
ELSE
|
||||
C(J,J) = ALPHA*RTEMP + BETA*REAL(C(J,J))
|
||||
END IF
|
||||
DO 250 I = J + 1,N
|
||||
TEMP = ZERO
|
||||
DO 240 L = 1,K
|
||||
TEMP = TEMP + CONJG(A(L,I))*A(L,J)
|
||||
240 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
250 CONTINUE
|
||||
260 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CHERK .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,338 +0,0 @@
|
|||
*> \brief \b CHPMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX ALPHA,BETA
|
||||
* INTEGER INCX,INCY,N
|
||||
* CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX AP(*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CHPMV performs the matrix-vector operation
|
||||
*>
|
||||
*> y := alpha*A*x + beta*y,
|
||||
*>
|
||||
*> where alpha and beta are scalars, x and y are n element vectors and
|
||||
*> A is an n by n hermitian matrix, supplied in packed form.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the matrix A is supplied in the packed
|
||||
*> array AP as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' The upper triangular part of A is
|
||||
*> supplied in AP.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' The lower triangular part of A is
|
||||
*> supplied in AP.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] AP
|
||||
*> \verbatim
|
||||
*> AP is COMPLEX array of DIMENSION at least
|
||||
*> ( ( n*( n + 1 ) )/2 ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the array AP must
|
||||
*> contain the upper triangular part of the hermitian matrix
|
||||
*> packed sequentially, column by column, so that AP( 1 )
|
||||
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
|
||||
*> and a( 2, 2 ) respectively, and so on.
|
||||
*> Before entry with UPLO = 'L' or 'l', the array AP must
|
||||
*> contain the lower triangular part of the hermitian matrix
|
||||
*> packed sequentially, column by column, so that AP( 1 )
|
||||
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
|
||||
*> and a( 3, 1 ) respectively, and so on.
|
||||
*> Note that the imaginary parts of the diagonal elements need
|
||||
*> not be set and are assumed to be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is COMPLEX
|
||||
*> On entry, BETA specifies the scalar beta. When BETA is
|
||||
*> supplied as zero then Y need not be set on input.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] Y
|
||||
*> \verbatim
|
||||
*> Y is COMPLEX array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
*> Before entry, the incremented array Y must contain the n
|
||||
*> element vector y. On exit, Y is overwritten by the updated
|
||||
*> vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX ALPHA,BETA
|
||||
INTEGER INCX,INCY,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX AP(*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ONE
|
||||
PARAMETER (ONE= (1.0E+0,0.0E+0))
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG,REAL
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 6
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CHPMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* Set up the start points in X and Y.
|
||||
*
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (N-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of the array AP
|
||||
* are accessed sequentially with one pass through AP.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,N
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,N
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,N
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,N
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
KK = 1
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form y when AP contains the upper triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 60 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
K = KK
|
||||
DO 50 I = 1,J - 1
|
||||
Y(I) = Y(I) + TEMP1*AP(K)
|
||||
TEMP2 = TEMP2 + CONJG(AP(K))*X(I)
|
||||
K = K + 1
|
||||
50 CONTINUE
|
||||
Y(J) = Y(J) + TEMP1*REAL(AP(KK+J-1)) + ALPHA*TEMP2
|
||||
KK = KK + J
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 80 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
IX = KX
|
||||
IY = KY
|
||||
DO 70 K = KK,KK + J - 2
|
||||
Y(IY) = Y(IY) + TEMP1*AP(K)
|
||||
TEMP2 = TEMP2 + CONJG(AP(K))*X(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
Y(JY) = Y(JY) + TEMP1*REAL(AP(KK+J-1)) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
KK = KK + J
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y when AP contains the lower triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
Y(J) = Y(J) + TEMP1*REAL(AP(KK))
|
||||
K = KK + 1
|
||||
DO 90 I = J + 1,N
|
||||
Y(I) = Y(I) + TEMP1*AP(K)
|
||||
TEMP2 = TEMP2 + CONJG(AP(K))*X(I)
|
||||
K = K + 1
|
||||
90 CONTINUE
|
||||
Y(J) = Y(J) + ALPHA*TEMP2
|
||||
KK = KK + (N-J+1)
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 120 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
Y(JY) = Y(JY) + TEMP1*REAL(AP(KK))
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 110 K = KK + 1,KK + N - J
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
Y(IY) = Y(IY) + TEMP1*AP(K)
|
||||
TEMP2 = TEMP2 + CONJG(AP(K))*X(IX)
|
||||
110 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
KK = KK + (N-J+1)
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CHPMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,279 +0,0 @@
|
|||
*> \brief \b CHPR
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CHPR(UPLO,N,ALPHA,X,INCX,AP)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* REAL ALPHA
|
||||
* INTEGER INCX,N
|
||||
* CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX AP(*),X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CHPR performs the hermitian rank 1 operation
|
||||
*>
|
||||
*> A := alpha*x*x**H + A,
|
||||
*>
|
||||
*> where alpha is a real scalar, x is an n element vector and A is an
|
||||
*> n by n hermitian matrix, supplied in packed form.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the matrix A is supplied in the packed
|
||||
*> array AP as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' The upper triangular part of A is
|
||||
*> supplied in AP.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' The lower triangular part of A is
|
||||
*> supplied in AP.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is REAL
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] AP
|
||||
*> \verbatim
|
||||
*> AP is COMPLEX array of DIMENSION at least
|
||||
*> ( ( n*( n + 1 ) )/2 ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the array AP must
|
||||
*> contain the upper triangular part of the hermitian matrix
|
||||
*> packed sequentially, column by column, so that AP( 1 )
|
||||
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
|
||||
*> and a( 2, 2 ) respectively, and so on. On exit, the array
|
||||
*> AP is overwritten by the upper triangular part of the
|
||||
*> updated matrix.
|
||||
*> Before entry with UPLO = 'L' or 'l', the array AP must
|
||||
*> contain the lower triangular part of the hermitian matrix
|
||||
*> packed sequentially, column by column, so that AP( 1 )
|
||||
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
|
||||
*> and a( 3, 1 ) respectively, and so on. On exit, the array
|
||||
*> AP is overwritten by the lower triangular part of the
|
||||
*> updated matrix.
|
||||
*> Note that the imaginary parts of the diagonal elements need
|
||||
*> not be set, they are assumed to be zero, and on exit they
|
||||
*> are set to zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CHPR(UPLO,N,ALPHA,X,INCX,AP)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL ALPHA
|
||||
INTEGER INCX,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX AP(*),X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP
|
||||
INTEGER I,INFO,IX,J,JX,K,KK,KX
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG,REAL
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 5
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CHPR ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. (ALPHA.EQ.REAL(ZERO))) RETURN
|
||||
*
|
||||
* Set the start point in X if the increment is not unity.
|
||||
*
|
||||
IF (INCX.LE.0) THEN
|
||||
KX = 1 - (N-1)*INCX
|
||||
ELSE IF (INCX.NE.1) THEN
|
||||
KX = 1
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of the array AP
|
||||
* are accessed sequentially with one pass through AP.
|
||||
*
|
||||
KK = 1
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form A when upper triangle is stored in AP.
|
||||
*
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*CONJG(X(J))
|
||||
K = KK
|
||||
DO 10 I = 1,J - 1
|
||||
AP(K) = AP(K) + X(I)*TEMP
|
||||
K = K + 1
|
||||
10 CONTINUE
|
||||
AP(KK+J-1) = REAL(AP(KK+J-1)) + REAL(X(J)*TEMP)
|
||||
ELSE
|
||||
AP(KK+J-1) = REAL(AP(KK+J-1))
|
||||
END IF
|
||||
KK = KK + J
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 40 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*CONJG(X(JX))
|
||||
IX = KX
|
||||
DO 30 K = KK,KK + J - 2
|
||||
AP(K) = AP(K) + X(IX)*TEMP
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
AP(KK+J-1) = REAL(AP(KK+J-1)) + REAL(X(JX)*TEMP)
|
||||
ELSE
|
||||
AP(KK+J-1) = REAL(AP(KK+J-1))
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
KK = KK + J
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form A when lower triangle is stored in AP.
|
||||
*
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 60 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*CONJG(X(J))
|
||||
AP(KK) = REAL(AP(KK)) + REAL(TEMP*X(J))
|
||||
K = KK + 1
|
||||
DO 50 I = J + 1,N
|
||||
AP(K) = AP(K) + X(I)*TEMP
|
||||
K = K + 1
|
||||
50 CONTINUE
|
||||
ELSE
|
||||
AP(KK) = REAL(AP(KK))
|
||||
END IF
|
||||
KK = KK + N - J + 1
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 80 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*CONJG(X(JX))
|
||||
AP(KK) = REAL(AP(KK)) + REAL(TEMP*X(JX))
|
||||
IX = JX
|
||||
DO 70 K = KK + 1,KK + N - J
|
||||
IX = IX + INCX
|
||||
AP(K) = AP(K) + X(IX)*TEMP
|
||||
70 CONTINUE
|
||||
ELSE
|
||||
AP(KK) = REAL(AP(KK))
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
KK = KK + N - J + 1
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CHPR .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,318 +0,0 @@
|
|||
*> \brief \b CHPR2
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX ALPHA
|
||||
* INTEGER INCX,INCY,N
|
||||
* CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX AP(*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CHPR2 performs the hermitian rank 2 operation
|
||||
*>
|
||||
*> A := alpha*x*y**H + conjg( alpha )*y*x**H + A,
|
||||
*>
|
||||
*> where alpha is a scalar, x and y are n element vectors and A is an
|
||||
*> n by n hermitian matrix, supplied in packed form.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the matrix A is supplied in the packed
|
||||
*> array AP as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' The upper triangular part of A is
|
||||
*> supplied in AP.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' The lower triangular part of A is
|
||||
*> supplied in AP.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] Y
|
||||
*> \verbatim
|
||||
*> Y is COMPLEX array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
*> Before entry, the incremented array Y must contain the n
|
||||
*> element vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] AP
|
||||
*> \verbatim
|
||||
*> AP is COMPLEX array of DIMENSION at least
|
||||
*> ( ( n*( n + 1 ) )/2 ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the array AP must
|
||||
*> contain the upper triangular part of the hermitian matrix
|
||||
*> packed sequentially, column by column, so that AP( 1 )
|
||||
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
|
||||
*> and a( 2, 2 ) respectively, and so on. On exit, the array
|
||||
*> AP is overwritten by the upper triangular part of the
|
||||
*> updated matrix.
|
||||
*> Before entry with UPLO = 'L' or 'l', the array AP must
|
||||
*> contain the lower triangular part of the hermitian matrix
|
||||
*> packed sequentially, column by column, so that AP( 1 )
|
||||
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
|
||||
*> and a( 3, 1 ) respectively, and so on. On exit, the array
|
||||
*> AP is overwritten by the lower triangular part of the
|
||||
*> updated matrix.
|
||||
*> Note that the imaginary parts of the diagonal elements need
|
||||
*> not be set, they are assumed to be zero, and on exit they
|
||||
*> are set to zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX ALPHA
|
||||
INTEGER INCX,INCY,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX AP(*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG,REAL
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 7
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CHPR2 ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
|
||||
*
|
||||
* Set up the start points in X and Y if the increments are not both
|
||||
* unity.
|
||||
*
|
||||
IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (N-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
JX = KX
|
||||
JY = KY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of the array AP
|
||||
* are accessed sequentially with one pass through AP.
|
||||
*
|
||||
KK = 1
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form A when upper triangle is stored in AP.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 20 J = 1,N
|
||||
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*CONJG(Y(J))
|
||||
TEMP2 = CONJG(ALPHA*X(J))
|
||||
K = KK
|
||||
DO 10 I = 1,J - 1
|
||||
AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
|
||||
K = K + 1
|
||||
10 CONTINUE
|
||||
AP(KK+J-1) = REAL(AP(KK+J-1)) +
|
||||
+ REAL(X(J)*TEMP1+Y(J)*TEMP2)
|
||||
ELSE
|
||||
AP(KK+J-1) = REAL(AP(KK+J-1))
|
||||
END IF
|
||||
KK = KK + J
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*CONJG(Y(JY))
|
||||
TEMP2 = CONJG(ALPHA*X(JX))
|
||||
IX = KX
|
||||
IY = KY
|
||||
DO 30 K = KK,KK + J - 2
|
||||
AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
AP(KK+J-1) = REAL(AP(KK+J-1)) +
|
||||
+ REAL(X(JX)*TEMP1+Y(JY)*TEMP2)
|
||||
ELSE
|
||||
AP(KK+J-1) = REAL(AP(KK+J-1))
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
KK = KK + J
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form A when lower triangle is stored in AP.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 60 J = 1,N
|
||||
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*CONJG(Y(J))
|
||||
TEMP2 = CONJG(ALPHA*X(J))
|
||||
AP(KK) = REAL(AP(KK)) +
|
||||
+ REAL(X(J)*TEMP1+Y(J)*TEMP2)
|
||||
K = KK + 1
|
||||
DO 50 I = J + 1,N
|
||||
AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
|
||||
K = K + 1
|
||||
50 CONTINUE
|
||||
ELSE
|
||||
AP(KK) = REAL(AP(KK))
|
||||
END IF
|
||||
KK = KK + N - J + 1
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*CONJG(Y(JY))
|
||||
TEMP2 = CONJG(ALPHA*X(JX))
|
||||
AP(KK) = REAL(AP(KK)) +
|
||||
+ REAL(X(JX)*TEMP1+Y(JY)*TEMP2)
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 70 K = KK + 1,KK + N - J
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
|
||||
70 CONTINUE
|
||||
ELSE
|
||||
AP(KK) = REAL(AP(KK))
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
KK = KK + N - J + 1
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CHPR2 .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,74 +0,0 @@
|
|||
*> \brief \b CROTG
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CROTG(CA,CB,C,S)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX CA,CB,S
|
||||
* REAL C
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CROTG determines a complex Givens rotation.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level1
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE CROTG(CA,CB,C,S)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX CA,CB,S
|
||||
REAL C
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
COMPLEX ALPHA
|
||||
REAL NORM,SCALE
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CABS,CONJG,SQRT
|
||||
* ..
|
||||
IF (CABS(CA).EQ.0.) THEN
|
||||
C = 0.
|
||||
S = (1.,0.)
|
||||
CA = CB
|
||||
ELSE
|
||||
SCALE = CABS(CA) + CABS(CB)
|
||||
NORM = SCALE*SQRT((CABS(CA/SCALE))**2+ (CABS(CB/SCALE))**2)
|
||||
ALPHA = CA/CABS(CA)
|
||||
C = CABS(CA)/NORM
|
||||
S = ALPHA*CONJG(CB)/NORM
|
||||
CA = ALPHA*NORM
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,91 +0,0 @@
|
|||
*> \brief \b CSCAL
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CSCAL(N,CA,CX,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX CA
|
||||
* INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX CX(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CSCAL scales a vector by a constant.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 3/93 to return if incx .le. 0.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CSCAL(N,CA,CX,INCX)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX CA
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX CX(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I,NINCX
|
||||
* ..
|
||||
IF (N.LE.0 .OR. INCX.LE.0) RETURN
|
||||
IF (INCX.EQ.1) THEN
|
||||
*
|
||||
* code for increment equal to 1
|
||||
*
|
||||
DO I = 1,N
|
||||
CX(I) = CA*CX(I)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for increment not equal to 1
|
||||
*
|
||||
NINCX = N*INCX
|
||||
DO I = 1,NINCX,INCX
|
||||
CX(I) = CA*CX(I)
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,153 +0,0 @@
|
|||
*> \brief \b CSROT
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CSROT( N, CX, INCX, CY, INCY, C, S )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX, INCY, N
|
||||
* REAL C, S
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX CX( * ), CY( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CSROT applies a plane rotation, where the cos and sin (c and s) are real
|
||||
*> and the vectors cx and cy are complex.
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the vectors cx and cy.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] CX
|
||||
*> \verbatim
|
||||
*> CX is COMPLEX array, dimension at least
|
||||
*> ( 1 + ( N - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array CX must contain the n
|
||||
*> element vector cx. On exit, CX is overwritten by the updated
|
||||
*> vector cx.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> CX. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] CY
|
||||
*> \verbatim
|
||||
*> CY is COMPLEX array, dimension at least
|
||||
*> ( 1 + ( N - 1 )*abs( INCY ) ).
|
||||
*> Before entry, the incremented array CY must contain the n
|
||||
*> element vector cy. On exit, CY is overwritten by the updated
|
||||
*> vector cy.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> CY. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] C
|
||||
*> \verbatim
|
||||
*> C is REAL
|
||||
*> On entry, C specifies the cosine, cos.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] S
|
||||
*> \verbatim
|
||||
*> S is REAL
|
||||
*> On entry, S specifies the sine, sin.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level1
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE CSROT( N, CX, INCX, CY, INCY, C, S )
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX, INCY, N
|
||||
REAL C, S
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX CX( * ), CY( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, IX, IY
|
||||
COMPLEX CTEMP
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( N.LE.0 )
|
||||
$ RETURN
|
||||
IF( INCX.EQ.1 .AND. INCY.EQ.1 ) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
DO I = 1, N
|
||||
CTEMP = C*CX( I ) + S*CY( I )
|
||||
CY( I ) = C*CY( I ) - S*CX( I )
|
||||
CX( I ) = CTEMP
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments not equal
|
||||
* to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF( INCX.LT.0 )
|
||||
$ IX = ( -N+1 )*INCX + 1
|
||||
IF( INCY.LT.0 )
|
||||
$ IY = ( -N+1 )*INCY + 1
|
||||
DO I = 1, N
|
||||
CTEMP = C*CX( IX ) + S*CY( IY )
|
||||
CY( IY ) = C*CY( IY ) - S*CX( IX )
|
||||
CX( IX ) = CTEMP
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,94 +0,0 @@
|
|||
*> \brief \b CSSCAL
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CSSCAL(N,SA,CX,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* REAL SA
|
||||
* INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX CX(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CSSCAL scales a complex vector by a real constant.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 3/93 to return if incx .le. 0.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CSSCAL(N,SA,CX,INCX)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL SA
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX CX(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I,NINCX
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC AIMAG,CMPLX,REAL
|
||||
* ..
|
||||
IF (N.LE.0 .OR. INCX.LE.0) RETURN
|
||||
IF (INCX.EQ.1) THEN
|
||||
*
|
||||
* code for increment equal to 1
|
||||
*
|
||||
DO I = 1,N
|
||||
CX(I) = CMPLX(SA*REAL(CX(I)),SA*AIMAG(CX(I)))
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for increment not equal to 1
|
||||
*
|
||||
NINCX = N*INCX
|
||||
DO I = 1,NINCX,INCX
|
||||
CX(I) = CMPLX(SA*REAL(CX(I)),SA*AIMAG(CX(I)))
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,98 +0,0 @@
|
|||
*> \brief \b CSWAP
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CSWAP(N,CX,INCX,CY,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX CX(*),CY(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CSWAP interchanges two vectors.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CSWAP(N,CX,INCX,CY,INCY)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX CX(*),CY(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
COMPLEX CTEMP
|
||||
INTEGER I,IX,IY
|
||||
* ..
|
||||
IF (N.LE.0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
DO I = 1,N
|
||||
CTEMP = CX(I)
|
||||
CX(I) = CY(I)
|
||||
CY(I) = CTEMP
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments not equal
|
||||
* to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
CTEMP = CX(IX)
|
||||
CX(IX) = CY(IY)
|
||||
CY(IY) = CTEMP
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,369 +0,0 @@
|
|||
*> \brief \b CSYMM
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX ALPHA,BETA
|
||||
* INTEGER LDA,LDB,LDC,M,N
|
||||
* CHARACTER SIDE,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CSYMM performs one of the matrix-matrix operations
|
||||
*>
|
||||
*> C := alpha*A*B + beta*C,
|
||||
*>
|
||||
*> or
|
||||
*>
|
||||
*> C := alpha*B*A + beta*C,
|
||||
*>
|
||||
*> where alpha and beta are scalars, A is a symmetric matrix and B and
|
||||
*> C are m by n matrices.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> On entry, SIDE specifies whether the symmetric matrix A
|
||||
*> appears on the left or right in the operation as follows:
|
||||
*>
|
||||
*> SIDE = 'L' or 'l' C := alpha*A*B + beta*C,
|
||||
*>
|
||||
*> SIDE = 'R' or 'r' C := alpha*B*A + beta*C,
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the symmetric matrix A is to be
|
||||
*> referenced as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' Only the upper triangular part of the
|
||||
*> symmetric matrix is to be referenced.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' Only the lower triangular part of the
|
||||
*> symmetric matrix is to be referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of the matrix C.
|
||||
*> M must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of the matrix C.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array of DIMENSION ( LDA, ka ), where ka is
|
||||
*> m when SIDE = 'L' or 'l' and is n otherwise.
|
||||
*> Before entry with SIDE = 'L' or 'l', the m by m part of
|
||||
*> the array A must contain the symmetric matrix, such that
|
||||
*> when UPLO = 'U' or 'u', the leading m by m upper triangular
|
||||
*> part of the array A must contain the upper triangular part
|
||||
*> of the symmetric matrix and the strictly lower triangular
|
||||
*> part of A is not referenced, and when UPLO = 'L' or 'l',
|
||||
*> the leading m by m lower triangular part of the array A
|
||||
*> must contain the lower triangular part of the symmetric
|
||||
*> matrix and the strictly upper triangular part of A is not
|
||||
*> referenced.
|
||||
*> Before entry with SIDE = 'R' or 'r', the n by n part of
|
||||
*> the array A must contain the symmetric matrix, such that
|
||||
*> when UPLO = 'U' or 'u', the leading n by n upper triangular
|
||||
*> part of the array A must contain the upper triangular part
|
||||
*> of the symmetric matrix and the strictly lower triangular
|
||||
*> part of A is not referenced, and when UPLO = 'L' or 'l',
|
||||
*> the leading n by n lower triangular part of the array A
|
||||
*> must contain the lower triangular part of the symmetric
|
||||
*> matrix and the strictly upper triangular part of A is not
|
||||
*> referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. When SIDE = 'L' or 'l' then
|
||||
*> LDA must be at least max( 1, m ), otherwise LDA must be at
|
||||
*> least max( 1, n ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> B is COMPLEX array of DIMENSION ( LDB, n ).
|
||||
*> Before entry, the leading m by n part of the array B must
|
||||
*> contain the matrix B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> On entry, LDB specifies the first dimension of B as declared
|
||||
*> in the calling (sub) program. LDB must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is COMPLEX
|
||||
*> On entry, BETA specifies the scalar beta. When BETA is
|
||||
*> supplied as zero then C need not be set on input.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is COMPLEX array of DIMENSION ( LDC, n ).
|
||||
*> Before entry, the leading m by n part of the array C must
|
||||
*> contain the matrix C, except when beta is zero, in which
|
||||
*> case C need not be set on entry.
|
||||
*> On exit, the array C is overwritten by the m by n updated
|
||||
*> matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> On entry, LDC specifies the first dimension of C as declared
|
||||
*> in the calling (sub) program. LDC must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level3
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 3 Blas routine.
|
||||
*>
|
||||
*> -- Written on 8-February-1989.
|
||||
*> Jack Dongarra, Argonne National Laboratory.
|
||||
*> Iain Duff, AERE Harwell.
|
||||
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
*> Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* -- Reference BLAS level3 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX ALPHA,BETA
|
||||
INTEGER LDA,LDB,LDC,M,N
|
||||
CHARACTER SIDE,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP1,TEMP2
|
||||
INTEGER I,INFO,J,K,NROWA
|
||||
LOGICAL UPPER
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
COMPLEX ONE
|
||||
PARAMETER (ONE= (1.0E+0,0.0E+0))
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
*
|
||||
* Set NROWA as the number of rows of A.
|
||||
*
|
||||
IF (LSAME(SIDE,'L')) THEN
|
||||
NROWA = M
|
||||
ELSE
|
||||
NROWA = N
|
||||
END IF
|
||||
UPPER = LSAME(UPLO,'U')
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.LSAME(SIDE,'L')) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDB.LT.MAX(1,M)) THEN
|
||||
INFO = 9
|
||||
ELSE IF (LDC.LT.MAX(1,M)) THEN
|
||||
INFO = 12
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CSYMM ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
|
||||
+ ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* And when alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
DO 30 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
END IF
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (LSAME(SIDE,'L')) THEN
|
||||
*
|
||||
* Form C := alpha*A*B + beta*C.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 70 J = 1,N
|
||||
DO 60 I = 1,M
|
||||
TEMP1 = ALPHA*B(I,J)
|
||||
TEMP2 = ZERO
|
||||
DO 50 K = 1,I - 1
|
||||
C(K,J) = C(K,J) + TEMP1*A(K,I)
|
||||
TEMP2 = TEMP2 + B(K,J)*A(K,I)
|
||||
50 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2
|
||||
ELSE
|
||||
C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) +
|
||||
+ ALPHA*TEMP2
|
||||
END IF
|
||||
60 CONTINUE
|
||||
70 CONTINUE
|
||||
ELSE
|
||||
DO 100 J = 1,N
|
||||
DO 90 I = M,1,-1
|
||||
TEMP1 = ALPHA*B(I,J)
|
||||
TEMP2 = ZERO
|
||||
DO 80 K = I + 1,M
|
||||
C(K,J) = C(K,J) + TEMP1*A(K,I)
|
||||
TEMP2 = TEMP2 + B(K,J)*A(K,I)
|
||||
80 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2
|
||||
ELSE
|
||||
C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) +
|
||||
+ ALPHA*TEMP2
|
||||
END IF
|
||||
90 CONTINUE
|
||||
100 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*B*A + beta*C.
|
||||
*
|
||||
DO 170 J = 1,N
|
||||
TEMP1 = ALPHA*A(J,J)
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 110 I = 1,M
|
||||
C(I,J) = TEMP1*B(I,J)
|
||||
110 CONTINUE
|
||||
ELSE
|
||||
DO 120 I = 1,M
|
||||
C(I,J) = BETA*C(I,J) + TEMP1*B(I,J)
|
||||
120 CONTINUE
|
||||
END IF
|
||||
DO 140 K = 1,J - 1
|
||||
IF (UPPER) THEN
|
||||
TEMP1 = ALPHA*A(K,J)
|
||||
ELSE
|
||||
TEMP1 = ALPHA*A(J,K)
|
||||
END IF
|
||||
DO 130 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP1*B(I,K)
|
||||
130 CONTINUE
|
||||
140 CONTINUE
|
||||
DO 160 K = J + 1,N
|
||||
IF (UPPER) THEN
|
||||
TEMP1 = ALPHA*A(J,K)
|
||||
ELSE
|
||||
TEMP1 = ALPHA*A(K,J)
|
||||
END IF
|
||||
DO 150 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP1*B(I,K)
|
||||
150 CONTINUE
|
||||
160 CONTINUE
|
||||
170 CONTINUE
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CSYMM .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,396 +0,0 @@
|
|||
*> \brief \b CSYR2K
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX ALPHA,BETA
|
||||
* INTEGER K,LDA,LDB,LDC,N
|
||||
* CHARACTER TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CSYR2K performs one of the symmetric rank 2k operations
|
||||
*>
|
||||
*> C := alpha*A*B**T + alpha*B*A**T + beta*C,
|
||||
*>
|
||||
*> or
|
||||
*>
|
||||
*> C := alpha*A**T*B + alpha*B**T*A + beta*C,
|
||||
*>
|
||||
*> where alpha and beta are scalars, C is an n by n symmetric matrix
|
||||
*> and A and B are n by k matrices in the first case and k by n
|
||||
*> matrices in the second case.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the array C is to be referenced as
|
||||
*> follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' Only the upper triangular part of C
|
||||
*> is to be referenced.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' Only the lower triangular part of C
|
||||
*> is to be referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the operation to be performed as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' C := alpha*A*B**T + alpha*B*A**T +
|
||||
*> beta*C.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' C := alpha*A**T*B + alpha*B**T*A +
|
||||
*> beta*C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix C. N must be
|
||||
*> at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> On entry with TRANS = 'N' or 'n', K specifies the number
|
||||
*> of columns of the matrices A and B, and on entry with
|
||||
*> TRANS = 'T' or 't', K specifies the number of rows of the
|
||||
*> matrices A and B. K must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array of DIMENSION ( LDA, ka ), where ka is
|
||||
*> k when TRANS = 'N' or 'n', and is n otherwise.
|
||||
*> Before entry with TRANS = 'N' or 'n', the leading n by k
|
||||
*> part of the array A must contain the matrix A, otherwise
|
||||
*> the leading k by n part of the array A must contain the
|
||||
*> matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. When TRANS = 'N' or 'n'
|
||||
*> then LDA must be at least max( 1, n ), otherwise LDA must
|
||||
*> be at least max( 1, k ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> B is COMPLEX array of DIMENSION ( LDB, kb ), where kb is
|
||||
*> k when TRANS = 'N' or 'n', and is n otherwise.
|
||||
*> Before entry with TRANS = 'N' or 'n', the leading n by k
|
||||
*> part of the array B must contain the matrix B, otherwise
|
||||
*> the leading k by n part of the array B must contain the
|
||||
*> matrix B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> On entry, LDB specifies the first dimension of B as declared
|
||||
*> in the calling (sub) program. When TRANS = 'N' or 'n'
|
||||
*> then LDB must be at least max( 1, n ), otherwise LDB must
|
||||
*> be at least max( 1, k ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is COMPLEX
|
||||
*> On entry, BETA specifies the scalar beta.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is COMPLEX array of DIMENSION ( LDC, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
*> upper triangular part of the array C must contain the upper
|
||||
*> triangular part of the symmetric matrix and the strictly
|
||||
*> lower triangular part of C is not referenced. On exit, the
|
||||
*> upper triangular part of the array C is overwritten by the
|
||||
*> upper triangular part of the updated matrix.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
*> lower triangular part of the array C must contain the lower
|
||||
*> triangular part of the symmetric matrix and the strictly
|
||||
*> upper triangular part of C is not referenced. On exit, the
|
||||
*> lower triangular part of the array C is overwritten by the
|
||||
*> lower triangular part of the updated matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> On entry, LDC specifies the first dimension of C as declared
|
||||
*> in the calling (sub) program. LDC must be at least
|
||||
*> max( 1, n ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level3
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 3 Blas routine.
|
||||
*>
|
||||
*> -- Written on 8-February-1989.
|
||||
*> Jack Dongarra, Argonne National Laboratory.
|
||||
*> Iain Duff, AERE Harwell.
|
||||
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
*> Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* -- Reference BLAS level3 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX ALPHA,BETA
|
||||
INTEGER K,LDA,LDB,LDC,N
|
||||
CHARACTER TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP1,TEMP2
|
||||
INTEGER I,INFO,J,L,NROWA
|
||||
LOGICAL UPPER
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
COMPLEX ONE
|
||||
PARAMETER (ONE= (1.0E+0,0.0E+0))
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
NROWA = N
|
||||
ELSE
|
||||
NROWA = K
|
||||
END IF
|
||||
UPPER = LSAME(UPLO,'U')
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
|
||||
+ (.NOT.LSAME(TRANS,'T'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDB.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 9
|
||||
ELSE IF (LDC.LT.MAX(1,N)) THEN
|
||||
INFO = 12
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CSYR2K',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
|
||||
+ (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* And when alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
IF (UPPER) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,J
|
||||
C(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
DO 30 I = 1,J
|
||||
C(I,J) = BETA*C(I,J)
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 60 J = 1,N
|
||||
DO 50 I = J,N
|
||||
C(I,J) = ZERO
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
DO 70 I = J,N
|
||||
C(I,J) = BETA*C(I,J)
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form C := alpha*A*B**T + alpha*B*A**T + C.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 130 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 90 I = 1,J
|
||||
C(I,J) = ZERO
|
||||
90 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 100 I = 1,J
|
||||
C(I,J) = BETA*C(I,J)
|
||||
100 CONTINUE
|
||||
END IF
|
||||
DO 120 L = 1,K
|
||||
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*B(J,L)
|
||||
TEMP2 = ALPHA*A(J,L)
|
||||
DO 110 I = 1,J
|
||||
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
|
||||
+ B(I,L)*TEMP2
|
||||
110 CONTINUE
|
||||
END IF
|
||||
120 CONTINUE
|
||||
130 CONTINUE
|
||||
ELSE
|
||||
DO 180 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 140 I = J,N
|
||||
C(I,J) = ZERO
|
||||
140 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 150 I = J,N
|
||||
C(I,J) = BETA*C(I,J)
|
||||
150 CONTINUE
|
||||
END IF
|
||||
DO 170 L = 1,K
|
||||
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*B(J,L)
|
||||
TEMP2 = ALPHA*A(J,L)
|
||||
DO 160 I = J,N
|
||||
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
|
||||
+ B(I,L)*TEMP2
|
||||
160 CONTINUE
|
||||
END IF
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**T*B + alpha*B**T*A + C.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 210 J = 1,N
|
||||
DO 200 I = 1,J
|
||||
TEMP1 = ZERO
|
||||
TEMP2 = ZERO
|
||||
DO 190 L = 1,K
|
||||
TEMP1 = TEMP1 + A(L,I)*B(L,J)
|
||||
TEMP2 = TEMP2 + B(L,I)*A(L,J)
|
||||
190 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
|
||||
ELSE
|
||||
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
|
||||
+ ALPHA*TEMP2
|
||||
END IF
|
||||
200 CONTINUE
|
||||
210 CONTINUE
|
||||
ELSE
|
||||
DO 240 J = 1,N
|
||||
DO 230 I = J,N
|
||||
TEMP1 = ZERO
|
||||
TEMP2 = ZERO
|
||||
DO 220 L = 1,K
|
||||
TEMP1 = TEMP1 + A(L,I)*B(L,J)
|
||||
TEMP2 = TEMP2 + B(L,I)*A(L,J)
|
||||
220 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
|
||||
ELSE
|
||||
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
|
||||
+ ALPHA*TEMP2
|
||||
END IF
|
||||
230 CONTINUE
|
||||
240 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CSYR2K.
|
||||
*
|
||||
END
|
||||
|
|
@ -1,363 +0,0 @@
|
|||
*> \brief \b CSYRK
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX ALPHA,BETA
|
||||
* INTEGER K,LDA,LDC,N
|
||||
* CHARACTER TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A(LDA,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CSYRK performs one of the symmetric rank k operations
|
||||
*>
|
||||
*> C := alpha*A*A**T + beta*C,
|
||||
*>
|
||||
*> or
|
||||
*>
|
||||
*> C := alpha*A**T*A + beta*C,
|
||||
*>
|
||||
*> where alpha and beta are scalars, C is an n by n symmetric matrix
|
||||
*> and A is an n by k matrix in the first case and a k by n matrix
|
||||
*> in the second case.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the array C is to be referenced as
|
||||
*> follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' Only the upper triangular part of C
|
||||
*> is to be referenced.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' Only the lower triangular part of C
|
||||
*> is to be referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the operation to be performed as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' C := alpha*A*A**T + beta*C.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' C := alpha*A**T*A + beta*C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix C. N must be
|
||||
*> at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> On entry with TRANS = 'N' or 'n', K specifies the number
|
||||
*> of columns of the matrix A, and on entry with
|
||||
*> TRANS = 'T' or 't', K specifies the number of rows of the
|
||||
*> matrix A. K must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array of DIMENSION ( LDA, ka ), where ka is
|
||||
*> k when TRANS = 'N' or 'n', and is n otherwise.
|
||||
*> Before entry with TRANS = 'N' or 'n', the leading n by k
|
||||
*> part of the array A must contain the matrix A, otherwise
|
||||
*> the leading k by n part of the array A must contain the
|
||||
*> matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. When TRANS = 'N' or 'n'
|
||||
*> then LDA must be at least max( 1, n ), otherwise LDA must
|
||||
*> be at least max( 1, k ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is COMPLEX
|
||||
*> On entry, BETA specifies the scalar beta.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is COMPLEX array of DIMENSION ( LDC, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
*> upper triangular part of the array C must contain the upper
|
||||
*> triangular part of the symmetric matrix and the strictly
|
||||
*> lower triangular part of C is not referenced. On exit, the
|
||||
*> upper triangular part of the array C is overwritten by the
|
||||
*> upper triangular part of the updated matrix.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
*> lower triangular part of the array C must contain the lower
|
||||
*> triangular part of the symmetric matrix and the strictly
|
||||
*> upper triangular part of C is not referenced. On exit, the
|
||||
*> lower triangular part of the array C is overwritten by the
|
||||
*> lower triangular part of the updated matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> On entry, LDC specifies the first dimension of C as declared
|
||||
*> in the calling (sub) program. LDC must be at least
|
||||
*> max( 1, n ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level3
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 3 Blas routine.
|
||||
*>
|
||||
*> -- Written on 8-February-1989.
|
||||
*> Jack Dongarra, Argonne National Laboratory.
|
||||
*> Iain Duff, AERE Harwell.
|
||||
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
*> Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
|
||||
*
|
||||
* -- Reference BLAS level3 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX ALPHA,BETA
|
||||
INTEGER K,LDA,LDC,N
|
||||
CHARACTER TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP
|
||||
INTEGER I,INFO,J,L,NROWA
|
||||
LOGICAL UPPER
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
COMPLEX ONE
|
||||
PARAMETER (ONE= (1.0E+0,0.0E+0))
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
NROWA = N
|
||||
ELSE
|
||||
NROWA = K
|
||||
END IF
|
||||
UPPER = LSAME(UPLO,'U')
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
|
||||
+ (.NOT.LSAME(TRANS,'T'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDC.LT.MAX(1,N)) THEN
|
||||
INFO = 10
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CSYRK ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
|
||||
+ (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* And when alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
IF (UPPER) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,J
|
||||
C(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
DO 30 I = 1,J
|
||||
C(I,J) = BETA*C(I,J)
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 60 J = 1,N
|
||||
DO 50 I = J,N
|
||||
C(I,J) = ZERO
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
DO 70 I = J,N
|
||||
C(I,J) = BETA*C(I,J)
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form C := alpha*A*A**T + beta*C.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 130 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 90 I = 1,J
|
||||
C(I,J) = ZERO
|
||||
90 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 100 I = 1,J
|
||||
C(I,J) = BETA*C(I,J)
|
||||
100 CONTINUE
|
||||
END IF
|
||||
DO 120 L = 1,K
|
||||
IF (A(J,L).NE.ZERO) THEN
|
||||
TEMP = ALPHA*A(J,L)
|
||||
DO 110 I = 1,J
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
110 CONTINUE
|
||||
END IF
|
||||
120 CONTINUE
|
||||
130 CONTINUE
|
||||
ELSE
|
||||
DO 180 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 140 I = J,N
|
||||
C(I,J) = ZERO
|
||||
140 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 150 I = J,N
|
||||
C(I,J) = BETA*C(I,J)
|
||||
150 CONTINUE
|
||||
END IF
|
||||
DO 170 L = 1,K
|
||||
IF (A(J,L).NE.ZERO) THEN
|
||||
TEMP = ALPHA*A(J,L)
|
||||
DO 160 I = J,N
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
160 CONTINUE
|
||||
END IF
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**T*A + beta*C.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 210 J = 1,N
|
||||
DO 200 I = 1,J
|
||||
TEMP = ZERO
|
||||
DO 190 L = 1,K
|
||||
TEMP = TEMP + A(L,I)*A(L,J)
|
||||
190 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
200 CONTINUE
|
||||
210 CONTINUE
|
||||
ELSE
|
||||
DO 240 J = 1,N
|
||||
DO 230 I = J,N
|
||||
TEMP = ZERO
|
||||
DO 220 L = 1,K
|
||||
TEMP = TEMP + A(L,I)*A(L,J)
|
||||
220 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
230 CONTINUE
|
||||
240 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CSYRK .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,429 +0,0 @@
|
|||
*> \brief \b CTBMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,K,LDA,N
|
||||
* CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CTBMV performs one of the matrix-vector operations
|
||||
*>
|
||||
*> x := A*x, or x := A**T*x, or x := A**H*x,
|
||||
*>
|
||||
*> where x is an n element vector and A is an n by n unit, or non-unit,
|
||||
*> upper or lower triangular band matrix, with ( k + 1 ) diagonals.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the matrix is an upper or
|
||||
*> lower triangular matrix as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the operation to be performed as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' x := A*x.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' x := A**T*x.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' x := A**H*x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIAG
|
||||
*> \verbatim
|
||||
*> DIAG is CHARACTER*1
|
||||
*> On entry, DIAG specifies whether or not A is unit
|
||||
*> triangular as follows:
|
||||
*>
|
||||
*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*>
|
||||
*> DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
*> triangular.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> On entry with UPLO = 'U' or 'u', K specifies the number of
|
||||
*> super-diagonals of the matrix A.
|
||||
*> On entry with UPLO = 'L' or 'l', K specifies the number of
|
||||
*> sub-diagonals of the matrix A.
|
||||
*> K must satisfy 0 .le. K.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array of DIMENSION ( LDA, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
|
||||
*> by n part of the array A must contain the upper triangular
|
||||
*> band part of the matrix of coefficients, supplied column by
|
||||
*> column, with the leading diagonal of the matrix in row
|
||||
*> ( k + 1 ) of the array, the first super-diagonal starting at
|
||||
*> position 2 in row k, and so on. The top left k by k triangle
|
||||
*> of the array A is not referenced.
|
||||
*> The following program segment will transfer an upper
|
||||
*> triangular band matrix from conventional full matrix storage
|
||||
*> to band storage:
|
||||
*>
|
||||
*> DO 20, J = 1, N
|
||||
*> M = K + 1 - J
|
||||
*> DO 10, I = MAX( 1, J - K ), J
|
||||
*> A( M + I, J ) = matrix( I, J )
|
||||
*> 10 CONTINUE
|
||||
*> 20 CONTINUE
|
||||
*>
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
|
||||
*> by n part of the array A must contain the lower triangular
|
||||
*> band part of the matrix of coefficients, supplied column by
|
||||
*> column, with the leading diagonal of the matrix in row 1 of
|
||||
*> the array, the first sub-diagonal starting at position 1 in
|
||||
*> row 2, and so on. The bottom right k by k triangle of the
|
||||
*> array A is not referenced.
|
||||
*> The following program segment will transfer a lower
|
||||
*> triangular band matrix from conventional full matrix storage
|
||||
*> to band storage:
|
||||
*>
|
||||
*> DO 20, J = 1, N
|
||||
*> M = 1 - J
|
||||
*> DO 10, I = J, MIN( N, J + K )
|
||||
*> A( M + I, J ) = matrix( I, J )
|
||||
*> 10 CONTINUE
|
||||
*> 20 CONTINUE
|
||||
*>
|
||||
*> Note that when DIAG = 'U' or 'u' the elements of the array A
|
||||
*> corresponding to the diagonal elements of the matrix are not
|
||||
*> referenced, but are assumed to be unity.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> ( k + 1 ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x. On exit, X is overwritten with the
|
||||
*> tranformed vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,K,LDA,N
|
||||
CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP
|
||||
INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L
|
||||
LOGICAL NOCONJ,NOUNIT
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG,MAX,MIN
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 2
|
||||
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (LDA.LT. (K+1)) THEN
|
||||
INFO = 7
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CTBMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (N.EQ.0) RETURN
|
||||
*
|
||||
NOCONJ = LSAME(TRANS,'T')
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
*
|
||||
* Set up the start point in X if the increment is not unity. This
|
||||
* will be ( N - 1 )*INCX too small for descending loops.
|
||||
*
|
||||
IF (INCX.LE.0) THEN
|
||||
KX = 1 - (N-1)*INCX
|
||||
ELSE IF (INCX.NE.1) THEN
|
||||
KX = 1
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form x := A*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
KPLUS1 = K + 1
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = X(J)
|
||||
L = KPLUS1 - J
|
||||
DO 10 I = MAX(1,J-K),J - 1
|
||||
X(I) = X(I) + TEMP*A(L+I,J)
|
||||
10 CONTINUE
|
||||
IF (NOUNIT) X(J) = X(J)*A(KPLUS1,J)
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 40 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
L = KPLUS1 - J
|
||||
DO 30 I = MAX(1,J-K),J - 1
|
||||
X(IX) = X(IX) + TEMP*A(L+I,J)
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
IF (NOUNIT) X(JX) = X(JX)*A(KPLUS1,J)
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
IF (J.GT.K) KX = KX + INCX
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 60 J = N,1,-1
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = X(J)
|
||||
L = 1 - J
|
||||
DO 50 I = MIN(N,J+K),J + 1,-1
|
||||
X(I) = X(I) + TEMP*A(L+I,J)
|
||||
50 CONTINUE
|
||||
IF (NOUNIT) X(J) = X(J)*A(1,J)
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
KX = KX + (N-1)*INCX
|
||||
JX = KX
|
||||
DO 80 J = N,1,-1
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
L = 1 - J
|
||||
DO 70 I = MIN(N,J+K),J + 1,-1
|
||||
X(IX) = X(IX) + TEMP*A(L+I,J)
|
||||
IX = IX - INCX
|
||||
70 CONTINUE
|
||||
IF (NOUNIT) X(JX) = X(JX)*A(1,J)
|
||||
END IF
|
||||
JX = JX - INCX
|
||||
IF ((N-J).GE.K) KX = KX - INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form x := A**T*x or x := A**H*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
KPLUS1 = K + 1
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 110 J = N,1,-1
|
||||
TEMP = X(J)
|
||||
L = KPLUS1 - J
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J)
|
||||
DO 90 I = J - 1,MAX(1,J-K),-1
|
||||
TEMP = TEMP + A(L+I,J)*X(I)
|
||||
90 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*CONJG(A(KPLUS1,J))
|
||||
DO 100 I = J - 1,MAX(1,J-K),-1
|
||||
TEMP = TEMP + CONJG(A(L+I,J))*X(I)
|
||||
100 CONTINUE
|
||||
END IF
|
||||
X(J) = TEMP
|
||||
110 CONTINUE
|
||||
ELSE
|
||||
KX = KX + (N-1)*INCX
|
||||
JX = KX
|
||||
DO 140 J = N,1,-1
|
||||
TEMP = X(JX)
|
||||
KX = KX - INCX
|
||||
IX = KX
|
||||
L = KPLUS1 - J
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J)
|
||||
DO 120 I = J - 1,MAX(1,J-K),-1
|
||||
TEMP = TEMP + A(L+I,J)*X(IX)
|
||||
IX = IX - INCX
|
||||
120 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*CONJG(A(KPLUS1,J))
|
||||
DO 130 I = J - 1,MAX(1,J-K),-1
|
||||
TEMP = TEMP + CONJG(A(L+I,J))*X(IX)
|
||||
IX = IX - INCX
|
||||
130 CONTINUE
|
||||
END IF
|
||||
X(JX) = TEMP
|
||||
JX = JX - INCX
|
||||
140 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 170 J = 1,N
|
||||
TEMP = X(J)
|
||||
L = 1 - J
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(1,J)
|
||||
DO 150 I = J + 1,MIN(N,J+K)
|
||||
TEMP = TEMP + A(L+I,J)*X(I)
|
||||
150 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*CONJG(A(1,J))
|
||||
DO 160 I = J + 1,MIN(N,J+K)
|
||||
TEMP = TEMP + CONJG(A(L+I,J))*X(I)
|
||||
160 CONTINUE
|
||||
END IF
|
||||
X(J) = TEMP
|
||||
170 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 200 J = 1,N
|
||||
TEMP = X(JX)
|
||||
KX = KX + INCX
|
||||
IX = KX
|
||||
L = 1 - J
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(1,J)
|
||||
DO 180 I = J + 1,MIN(N,J+K)
|
||||
TEMP = TEMP + A(L+I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
180 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*CONJG(A(1,J))
|
||||
DO 190 I = J + 1,MIN(N,J+K)
|
||||
TEMP = TEMP + CONJG(A(L+I,J))*X(IX)
|
||||
IX = IX + INCX
|
||||
190 CONTINUE
|
||||
END IF
|
||||
X(JX) = TEMP
|
||||
JX = JX + INCX
|
||||
200 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CTBMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,432 +0,0 @@
|
|||
*> \brief \b CTBSV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,K,LDA,N
|
||||
* CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CTBSV solves one of the systems of equations
|
||||
*>
|
||||
*> A*x = b, or A**T*x = b, or A**H*x = b,
|
||||
*>
|
||||
*> where b and x are n element vectors and A is an n by n unit, or
|
||||
*> non-unit, upper or lower triangular band matrix, with ( k + 1 )
|
||||
*> diagonals.
|
||||
*>
|
||||
*> No test for singularity or near-singularity is included in this
|
||||
*> routine. Such tests must be performed before calling this routine.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the matrix is an upper or
|
||||
*> lower triangular matrix as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the equations to be solved as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' A*x = b.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' A**T*x = b.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' A**H*x = b.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIAG
|
||||
*> \verbatim
|
||||
*> DIAG is CHARACTER*1
|
||||
*> On entry, DIAG specifies whether or not A is unit
|
||||
*> triangular as follows:
|
||||
*>
|
||||
*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*>
|
||||
*> DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
*> triangular.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> On entry with UPLO = 'U' or 'u', K specifies the number of
|
||||
*> super-diagonals of the matrix A.
|
||||
*> On entry with UPLO = 'L' or 'l', K specifies the number of
|
||||
*> sub-diagonals of the matrix A.
|
||||
*> K must satisfy 0 .le. K.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array of DIMENSION ( LDA, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
|
||||
*> by n part of the array A must contain the upper triangular
|
||||
*> band part of the matrix of coefficients, supplied column by
|
||||
*> column, with the leading diagonal of the matrix in row
|
||||
*> ( k + 1 ) of the array, the first super-diagonal starting at
|
||||
*> position 2 in row k, and so on. The top left k by k triangle
|
||||
*> of the array A is not referenced.
|
||||
*> The following program segment will transfer an upper
|
||||
*> triangular band matrix from conventional full matrix storage
|
||||
*> to band storage:
|
||||
*>
|
||||
*> DO 20, J = 1, N
|
||||
*> M = K + 1 - J
|
||||
*> DO 10, I = MAX( 1, J - K ), J
|
||||
*> A( M + I, J ) = matrix( I, J )
|
||||
*> 10 CONTINUE
|
||||
*> 20 CONTINUE
|
||||
*>
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
|
||||
*> by n part of the array A must contain the lower triangular
|
||||
*> band part of the matrix of coefficients, supplied column by
|
||||
*> column, with the leading diagonal of the matrix in row 1 of
|
||||
*> the array, the first sub-diagonal starting at position 1 in
|
||||
*> row 2, and so on. The bottom right k by k triangle of the
|
||||
*> array A is not referenced.
|
||||
*> The following program segment will transfer a lower
|
||||
*> triangular band matrix from conventional full matrix storage
|
||||
*> to band storage:
|
||||
*>
|
||||
*> DO 20, J = 1, N
|
||||
*> M = 1 - J
|
||||
*> DO 10, I = J, MIN( N, J + K )
|
||||
*> A( M + I, J ) = matrix( I, J )
|
||||
*> 10 CONTINUE
|
||||
*> 20 CONTINUE
|
||||
*>
|
||||
*> Note that when DIAG = 'U' or 'u' the elements of the array A
|
||||
*> corresponding to the diagonal elements of the matrix are not
|
||||
*> referenced, but are assumed to be unity.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> ( k + 1 ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element right-hand side vector b. On exit, X is overwritten
|
||||
*> with the solution vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,K,LDA,N
|
||||
CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP
|
||||
INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L
|
||||
LOGICAL NOCONJ,NOUNIT
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG,MAX,MIN
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 2
|
||||
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (LDA.LT. (K+1)) THEN
|
||||
INFO = 7
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CTBSV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (N.EQ.0) RETURN
|
||||
*
|
||||
NOCONJ = LSAME(TRANS,'T')
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
*
|
||||
* Set up the start point in X if the increment is not unity. This
|
||||
* will be ( N - 1 )*INCX too small for descending loops.
|
||||
*
|
||||
IF (INCX.LE.0) THEN
|
||||
KX = 1 - (N-1)*INCX
|
||||
ELSE IF (INCX.NE.1) THEN
|
||||
KX = 1
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed by sequentially with one pass through A.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form x := inv( A )*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
KPLUS1 = K + 1
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = N,1,-1
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
L = KPLUS1 - J
|
||||
IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J)
|
||||
TEMP = X(J)
|
||||
DO 10 I = J - 1,MAX(1,J-K),-1
|
||||
X(I) = X(I) - TEMP*A(L+I,J)
|
||||
10 CONTINUE
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
KX = KX + (N-1)*INCX
|
||||
JX = KX
|
||||
DO 40 J = N,1,-1
|
||||
KX = KX - INCX
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
IX = KX
|
||||
L = KPLUS1 - J
|
||||
IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J)
|
||||
TEMP = X(JX)
|
||||
DO 30 I = J - 1,MAX(1,J-K),-1
|
||||
X(IX) = X(IX) - TEMP*A(L+I,J)
|
||||
IX = IX - INCX
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JX = JX - INCX
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 60 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
L = 1 - J
|
||||
IF (NOUNIT) X(J) = X(J)/A(1,J)
|
||||
TEMP = X(J)
|
||||
DO 50 I = J + 1,MIN(N,J+K)
|
||||
X(I) = X(I) - TEMP*A(L+I,J)
|
||||
50 CONTINUE
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 80 J = 1,N
|
||||
KX = KX + INCX
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
IX = KX
|
||||
L = 1 - J
|
||||
IF (NOUNIT) X(JX) = X(JX)/A(1,J)
|
||||
TEMP = X(JX)
|
||||
DO 70 I = J + 1,MIN(N,J+K)
|
||||
X(IX) = X(IX) - TEMP*A(L+I,J)
|
||||
IX = IX + INCX
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form x := inv( A**T )*x or x := inv( A**H )*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
KPLUS1 = K + 1
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 110 J = 1,N
|
||||
TEMP = X(J)
|
||||
L = KPLUS1 - J
|
||||
IF (NOCONJ) THEN
|
||||
DO 90 I = MAX(1,J-K),J - 1
|
||||
TEMP = TEMP - A(L+I,J)*X(I)
|
||||
90 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J)
|
||||
ELSE
|
||||
DO 100 I = MAX(1,J-K),J - 1
|
||||
TEMP = TEMP - CONJG(A(L+I,J))*X(I)
|
||||
100 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/CONJG(A(KPLUS1,J))
|
||||
END IF
|
||||
X(J) = TEMP
|
||||
110 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 140 J = 1,N
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
L = KPLUS1 - J
|
||||
IF (NOCONJ) THEN
|
||||
DO 120 I = MAX(1,J-K),J - 1
|
||||
TEMP = TEMP - A(L+I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
120 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J)
|
||||
ELSE
|
||||
DO 130 I = MAX(1,J-K),J - 1
|
||||
TEMP = TEMP - CONJG(A(L+I,J))*X(IX)
|
||||
IX = IX + INCX
|
||||
130 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/CONJG(A(KPLUS1,J))
|
||||
END IF
|
||||
X(JX) = TEMP
|
||||
JX = JX + INCX
|
||||
IF (J.GT.K) KX = KX + INCX
|
||||
140 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 170 J = N,1,-1
|
||||
TEMP = X(J)
|
||||
L = 1 - J
|
||||
IF (NOCONJ) THEN
|
||||
DO 150 I = MIN(N,J+K),J + 1,-1
|
||||
TEMP = TEMP - A(L+I,J)*X(I)
|
||||
150 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/A(1,J)
|
||||
ELSE
|
||||
DO 160 I = MIN(N,J+K),J + 1,-1
|
||||
TEMP = TEMP - CONJG(A(L+I,J))*X(I)
|
||||
160 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/CONJG(A(1,J))
|
||||
END IF
|
||||
X(J) = TEMP
|
||||
170 CONTINUE
|
||||
ELSE
|
||||
KX = KX + (N-1)*INCX
|
||||
JX = KX
|
||||
DO 200 J = N,1,-1
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
L = 1 - J
|
||||
IF (NOCONJ) THEN
|
||||
DO 180 I = MIN(N,J+K),J + 1,-1
|
||||
TEMP = TEMP - A(L+I,J)*X(IX)
|
||||
IX = IX - INCX
|
||||
180 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/A(1,J)
|
||||
ELSE
|
||||
DO 190 I = MIN(N,J+K),J + 1,-1
|
||||
TEMP = TEMP - CONJG(A(L+I,J))*X(IX)
|
||||
IX = IX - INCX
|
||||
190 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/CONJG(A(1,J))
|
||||
END IF
|
||||
X(JX) = TEMP
|
||||
JX = JX - INCX
|
||||
IF ((N-J).GE.K) KX = KX - INCX
|
||||
200 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CTBSV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,388 +0,0 @@
|
|||
*> \brief \b CTPMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,N
|
||||
* CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX AP(*),X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CTPMV performs one of the matrix-vector operations
|
||||
*>
|
||||
*> x := A*x, or x := A**T*x, or x := A**H*x,
|
||||
*>
|
||||
*> where x is an n element vector and A is an n by n unit, or non-unit,
|
||||
*> upper or lower triangular matrix, supplied in packed form.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the matrix is an upper or
|
||||
*> lower triangular matrix as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the operation to be performed as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' x := A*x.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' x := A**T*x.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' x := A**H*x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIAG
|
||||
*> \verbatim
|
||||
*> DIAG is CHARACTER*1
|
||||
*> On entry, DIAG specifies whether or not A is unit
|
||||
*> triangular as follows:
|
||||
*>
|
||||
*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*>
|
||||
*> DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
*> triangular.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] AP
|
||||
*> \verbatim
|
||||
*> AP is COMPLEX array of DIMENSION at least
|
||||
*> ( ( n*( n + 1 ) )/2 ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the array AP must
|
||||
*> contain the upper triangular matrix packed sequentially,
|
||||
*> column by column, so that AP( 1 ) contains a( 1, 1 ),
|
||||
*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
|
||||
*> respectively, and so on.
|
||||
*> Before entry with UPLO = 'L' or 'l', the array AP must
|
||||
*> contain the lower triangular matrix packed sequentially,
|
||||
*> column by column, so that AP( 1 ) contains a( 1, 1 ),
|
||||
*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
|
||||
*> respectively, and so on.
|
||||
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
*> A are not referenced, but are assumed to be unity.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x. On exit, X is overwritten with the
|
||||
*> tranformed vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,N
|
||||
CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX AP(*),X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP
|
||||
INTEGER I,INFO,IX,J,JX,K,KK,KX
|
||||
LOGICAL NOCONJ,NOUNIT
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 2
|
||||
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 7
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CTPMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (N.EQ.0) RETURN
|
||||
*
|
||||
NOCONJ = LSAME(TRANS,'T')
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
*
|
||||
* Set up the start point in X if the increment is not unity. This
|
||||
* will be ( N - 1 )*INCX too small for descending loops.
|
||||
*
|
||||
IF (INCX.LE.0) THEN
|
||||
KX = 1 - (N-1)*INCX
|
||||
ELSE IF (INCX.NE.1) THEN
|
||||
KX = 1
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of AP are
|
||||
* accessed sequentially with one pass through AP.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form x:= A*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
KK = 1
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = X(J)
|
||||
K = KK
|
||||
DO 10 I = 1,J - 1
|
||||
X(I) = X(I) + TEMP*AP(K)
|
||||
K = K + 1
|
||||
10 CONTINUE
|
||||
IF (NOUNIT) X(J) = X(J)*AP(KK+J-1)
|
||||
END IF
|
||||
KK = KK + J
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 40 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
DO 30 K = KK,KK + J - 2
|
||||
X(IX) = X(IX) + TEMP*AP(K)
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
IF (NOUNIT) X(JX) = X(JX)*AP(KK+J-1)
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
KK = KK + J
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
KK = (N* (N+1))/2
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 60 J = N,1,-1
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = X(J)
|
||||
K = KK
|
||||
DO 50 I = N,J + 1,-1
|
||||
X(I) = X(I) + TEMP*AP(K)
|
||||
K = K - 1
|
||||
50 CONTINUE
|
||||
IF (NOUNIT) X(J) = X(J)*AP(KK-N+J)
|
||||
END IF
|
||||
KK = KK - (N-J+1)
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
KX = KX + (N-1)*INCX
|
||||
JX = KX
|
||||
DO 80 J = N,1,-1
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
DO 70 K = KK,KK - (N- (J+1)),-1
|
||||
X(IX) = X(IX) + TEMP*AP(K)
|
||||
IX = IX - INCX
|
||||
70 CONTINUE
|
||||
IF (NOUNIT) X(JX) = X(JX)*AP(KK-N+J)
|
||||
END IF
|
||||
JX = JX - INCX
|
||||
KK = KK - (N-J+1)
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form x := A**T*x or x := A**H*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
KK = (N* (N+1))/2
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 110 J = N,1,-1
|
||||
TEMP = X(J)
|
||||
K = KK - 1
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*AP(KK)
|
||||
DO 90 I = J - 1,1,-1
|
||||
TEMP = TEMP + AP(K)*X(I)
|
||||
K = K - 1
|
||||
90 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*CONJG(AP(KK))
|
||||
DO 100 I = J - 1,1,-1
|
||||
TEMP = TEMP + CONJG(AP(K))*X(I)
|
||||
K = K - 1
|
||||
100 CONTINUE
|
||||
END IF
|
||||
X(J) = TEMP
|
||||
KK = KK - J
|
||||
110 CONTINUE
|
||||
ELSE
|
||||
JX = KX + (N-1)*INCX
|
||||
DO 140 J = N,1,-1
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*AP(KK)
|
||||
DO 120 K = KK - 1,KK - J + 1,-1
|
||||
IX = IX - INCX
|
||||
TEMP = TEMP + AP(K)*X(IX)
|
||||
120 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*CONJG(AP(KK))
|
||||
DO 130 K = KK - 1,KK - J + 1,-1
|
||||
IX = IX - INCX
|
||||
TEMP = TEMP + CONJG(AP(K))*X(IX)
|
||||
130 CONTINUE
|
||||
END IF
|
||||
X(JX) = TEMP
|
||||
JX = JX - INCX
|
||||
KK = KK - J
|
||||
140 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
KK = 1
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 170 J = 1,N
|
||||
TEMP = X(J)
|
||||
K = KK + 1
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*AP(KK)
|
||||
DO 150 I = J + 1,N
|
||||
TEMP = TEMP + AP(K)*X(I)
|
||||
K = K + 1
|
||||
150 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*CONJG(AP(KK))
|
||||
DO 160 I = J + 1,N
|
||||
TEMP = TEMP + CONJG(AP(K))*X(I)
|
||||
K = K + 1
|
||||
160 CONTINUE
|
||||
END IF
|
||||
X(J) = TEMP
|
||||
KK = KK + (N-J+1)
|
||||
170 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 200 J = 1,N
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*AP(KK)
|
||||
DO 180 K = KK + 1,KK + N - J
|
||||
IX = IX + INCX
|
||||
TEMP = TEMP + AP(K)*X(IX)
|
||||
180 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*CONJG(AP(KK))
|
||||
DO 190 K = KK + 1,KK + N - J
|
||||
IX = IX + INCX
|
||||
TEMP = TEMP + CONJG(AP(K))*X(IX)
|
||||
190 CONTINUE
|
||||
END IF
|
||||
X(JX) = TEMP
|
||||
JX = JX + INCX
|
||||
KK = KK + (N-J+1)
|
||||
200 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CTPMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,390 +0,0 @@
|
|||
*> \brief \b CTPSV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,N
|
||||
* CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX AP(*),X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CTPSV solves one of the systems of equations
|
||||
*>
|
||||
*> A*x = b, or A**T*x = b, or A**H*x = b,
|
||||
*>
|
||||
*> where b and x are n element vectors and A is an n by n unit, or
|
||||
*> non-unit, upper or lower triangular matrix, supplied in packed form.
|
||||
*>
|
||||
*> No test for singularity or near-singularity is included in this
|
||||
*> routine. Such tests must be performed before calling this routine.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the matrix is an upper or
|
||||
*> lower triangular matrix as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the equations to be solved as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' A*x = b.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' A**T*x = b.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' A**H*x = b.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIAG
|
||||
*> \verbatim
|
||||
*> DIAG is CHARACTER*1
|
||||
*> On entry, DIAG specifies whether or not A is unit
|
||||
*> triangular as follows:
|
||||
*>
|
||||
*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*>
|
||||
*> DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
*> triangular.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] AP
|
||||
*> \verbatim
|
||||
*> AP is COMPLEX array of DIMENSION at least
|
||||
*> ( ( n*( n + 1 ) )/2 ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the array AP must
|
||||
*> contain the upper triangular matrix packed sequentially,
|
||||
*> column by column, so that AP( 1 ) contains a( 1, 1 ),
|
||||
*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
|
||||
*> respectively, and so on.
|
||||
*> Before entry with UPLO = 'L' or 'l', the array AP must
|
||||
*> contain the lower triangular matrix packed sequentially,
|
||||
*> column by column, so that AP( 1 ) contains a( 1, 1 ),
|
||||
*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
|
||||
*> respectively, and so on.
|
||||
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
*> A are not referenced, but are assumed to be unity.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element right-hand side vector b. On exit, X is overwritten
|
||||
*> with the solution vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,N
|
||||
CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX AP(*),X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP
|
||||
INTEGER I,INFO,IX,J,JX,K,KK,KX
|
||||
LOGICAL NOCONJ,NOUNIT
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 2
|
||||
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 7
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CTPSV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (N.EQ.0) RETURN
|
||||
*
|
||||
NOCONJ = LSAME(TRANS,'T')
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
*
|
||||
* Set up the start point in X if the increment is not unity. This
|
||||
* will be ( N - 1 )*INCX too small for descending loops.
|
||||
*
|
||||
IF (INCX.LE.0) THEN
|
||||
KX = 1 - (N-1)*INCX
|
||||
ELSE IF (INCX.NE.1) THEN
|
||||
KX = 1
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of AP are
|
||||
* accessed sequentially with one pass through AP.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form x := inv( A )*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
KK = (N* (N+1))/2
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = N,1,-1
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
IF (NOUNIT) X(J) = X(J)/AP(KK)
|
||||
TEMP = X(J)
|
||||
K = KK - 1
|
||||
DO 10 I = J - 1,1,-1
|
||||
X(I) = X(I) - TEMP*AP(K)
|
||||
K = K - 1
|
||||
10 CONTINUE
|
||||
END IF
|
||||
KK = KK - J
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX + (N-1)*INCX
|
||||
DO 40 J = N,1,-1
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
IF (NOUNIT) X(JX) = X(JX)/AP(KK)
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
DO 30 K = KK - 1,KK - J + 1,-1
|
||||
IX = IX - INCX
|
||||
X(IX) = X(IX) - TEMP*AP(K)
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JX = JX - INCX
|
||||
KK = KK - J
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
KK = 1
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 60 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
IF (NOUNIT) X(J) = X(J)/AP(KK)
|
||||
TEMP = X(J)
|
||||
K = KK + 1
|
||||
DO 50 I = J + 1,N
|
||||
X(I) = X(I) - TEMP*AP(K)
|
||||
K = K + 1
|
||||
50 CONTINUE
|
||||
END IF
|
||||
KK = KK + (N-J+1)
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 80 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
IF (NOUNIT) X(JX) = X(JX)/AP(KK)
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
DO 70 K = KK + 1,KK + N - J
|
||||
IX = IX + INCX
|
||||
X(IX) = X(IX) - TEMP*AP(K)
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
KK = KK + (N-J+1)
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form x := inv( A**T )*x or x := inv( A**H )*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
KK = 1
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 110 J = 1,N
|
||||
TEMP = X(J)
|
||||
K = KK
|
||||
IF (NOCONJ) THEN
|
||||
DO 90 I = 1,J - 1
|
||||
TEMP = TEMP - AP(K)*X(I)
|
||||
K = K + 1
|
||||
90 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/AP(KK+J-1)
|
||||
ELSE
|
||||
DO 100 I = 1,J - 1
|
||||
TEMP = TEMP - CONJG(AP(K))*X(I)
|
||||
K = K + 1
|
||||
100 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/CONJG(AP(KK+J-1))
|
||||
END IF
|
||||
X(J) = TEMP
|
||||
KK = KK + J
|
||||
110 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 140 J = 1,N
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
IF (NOCONJ) THEN
|
||||
DO 120 K = KK,KK + J - 2
|
||||
TEMP = TEMP - AP(K)*X(IX)
|
||||
IX = IX + INCX
|
||||
120 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/AP(KK+J-1)
|
||||
ELSE
|
||||
DO 130 K = KK,KK + J - 2
|
||||
TEMP = TEMP - CONJG(AP(K))*X(IX)
|
||||
IX = IX + INCX
|
||||
130 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/CONJG(AP(KK+J-1))
|
||||
END IF
|
||||
X(JX) = TEMP
|
||||
JX = JX + INCX
|
||||
KK = KK + J
|
||||
140 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
KK = (N* (N+1))/2
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 170 J = N,1,-1
|
||||
TEMP = X(J)
|
||||
K = KK
|
||||
IF (NOCONJ) THEN
|
||||
DO 150 I = N,J + 1,-1
|
||||
TEMP = TEMP - AP(K)*X(I)
|
||||
K = K - 1
|
||||
150 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/AP(KK-N+J)
|
||||
ELSE
|
||||
DO 160 I = N,J + 1,-1
|
||||
TEMP = TEMP - CONJG(AP(K))*X(I)
|
||||
K = K - 1
|
||||
160 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/CONJG(AP(KK-N+J))
|
||||
END IF
|
||||
X(J) = TEMP
|
||||
KK = KK - (N-J+1)
|
||||
170 CONTINUE
|
||||
ELSE
|
||||
KX = KX + (N-1)*INCX
|
||||
JX = KX
|
||||
DO 200 J = N,1,-1
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
IF (NOCONJ) THEN
|
||||
DO 180 K = KK,KK - (N- (J+1)),-1
|
||||
TEMP = TEMP - AP(K)*X(IX)
|
||||
IX = IX - INCX
|
||||
180 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/AP(KK-N+J)
|
||||
ELSE
|
||||
DO 190 K = KK,KK - (N- (J+1)),-1
|
||||
TEMP = TEMP - CONJG(AP(K))*X(IX)
|
||||
IX = IX - INCX
|
||||
190 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/CONJG(AP(KK-N+J))
|
||||
END IF
|
||||
X(JX) = TEMP
|
||||
JX = JX - INCX
|
||||
KK = KK - (N-J+1)
|
||||
200 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CTPSV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,452 +0,0 @@
|
|||
*> \brief \b CTRMM
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX ALPHA
|
||||
* INTEGER LDA,LDB,M,N
|
||||
* CHARACTER DIAG,SIDE,TRANSA,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A(LDA,*),B(LDB,*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CTRMM performs one of the matrix-matrix operations
|
||||
*>
|
||||
*> B := alpha*op( A )*B, or B := alpha*B*op( A )
|
||||
*>
|
||||
*> where alpha is a scalar, B is an m by n matrix, A is a unit, or
|
||||
*> non-unit, upper or lower triangular matrix and op( A ) is one of
|
||||
*>
|
||||
*> op( A ) = A or op( A ) = A**T or op( A ) = A**H.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> On entry, SIDE specifies whether op( A ) multiplies B from
|
||||
*> the left or right as follows:
|
||||
*>
|
||||
*> SIDE = 'L' or 'l' B := alpha*op( A )*B.
|
||||
*>
|
||||
*> SIDE = 'R' or 'r' B := alpha*B*op( A ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the matrix A is an upper or
|
||||
*> lower triangular matrix as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANSA
|
||||
*> \verbatim
|
||||
*> TRANSA is CHARACTER*1
|
||||
*> On entry, TRANSA specifies the form of op( A ) to be used in
|
||||
*> the matrix multiplication as follows:
|
||||
*>
|
||||
*> TRANSA = 'N' or 'n' op( A ) = A.
|
||||
*>
|
||||
*> TRANSA = 'T' or 't' op( A ) = A**T.
|
||||
*>
|
||||
*> TRANSA = 'C' or 'c' op( A ) = A**H.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIAG
|
||||
*> \verbatim
|
||||
*> DIAG is CHARACTER*1
|
||||
*> On entry, DIAG specifies whether or not A is unit triangular
|
||||
*> as follows:
|
||||
*>
|
||||
*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*>
|
||||
*> DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
*> triangular.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of B. M must be at
|
||||
*> least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of B. N must be
|
||||
*> at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX
|
||||
*> On entry, ALPHA specifies the scalar alpha. When alpha is
|
||||
*> zero then A is not referenced and B need not be set before
|
||||
*> entry.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array of DIMENSION ( LDA, k ), where k is m
|
||||
*> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading k by k
|
||||
*> upper triangular part of the array A must contain the upper
|
||||
*> triangular matrix and the strictly lower triangular part of
|
||||
*> A is not referenced.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading k by k
|
||||
*> lower triangular part of the array A must contain the lower
|
||||
*> triangular matrix and the strictly upper triangular part of
|
||||
*> A is not referenced.
|
||||
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
*> A are not referenced either, but are assumed to be unity.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. When SIDE = 'L' or 'l' then
|
||||
*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
|
||||
*> then LDA must be at least max( 1, n ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] B
|
||||
*> \verbatim
|
||||
*> B is COMPLEX array of DIMENSION ( LDB, n ).
|
||||
*> Before entry, the leading m by n part of the array B must
|
||||
*> contain the matrix B, and on exit is overwritten by the
|
||||
*> transformed matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> On entry, LDB specifies the first dimension of B as declared
|
||||
*> in the calling (sub) program. LDB must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level3
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 3 Blas routine.
|
||||
*>
|
||||
*> -- Written on 8-February-1989.
|
||||
*> Jack Dongarra, Argonne National Laboratory.
|
||||
*> Iain Duff, AERE Harwell.
|
||||
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
*> Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
|
||||
*
|
||||
* -- Reference BLAS level3 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX ALPHA
|
||||
INTEGER LDA,LDB,M,N
|
||||
CHARACTER DIAG,SIDE,TRANSA,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),B(LDB,*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG,MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP
|
||||
INTEGER I,INFO,J,K,NROWA
|
||||
LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
COMPLEX ONE
|
||||
PARAMETER (ONE= (1.0E+0,0.0E+0))
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
LSIDE = LSAME(SIDE,'L')
|
||||
IF (LSIDE) THEN
|
||||
NROWA = M
|
||||
ELSE
|
||||
NROWA = N
|
||||
END IF
|
||||
NOCONJ = LSAME(TRANSA,'T')
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
UPPER = LSAME(UPLO,'U')
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
|
||||
+ (.NOT.LSAME(TRANSA,'T')) .AND.
|
||||
+ (.NOT.LSAME(TRANSA,'C'))) THEN
|
||||
INFO = 3
|
||||
ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
|
||||
INFO = 4
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 6
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 9
|
||||
ELSE IF (LDB.LT.MAX(1,M)) THEN
|
||||
INFO = 11
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CTRMM ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (M.EQ.0 .OR. N.EQ.0) RETURN
|
||||
*
|
||||
* And when alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,M
|
||||
B(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (LSIDE) THEN
|
||||
IF (LSAME(TRANSA,'N')) THEN
|
||||
*
|
||||
* Form B := alpha*A*B.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 50 J = 1,N
|
||||
DO 40 K = 1,M
|
||||
IF (B(K,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(K,J)
|
||||
DO 30 I = 1,K - 1
|
||||
B(I,J) = B(I,J) + TEMP*A(I,K)
|
||||
30 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP*A(K,K)
|
||||
B(K,J) = TEMP
|
||||
END IF
|
||||
40 CONTINUE
|
||||
50 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
DO 70 K = M,1,-1
|
||||
IF (B(K,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(K,J)
|
||||
B(K,J) = TEMP
|
||||
IF (NOUNIT) B(K,J) = B(K,J)*A(K,K)
|
||||
DO 60 I = K + 1,M
|
||||
B(I,J) = B(I,J) + TEMP*A(I,K)
|
||||
60 CONTINUE
|
||||
END IF
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form B := alpha*A**T*B or B := alpha*A**H*B.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 120 J = 1,N
|
||||
DO 110 I = M,1,-1
|
||||
TEMP = B(I,J)
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(I,I)
|
||||
DO 90 K = 1,I - 1
|
||||
TEMP = TEMP + A(K,I)*B(K,J)
|
||||
90 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*CONJG(A(I,I))
|
||||
DO 100 K = 1,I - 1
|
||||
TEMP = TEMP + CONJG(A(K,I))*B(K,J)
|
||||
100 CONTINUE
|
||||
END IF
|
||||
B(I,J) = ALPHA*TEMP
|
||||
110 CONTINUE
|
||||
120 CONTINUE
|
||||
ELSE
|
||||
DO 160 J = 1,N
|
||||
DO 150 I = 1,M
|
||||
TEMP = B(I,J)
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(I,I)
|
||||
DO 130 K = I + 1,M
|
||||
TEMP = TEMP + A(K,I)*B(K,J)
|
||||
130 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*CONJG(A(I,I))
|
||||
DO 140 K = I + 1,M
|
||||
TEMP = TEMP + CONJG(A(K,I))*B(K,J)
|
||||
140 CONTINUE
|
||||
END IF
|
||||
B(I,J) = ALPHA*TEMP
|
||||
150 CONTINUE
|
||||
160 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
IF (LSAME(TRANSA,'N')) THEN
|
||||
*
|
||||
* Form B := alpha*B*A.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 200 J = N,1,-1
|
||||
TEMP = ALPHA
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 170 I = 1,M
|
||||
B(I,J) = TEMP*B(I,J)
|
||||
170 CONTINUE
|
||||
DO 190 K = 1,J - 1
|
||||
IF (A(K,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*A(K,J)
|
||||
DO 180 I = 1,M
|
||||
B(I,J) = B(I,J) + TEMP*B(I,K)
|
||||
180 CONTINUE
|
||||
END IF
|
||||
190 CONTINUE
|
||||
200 CONTINUE
|
||||
ELSE
|
||||
DO 240 J = 1,N
|
||||
TEMP = ALPHA
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 210 I = 1,M
|
||||
B(I,J) = TEMP*B(I,J)
|
||||
210 CONTINUE
|
||||
DO 230 K = J + 1,N
|
||||
IF (A(K,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*A(K,J)
|
||||
DO 220 I = 1,M
|
||||
B(I,J) = B(I,J) + TEMP*B(I,K)
|
||||
220 CONTINUE
|
||||
END IF
|
||||
230 CONTINUE
|
||||
240 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form B := alpha*B*A**T or B := alpha*B*A**H.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 280 K = 1,N
|
||||
DO 260 J = 1,K - 1
|
||||
IF (A(J,K).NE.ZERO) THEN
|
||||
IF (NOCONJ) THEN
|
||||
TEMP = ALPHA*A(J,K)
|
||||
ELSE
|
||||
TEMP = ALPHA*CONJG(A(J,K))
|
||||
END IF
|
||||
DO 250 I = 1,M
|
||||
B(I,J) = B(I,J) + TEMP*B(I,K)
|
||||
250 CONTINUE
|
||||
END IF
|
||||
260 CONTINUE
|
||||
TEMP = ALPHA
|
||||
IF (NOUNIT) THEN
|
||||
IF (NOCONJ) THEN
|
||||
TEMP = TEMP*A(K,K)
|
||||
ELSE
|
||||
TEMP = TEMP*CONJG(A(K,K))
|
||||
END IF
|
||||
END IF
|
||||
IF (TEMP.NE.ONE) THEN
|
||||
DO 270 I = 1,M
|
||||
B(I,K) = TEMP*B(I,K)
|
||||
270 CONTINUE
|
||||
END IF
|
||||
280 CONTINUE
|
||||
ELSE
|
||||
DO 320 K = N,1,-1
|
||||
DO 300 J = K + 1,N
|
||||
IF (A(J,K).NE.ZERO) THEN
|
||||
IF (NOCONJ) THEN
|
||||
TEMP = ALPHA*A(J,K)
|
||||
ELSE
|
||||
TEMP = ALPHA*CONJG(A(J,K))
|
||||
END IF
|
||||
DO 290 I = 1,M
|
||||
B(I,J) = B(I,J) + TEMP*B(I,K)
|
||||
290 CONTINUE
|
||||
END IF
|
||||
300 CONTINUE
|
||||
TEMP = ALPHA
|
||||
IF (NOUNIT) THEN
|
||||
IF (NOCONJ) THEN
|
||||
TEMP = TEMP*A(K,K)
|
||||
ELSE
|
||||
TEMP = TEMP*CONJG(A(K,K))
|
||||
END IF
|
||||
END IF
|
||||
IF (TEMP.NE.ONE) THEN
|
||||
DO 310 I = 1,M
|
||||
B(I,K) = TEMP*B(I,K)
|
||||
310 CONTINUE
|
||||
END IF
|
||||
320 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CTRMM .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,373 +0,0 @@
|
|||
*> \brief \b CTRMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,LDA,N
|
||||
* CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CTRMV performs one of the matrix-vector operations
|
||||
*>
|
||||
*> x := A*x, or x := A**T*x, or x := A**H*x,
|
||||
*>
|
||||
*> where x is an n element vector and A is an n by n unit, or non-unit,
|
||||
*> upper or lower triangular matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the matrix is an upper or
|
||||
*> lower triangular matrix as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the operation to be performed as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' x := A*x.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' x := A**T*x.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' x := A**H*x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIAG
|
||||
*> \verbatim
|
||||
*> DIAG is CHARACTER*1
|
||||
*> On entry, DIAG specifies whether or not A is unit
|
||||
*> triangular as follows:
|
||||
*>
|
||||
*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*>
|
||||
*> DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
*> triangular.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array of DIMENSION ( LDA, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
*> upper triangular part of the array A must contain the upper
|
||||
*> triangular matrix and the strictly lower triangular part of
|
||||
*> A is not referenced.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
*> lower triangular part of the array A must contain the lower
|
||||
*> triangular matrix and the strictly upper triangular part of
|
||||
*> A is not referenced.
|
||||
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
*> A are not referenced either, but are assumed to be unity.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, n ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x. On exit, X is overwritten with the
|
||||
*> tranformed vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,LDA,N
|
||||
CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP
|
||||
INTEGER I,INFO,IX,J,JX,KX
|
||||
LOGICAL NOCONJ,NOUNIT
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG,MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 2
|
||||
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (LDA.LT.MAX(1,N)) THEN
|
||||
INFO = 6
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 8
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CTRMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (N.EQ.0) RETURN
|
||||
*
|
||||
NOCONJ = LSAME(TRANS,'T')
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
*
|
||||
* Set up the start point in X if the increment is not unity. This
|
||||
* will be ( N - 1 )*INCX too small for descending loops.
|
||||
*
|
||||
IF (INCX.LE.0) THEN
|
||||
KX = 1 - (N-1)*INCX
|
||||
ELSE IF (INCX.NE.1) THEN
|
||||
KX = 1
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form x := A*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = X(J)
|
||||
DO 10 I = 1,J - 1
|
||||
X(I) = X(I) + TEMP*A(I,J)
|
||||
10 CONTINUE
|
||||
IF (NOUNIT) X(J) = X(J)*A(J,J)
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 40 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
DO 30 I = 1,J - 1
|
||||
X(IX) = X(IX) + TEMP*A(I,J)
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
IF (NOUNIT) X(JX) = X(JX)*A(J,J)
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 60 J = N,1,-1
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = X(J)
|
||||
DO 50 I = N,J + 1,-1
|
||||
X(I) = X(I) + TEMP*A(I,J)
|
||||
50 CONTINUE
|
||||
IF (NOUNIT) X(J) = X(J)*A(J,J)
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
KX = KX + (N-1)*INCX
|
||||
JX = KX
|
||||
DO 80 J = N,1,-1
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
DO 70 I = N,J + 1,-1
|
||||
X(IX) = X(IX) + TEMP*A(I,J)
|
||||
IX = IX - INCX
|
||||
70 CONTINUE
|
||||
IF (NOUNIT) X(JX) = X(JX)*A(J,J)
|
||||
END IF
|
||||
JX = JX - INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form x := A**T*x or x := A**H*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 110 J = N,1,-1
|
||||
TEMP = X(J)
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 90 I = J - 1,1,-1
|
||||
TEMP = TEMP + A(I,J)*X(I)
|
||||
90 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*CONJG(A(J,J))
|
||||
DO 100 I = J - 1,1,-1
|
||||
TEMP = TEMP + CONJG(A(I,J))*X(I)
|
||||
100 CONTINUE
|
||||
END IF
|
||||
X(J) = TEMP
|
||||
110 CONTINUE
|
||||
ELSE
|
||||
JX = KX + (N-1)*INCX
|
||||
DO 140 J = N,1,-1
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 120 I = J - 1,1,-1
|
||||
IX = IX - INCX
|
||||
TEMP = TEMP + A(I,J)*X(IX)
|
||||
120 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*CONJG(A(J,J))
|
||||
DO 130 I = J - 1,1,-1
|
||||
IX = IX - INCX
|
||||
TEMP = TEMP + CONJG(A(I,J))*X(IX)
|
||||
130 CONTINUE
|
||||
END IF
|
||||
X(JX) = TEMP
|
||||
JX = JX - INCX
|
||||
140 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 170 J = 1,N
|
||||
TEMP = X(J)
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 150 I = J + 1,N
|
||||
TEMP = TEMP + A(I,J)*X(I)
|
||||
150 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*CONJG(A(J,J))
|
||||
DO 160 I = J + 1,N
|
||||
TEMP = TEMP + CONJG(A(I,J))*X(I)
|
||||
160 CONTINUE
|
||||
END IF
|
||||
X(J) = TEMP
|
||||
170 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 200 J = 1,N
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 180 I = J + 1,N
|
||||
IX = IX + INCX
|
||||
TEMP = TEMP + A(I,J)*X(IX)
|
||||
180 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*CONJG(A(J,J))
|
||||
DO 190 I = J + 1,N
|
||||
IX = IX + INCX
|
||||
TEMP = TEMP + CONJG(A(I,J))*X(IX)
|
||||
190 CONTINUE
|
||||
END IF
|
||||
X(JX) = TEMP
|
||||
JX = JX + INCX
|
||||
200 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CTRMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,477 +0,0 @@
|
|||
*> \brief \b CTRSM
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX ALPHA
|
||||
* INTEGER LDA,LDB,M,N
|
||||
* CHARACTER DIAG,SIDE,TRANSA,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A(LDA,*),B(LDB,*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CTRSM solves one of the matrix equations
|
||||
*>
|
||||
*> op( A )*X = alpha*B, or X*op( A ) = alpha*B,
|
||||
*>
|
||||
*> where alpha is a scalar, X and B are m by n matrices, A is a unit, or
|
||||
*> non-unit, upper or lower triangular matrix and op( A ) is one of
|
||||
*>
|
||||
*> op( A ) = A or op( A ) = A**T or op( A ) = A**H.
|
||||
*>
|
||||
*> The matrix X is overwritten on B.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> On entry, SIDE specifies whether op( A ) appears on the left
|
||||
*> or right of X as follows:
|
||||
*>
|
||||
*> SIDE = 'L' or 'l' op( A )*X = alpha*B.
|
||||
*>
|
||||
*> SIDE = 'R' or 'r' X*op( A ) = alpha*B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the matrix A is an upper or
|
||||
*> lower triangular matrix as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANSA
|
||||
*> \verbatim
|
||||
*> TRANSA is CHARACTER*1
|
||||
*> On entry, TRANSA specifies the form of op( A ) to be used in
|
||||
*> the matrix multiplication as follows:
|
||||
*>
|
||||
*> TRANSA = 'N' or 'n' op( A ) = A.
|
||||
*>
|
||||
*> TRANSA = 'T' or 't' op( A ) = A**T.
|
||||
*>
|
||||
*> TRANSA = 'C' or 'c' op( A ) = A**H.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIAG
|
||||
*> \verbatim
|
||||
*> DIAG is CHARACTER*1
|
||||
*> On entry, DIAG specifies whether or not A is unit triangular
|
||||
*> as follows:
|
||||
*>
|
||||
*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*>
|
||||
*> DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
*> triangular.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of B. M must be at
|
||||
*> least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of B. N must be
|
||||
*> at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX
|
||||
*> On entry, ALPHA specifies the scalar alpha. When alpha is
|
||||
*> zero then A is not referenced and B need not be set before
|
||||
*> entry.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array of DIMENSION ( LDA, k ),
|
||||
*> where k is m when SIDE = 'L' or 'l'
|
||||
*> and k is n when SIDE = 'R' or 'r'.
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading k by k
|
||||
*> upper triangular part of the array A must contain the upper
|
||||
*> triangular matrix and the strictly lower triangular part of
|
||||
*> A is not referenced.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading k by k
|
||||
*> lower triangular part of the array A must contain the lower
|
||||
*> triangular matrix and the strictly upper triangular part of
|
||||
*> A is not referenced.
|
||||
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
*> A are not referenced either, but are assumed to be unity.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. When SIDE = 'L' or 'l' then
|
||||
*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
|
||||
*> then LDA must be at least max( 1, n ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] B
|
||||
*> \verbatim
|
||||
*> B is COMPLEX array of DIMENSION ( LDB, n ).
|
||||
*> Before entry, the leading m by n part of the array B must
|
||||
*> contain the right-hand side matrix B, and on exit is
|
||||
*> overwritten by the solution matrix X.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> On entry, LDB specifies the first dimension of B as declared
|
||||
*> in the calling (sub) program. LDB must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level3
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 3 Blas routine.
|
||||
*>
|
||||
*> -- Written on 8-February-1989.
|
||||
*> Jack Dongarra, Argonne National Laboratory.
|
||||
*> Iain Duff, AERE Harwell.
|
||||
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
*> Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
|
||||
*
|
||||
* -- Reference BLAS level3 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX ALPHA
|
||||
INTEGER LDA,LDB,M,N
|
||||
CHARACTER DIAG,SIDE,TRANSA,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),B(LDB,*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG,MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP
|
||||
INTEGER I,INFO,J,K,NROWA
|
||||
LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
COMPLEX ONE
|
||||
PARAMETER (ONE= (1.0E+0,0.0E+0))
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
LSIDE = LSAME(SIDE,'L')
|
||||
IF (LSIDE) THEN
|
||||
NROWA = M
|
||||
ELSE
|
||||
NROWA = N
|
||||
END IF
|
||||
NOCONJ = LSAME(TRANSA,'T')
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
UPPER = LSAME(UPLO,'U')
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
|
||||
+ (.NOT.LSAME(TRANSA,'T')) .AND.
|
||||
+ (.NOT.LSAME(TRANSA,'C'))) THEN
|
||||
INFO = 3
|
||||
ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
|
||||
INFO = 4
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 6
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 9
|
||||
ELSE IF (LDB.LT.MAX(1,M)) THEN
|
||||
INFO = 11
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CTRSM ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (M.EQ.0 .OR. N.EQ.0) RETURN
|
||||
*
|
||||
* And when alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,M
|
||||
B(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (LSIDE) THEN
|
||||
IF (LSAME(TRANSA,'N')) THEN
|
||||
*
|
||||
* Form B := alpha*inv( A )*B.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 60 J = 1,N
|
||||
IF (ALPHA.NE.ONE) THEN
|
||||
DO 30 I = 1,M
|
||||
B(I,J) = ALPHA*B(I,J)
|
||||
30 CONTINUE
|
||||
END IF
|
||||
DO 50 K = M,1,-1
|
||||
IF (B(K,J).NE.ZERO) THEN
|
||||
IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
|
||||
DO 40 I = 1,K - 1
|
||||
B(I,J) = B(I,J) - B(K,J)*A(I,K)
|
||||
40 CONTINUE
|
||||
END IF
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 100 J = 1,N
|
||||
IF (ALPHA.NE.ONE) THEN
|
||||
DO 70 I = 1,M
|
||||
B(I,J) = ALPHA*B(I,J)
|
||||
70 CONTINUE
|
||||
END IF
|
||||
DO 90 K = 1,M
|
||||
IF (B(K,J).NE.ZERO) THEN
|
||||
IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
|
||||
DO 80 I = K + 1,M
|
||||
B(I,J) = B(I,J) - B(K,J)*A(I,K)
|
||||
80 CONTINUE
|
||||
END IF
|
||||
90 CONTINUE
|
||||
100 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form B := alpha*inv( A**T )*B
|
||||
* or B := alpha*inv( A**H )*B.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 140 J = 1,N
|
||||
DO 130 I = 1,M
|
||||
TEMP = ALPHA*B(I,J)
|
||||
IF (NOCONJ) THEN
|
||||
DO 110 K = 1,I - 1
|
||||
TEMP = TEMP - A(K,I)*B(K,J)
|
||||
110 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/A(I,I)
|
||||
ELSE
|
||||
DO 120 K = 1,I - 1
|
||||
TEMP = TEMP - CONJG(A(K,I))*B(K,J)
|
||||
120 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/CONJG(A(I,I))
|
||||
END IF
|
||||
B(I,J) = TEMP
|
||||
130 CONTINUE
|
||||
140 CONTINUE
|
||||
ELSE
|
||||
DO 180 J = 1,N
|
||||
DO 170 I = M,1,-1
|
||||
TEMP = ALPHA*B(I,J)
|
||||
IF (NOCONJ) THEN
|
||||
DO 150 K = I + 1,M
|
||||
TEMP = TEMP - A(K,I)*B(K,J)
|
||||
150 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/A(I,I)
|
||||
ELSE
|
||||
DO 160 K = I + 1,M
|
||||
TEMP = TEMP - CONJG(A(K,I))*B(K,J)
|
||||
160 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/CONJG(A(I,I))
|
||||
END IF
|
||||
B(I,J) = TEMP
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
IF (LSAME(TRANSA,'N')) THEN
|
||||
*
|
||||
* Form B := alpha*B*inv( A ).
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 230 J = 1,N
|
||||
IF (ALPHA.NE.ONE) THEN
|
||||
DO 190 I = 1,M
|
||||
B(I,J) = ALPHA*B(I,J)
|
||||
190 CONTINUE
|
||||
END IF
|
||||
DO 210 K = 1,J - 1
|
||||
IF (A(K,J).NE.ZERO) THEN
|
||||
DO 200 I = 1,M
|
||||
B(I,J) = B(I,J) - A(K,J)*B(I,K)
|
||||
200 CONTINUE
|
||||
END IF
|
||||
210 CONTINUE
|
||||
IF (NOUNIT) THEN
|
||||
TEMP = ONE/A(J,J)
|
||||
DO 220 I = 1,M
|
||||
B(I,J) = TEMP*B(I,J)
|
||||
220 CONTINUE
|
||||
END IF
|
||||
230 CONTINUE
|
||||
ELSE
|
||||
DO 280 J = N,1,-1
|
||||
IF (ALPHA.NE.ONE) THEN
|
||||
DO 240 I = 1,M
|
||||
B(I,J) = ALPHA*B(I,J)
|
||||
240 CONTINUE
|
||||
END IF
|
||||
DO 260 K = J + 1,N
|
||||
IF (A(K,J).NE.ZERO) THEN
|
||||
DO 250 I = 1,M
|
||||
B(I,J) = B(I,J) - A(K,J)*B(I,K)
|
||||
250 CONTINUE
|
||||
END IF
|
||||
260 CONTINUE
|
||||
IF (NOUNIT) THEN
|
||||
TEMP = ONE/A(J,J)
|
||||
DO 270 I = 1,M
|
||||
B(I,J) = TEMP*B(I,J)
|
||||
270 CONTINUE
|
||||
END IF
|
||||
280 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form B := alpha*B*inv( A**T )
|
||||
* or B := alpha*B*inv( A**H ).
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 330 K = N,1,-1
|
||||
IF (NOUNIT) THEN
|
||||
IF (NOCONJ) THEN
|
||||
TEMP = ONE/A(K,K)
|
||||
ELSE
|
||||
TEMP = ONE/CONJG(A(K,K))
|
||||
END IF
|
||||
DO 290 I = 1,M
|
||||
B(I,K) = TEMP*B(I,K)
|
||||
290 CONTINUE
|
||||
END IF
|
||||
DO 310 J = 1,K - 1
|
||||
IF (A(J,K).NE.ZERO) THEN
|
||||
IF (NOCONJ) THEN
|
||||
TEMP = A(J,K)
|
||||
ELSE
|
||||
TEMP = CONJG(A(J,K))
|
||||
END IF
|
||||
DO 300 I = 1,M
|
||||
B(I,J) = B(I,J) - TEMP*B(I,K)
|
||||
300 CONTINUE
|
||||
END IF
|
||||
310 CONTINUE
|
||||
IF (ALPHA.NE.ONE) THEN
|
||||
DO 320 I = 1,M
|
||||
B(I,K) = ALPHA*B(I,K)
|
||||
320 CONTINUE
|
||||
END IF
|
||||
330 CONTINUE
|
||||
ELSE
|
||||
DO 380 K = 1,N
|
||||
IF (NOUNIT) THEN
|
||||
IF (NOCONJ) THEN
|
||||
TEMP = ONE/A(K,K)
|
||||
ELSE
|
||||
TEMP = ONE/CONJG(A(K,K))
|
||||
END IF
|
||||
DO 340 I = 1,M
|
||||
B(I,K) = TEMP*B(I,K)
|
||||
340 CONTINUE
|
||||
END IF
|
||||
DO 360 J = K + 1,N
|
||||
IF (A(J,K).NE.ZERO) THEN
|
||||
IF (NOCONJ) THEN
|
||||
TEMP = A(J,K)
|
||||
ELSE
|
||||
TEMP = CONJG(A(J,K))
|
||||
END IF
|
||||
DO 350 I = 1,M
|
||||
B(I,J) = B(I,J) - TEMP*B(I,K)
|
||||
350 CONTINUE
|
||||
END IF
|
||||
360 CONTINUE
|
||||
IF (ALPHA.NE.ONE) THEN
|
||||
DO 370 I = 1,M
|
||||
B(I,K) = ALPHA*B(I,K)
|
||||
370 CONTINUE
|
||||
END IF
|
||||
380 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CTRSM .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,375 +0,0 @@
|
|||
*> \brief \b CTRSV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,LDA,N
|
||||
* CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CTRSV solves one of the systems of equations
|
||||
*>
|
||||
*> A*x = b, or A**T*x = b, or A**H*x = b,
|
||||
*>
|
||||
*> where b and x are n element vectors and A is an n by n unit, or
|
||||
*> non-unit, upper or lower triangular matrix.
|
||||
*>
|
||||
*> No test for singularity or near-singularity is included in this
|
||||
*> routine. Such tests must be performed before calling this routine.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the matrix is an upper or
|
||||
*> lower triangular matrix as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the equations to be solved as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' A*x = b.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' A**T*x = b.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' A**H*x = b.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIAG
|
||||
*> \verbatim
|
||||
*> DIAG is CHARACTER*1
|
||||
*> On entry, DIAG specifies whether or not A is unit
|
||||
*> triangular as follows:
|
||||
*>
|
||||
*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*>
|
||||
*> DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
*> triangular.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array of DIMENSION ( LDA, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
*> upper triangular part of the array A must contain the upper
|
||||
*> triangular matrix and the strictly lower triangular part of
|
||||
*> A is not referenced.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
*> lower triangular part of the array A must contain the lower
|
||||
*> triangular matrix and the strictly upper triangular part of
|
||||
*> A is not referenced.
|
||||
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
*> A are not referenced either, but are assumed to be unity.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, n ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element right-hand side vector b. On exit, X is overwritten
|
||||
*> with the solution vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,LDA,N
|
||||
CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP
|
||||
INTEGER I,INFO,IX,J,JX,KX
|
||||
LOGICAL NOCONJ,NOUNIT
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG,MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 2
|
||||
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (LDA.LT.MAX(1,N)) THEN
|
||||
INFO = 6
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 8
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('CTRSV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (N.EQ.0) RETURN
|
||||
*
|
||||
NOCONJ = LSAME(TRANS,'T')
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
*
|
||||
* Set up the start point in X if the increment is not unity. This
|
||||
* will be ( N - 1 )*INCX too small for descending loops.
|
||||
*
|
||||
IF (INCX.LE.0) THEN
|
||||
KX = 1 - (N-1)*INCX
|
||||
ELSE IF (INCX.NE.1) THEN
|
||||
KX = 1
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form x := inv( A )*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = N,1,-1
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
IF (NOUNIT) X(J) = X(J)/A(J,J)
|
||||
TEMP = X(J)
|
||||
DO 10 I = J - 1,1,-1
|
||||
X(I) = X(I) - TEMP*A(I,J)
|
||||
10 CONTINUE
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX + (N-1)*INCX
|
||||
DO 40 J = N,1,-1
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
IF (NOUNIT) X(JX) = X(JX)/A(J,J)
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
DO 30 I = J - 1,1,-1
|
||||
IX = IX - INCX
|
||||
X(IX) = X(IX) - TEMP*A(I,J)
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JX = JX - INCX
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 60 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
IF (NOUNIT) X(J) = X(J)/A(J,J)
|
||||
TEMP = X(J)
|
||||
DO 50 I = J + 1,N
|
||||
X(I) = X(I) - TEMP*A(I,J)
|
||||
50 CONTINUE
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 80 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
IF (NOUNIT) X(JX) = X(JX)/A(J,J)
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
DO 70 I = J + 1,N
|
||||
IX = IX + INCX
|
||||
X(IX) = X(IX) - TEMP*A(I,J)
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form x := inv( A**T )*x or x := inv( A**H )*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 110 J = 1,N
|
||||
TEMP = X(J)
|
||||
IF (NOCONJ) THEN
|
||||
DO 90 I = 1,J - 1
|
||||
TEMP = TEMP - A(I,J)*X(I)
|
||||
90 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/A(J,J)
|
||||
ELSE
|
||||
DO 100 I = 1,J - 1
|
||||
TEMP = TEMP - CONJG(A(I,J))*X(I)
|
||||
100 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/CONJG(A(J,J))
|
||||
END IF
|
||||
X(J) = TEMP
|
||||
110 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 140 J = 1,N
|
||||
IX = KX
|
||||
TEMP = X(JX)
|
||||
IF (NOCONJ) THEN
|
||||
DO 120 I = 1,J - 1
|
||||
TEMP = TEMP - A(I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
120 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/A(J,J)
|
||||
ELSE
|
||||
DO 130 I = 1,J - 1
|
||||
TEMP = TEMP - CONJG(A(I,J))*X(IX)
|
||||
IX = IX + INCX
|
||||
130 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/CONJG(A(J,J))
|
||||
END IF
|
||||
X(JX) = TEMP
|
||||
JX = JX + INCX
|
||||
140 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 170 J = N,1,-1
|
||||
TEMP = X(J)
|
||||
IF (NOCONJ) THEN
|
||||
DO 150 I = N,J + 1,-1
|
||||
TEMP = TEMP - A(I,J)*X(I)
|
||||
150 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/A(J,J)
|
||||
ELSE
|
||||
DO 160 I = N,J + 1,-1
|
||||
TEMP = TEMP - CONJG(A(I,J))*X(I)
|
||||
160 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/CONJG(A(J,J))
|
||||
END IF
|
||||
X(J) = TEMP
|
||||
170 CONTINUE
|
||||
ELSE
|
||||
KX = KX + (N-1)*INCX
|
||||
JX = KX
|
||||
DO 200 J = N,1,-1
|
||||
IX = KX
|
||||
TEMP = X(JX)
|
||||
IF (NOCONJ) THEN
|
||||
DO 180 I = N,J + 1,-1
|
||||
TEMP = TEMP - A(I,J)*X(IX)
|
||||
IX = IX - INCX
|
||||
180 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/A(J,J)
|
||||
ELSE
|
||||
DO 190 I = N,J + 1,-1
|
||||
TEMP = TEMP - CONJG(A(I,J))*X(IX)
|
||||
IX = IX - INCX
|
||||
190 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/CONJG(A(J,J))
|
||||
END IF
|
||||
X(JX) = TEMP
|
||||
JX = JX - INCX
|
||||
200 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CTRSV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,111 +0,0 @@
|
|||
*> \brief \b DASUM
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION DX(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DASUM takes the sum of the absolute values.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 3/93 to return if incx .le. 0.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DX(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION DTEMP
|
||||
INTEGER I,M,MP1,NINCX
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DABS,MOD
|
||||
* ..
|
||||
DASUM = 0.0d0
|
||||
DTEMP = 0.0d0
|
||||
IF (N.LE.0 .OR. INCX.LE.0) RETURN
|
||||
IF (INCX.EQ.1) THEN
|
||||
* code for increment equal to 1
|
||||
*
|
||||
*
|
||||
* clean-up loop
|
||||
*
|
||||
M = MOD(N,6)
|
||||
IF (M.NE.0) THEN
|
||||
DO I = 1,M
|
||||
DTEMP = DTEMP + DABS(DX(I))
|
||||
END DO
|
||||
IF (N.LT.6) THEN
|
||||
DASUM = DTEMP
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
MP1 = M + 1
|
||||
DO I = MP1,N,6
|
||||
DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I+1)) +
|
||||
$ DABS(DX(I+2)) + DABS(DX(I+3)) +
|
||||
$ DABS(DX(I+4)) + DABS(DX(I+5))
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for increment not equal to 1
|
||||
*
|
||||
NINCX = N*INCX
|
||||
DO I = 1,NINCX,INCX
|
||||
DTEMP = DTEMP + DABS(DX(I))
|
||||
END DO
|
||||
END IF
|
||||
DASUM = DTEMP
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,115 +0,0 @@
|
|||
*> \brief \b DAXPY
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION DA
|
||||
* INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION DX(*),DY(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DAXPY constant times a vector plus a vector.
|
||||
*> uses unrolled loops for increments equal to one.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION DA
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DX(*),DY(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I,IX,IY,M,MP1
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD
|
||||
* ..
|
||||
IF (N.LE.0) RETURN
|
||||
IF (DA.EQ.0.0d0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
*
|
||||
* clean-up loop
|
||||
*
|
||||
M = MOD(N,4)
|
||||
IF (M.NE.0) THEN
|
||||
DO I = 1,M
|
||||
DY(I) = DY(I) + DA*DX(I)
|
||||
END DO
|
||||
END IF
|
||||
IF (N.LT.4) RETURN
|
||||
MP1 = M + 1
|
||||
DO I = MP1,N,4
|
||||
DY(I) = DY(I) + DA*DX(I)
|
||||
DY(I+1) = DY(I+1) + DA*DX(I+1)
|
||||
DY(I+2) = DY(I+2) + DA*DX(I+2)
|
||||
DY(I+3) = DY(I+3) + DA*DX(I+3)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments
|
||||
* not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
DY(IY) = DY(IY) + DA*DX(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,58 +0,0 @@
|
|||
*> \brief \b DCABS1
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* DOUBLE PRECISION FUNCTION DCABS1(Z)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX*16 Z
|
||||
* ..
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DCABS1 computes absolute value of a double complex number
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level1
|
||||
*
|
||||
* =====================================================================
|
||||
DOUBLE PRECISION FUNCTION DCABS1(Z)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX*16 Z
|
||||
* ..
|
||||
* ..
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS,DBLE,DIMAG
|
||||
*
|
||||
DCABS1 = ABS(DBLE(Z)) + ABS(DIMAG(Z))
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,115 +0,0 @@
|
|||
*> \brief \b DCOPY
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DCOPY(N,DX,INCX,DY,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION DX(*),DY(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DCOPY copies a vector, x, to a vector, y.
|
||||
*> uses unrolled loops for increments equal to one.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DCOPY(N,DX,INCX,DY,INCY)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DX(*),DY(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I,IX,IY,M,MP1
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD
|
||||
* ..
|
||||
IF (N.LE.0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
*
|
||||
* clean-up loop
|
||||
*
|
||||
M = MOD(N,7)
|
||||
IF (M.NE.0) THEN
|
||||
DO I = 1,M
|
||||
DY(I) = DX(I)
|
||||
END DO
|
||||
IF (N.LT.7) RETURN
|
||||
END IF
|
||||
MP1 = M + 1
|
||||
DO I = MP1,N,7
|
||||
DY(I) = DX(I)
|
||||
DY(I+1) = DX(I+1)
|
||||
DY(I+2) = DX(I+2)
|
||||
DY(I+3) = DX(I+3)
|
||||
DY(I+4) = DX(I+4)
|
||||
DY(I+5) = DX(I+5)
|
||||
DY(I+6) = DX(I+6)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments
|
||||
* not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
DY(IY) = DX(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,117 +0,0 @@
|
|||
*> \brief \b DDOT
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION DX(*),DY(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DDOT forms the dot product of two vectors.
|
||||
*> uses unrolled loops for increments equal to one.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DX(*),DY(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION DTEMP
|
||||
INTEGER I,IX,IY,M,MP1
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD
|
||||
* ..
|
||||
DDOT = 0.0d0
|
||||
DTEMP = 0.0d0
|
||||
IF (N.LE.0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
*
|
||||
* clean-up loop
|
||||
*
|
||||
M = MOD(N,5)
|
||||
IF (M.NE.0) THEN
|
||||
DO I = 1,M
|
||||
DTEMP = DTEMP + DX(I)*DY(I)
|
||||
END DO
|
||||
IF (N.LT.5) THEN
|
||||
DDOT=DTEMP
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
MP1 = M + 1
|
||||
DO I = MP1,N,5
|
||||
DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) +
|
||||
$ DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments
|
||||
* not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
DTEMP = DTEMP + DX(IX)*DY(IY)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
DDOT = DTEMP
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,374 +0,0 @@
|
|||
*> \brief \b DGBMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION ALPHA,BETA
|
||||
* INTEGER INCX,INCY,KL,KU,LDA,M,N
|
||||
* CHARACTER TRANS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DGBMV performs one of the matrix-vector operations
|
||||
*>
|
||||
*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y,
|
||||
*>
|
||||
*> where alpha and beta are scalars, x and y are vectors and A is an
|
||||
*> m by n band matrix, with kl sub-diagonals and ku super-diagonals.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the operation to be performed as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of the matrix A.
|
||||
*> M must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KL
|
||||
*> \verbatim
|
||||
*> KL is INTEGER
|
||||
*> On entry, KL specifies the number of sub-diagonals of the
|
||||
*> matrix A. KL must satisfy 0 .le. KL.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KU
|
||||
*> \verbatim
|
||||
*> KU is INTEGER
|
||||
*> On entry, KU specifies the number of super-diagonals of the
|
||||
*> matrix A. KU must satisfy 0 .le. KU.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is DOUBLE PRECISION.
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
*> Before entry, the leading ( kl + ku + 1 ) by n part of the
|
||||
*> array A must contain the matrix of coefficients, supplied
|
||||
*> column by column, with the leading diagonal of the matrix in
|
||||
*> row ( ku + 1 ) of the array, the first super-diagonal
|
||||
*> starting at position 2 in row ku, the first sub-diagonal
|
||||
*> starting at position 1 in row ( ku + 2 ), and so on.
|
||||
*> Elements in the array A that do not correspond to elements
|
||||
*> in the band matrix (such as the top left ku by ku triangle)
|
||||
*> are not referenced.
|
||||
*> The following program segment will transfer a band matrix
|
||||
*> from conventional full matrix storage to band storage:
|
||||
*>
|
||||
*> DO 20, J = 1, N
|
||||
*> K = KU + 1 - J
|
||||
*> DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL )
|
||||
*> A( K + I, J ) = matrix( I, J )
|
||||
*> 10 CONTINUE
|
||||
*> 20 CONTINUE
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> ( kl + ku + 1 ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION array of DIMENSION at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
|
||||
*> and at least
|
||||
*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
|
||||
*> Before entry, the incremented array X must contain the
|
||||
*> vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is DOUBLE PRECISION.
|
||||
*> On entry, BETA specifies the scalar beta. When BETA is
|
||||
*> supplied as zero then Y need not be set on input.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] Y
|
||||
*> \verbatim
|
||||
*> Y is DOUBLE PRECISION array of DIMENSION at least
|
||||
*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
|
||||
*> and at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
|
||||
*> Before entry, the incremented array Y must contain the
|
||||
*> vector y. On exit, Y is overwritten by the updated vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA,BETA
|
||||
INTEGER INCX,INCY,KL,KU,LDA,M,N
|
||||
CHARACTER TRANS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,K,KUP1,KX,KY,LENX,LENY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX,MIN
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (KL.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (KU.LT.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (LDA.LT. (KL+KU+1)) THEN
|
||||
INFO = 8
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 10
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 13
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DGBMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
|
||||
+ ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* Set LENX and LENY, the lengths of the vectors x and y, and set
|
||||
* up the start points in X and Y.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
LENX = N
|
||||
LENY = M
|
||||
ELSE
|
||||
LENX = M
|
||||
LENY = N
|
||||
END IF
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (LENX-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (LENY-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through the band part of A.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,LENY
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,LENY
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,LENY
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,LENY
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
KUP1 = KU + 1
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form y := alpha*A*x + y.
|
||||
*
|
||||
JX = KX
|
||||
IF (INCY.EQ.1) THEN
|
||||
DO 60 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
K = KUP1 - J
|
||||
DO 50 I = MAX(1,J-KU),MIN(M,J+KL)
|
||||
Y(I) = Y(I) + TEMP*A(K+I,J)
|
||||
50 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
IY = KY
|
||||
K = KUP1 - J
|
||||
DO 70 I = MAX(1,J-KU),MIN(M,J+KL)
|
||||
Y(IY) = Y(IY) + TEMP*A(K+I,J)
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
IF (J.GT.KU) KY = KY + INCY
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y := alpha*A**T*x + y.
|
||||
*
|
||||
JY = KY
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP = ZERO
|
||||
K = KUP1 - J
|
||||
DO 90 I = MAX(1,J-KU),MIN(M,J+KL)
|
||||
TEMP = TEMP + A(K+I,J)*X(I)
|
||||
90 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP
|
||||
JY = JY + INCY
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
DO 120 J = 1,N
|
||||
TEMP = ZERO
|
||||
IX = KX
|
||||
K = KUP1 - J
|
||||
DO 110 I = MAX(1,J-KU),MIN(M,J+KL)
|
||||
TEMP = TEMP + A(K+I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
110 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP
|
||||
JY = JY + INCY
|
||||
IF (J.GT.KU) KX = KX + INCX
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DGBMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,388 +0,0 @@
|
|||
*> \brief \b DGEMM
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION ALPHA,BETA
|
||||
* INTEGER K,LDA,LDB,LDC,M,N
|
||||
* CHARACTER TRANSA,TRANSB
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DGEMM performs one of the matrix-matrix operations
|
||||
*>
|
||||
*> C := alpha*op( A )*op( B ) + beta*C,
|
||||
*>
|
||||
*> where op( X ) is one of
|
||||
*>
|
||||
*> op( X ) = X or op( X ) = X**T,
|
||||
*>
|
||||
*> alpha and beta are scalars, and A, B and C are matrices, with op( A )
|
||||
*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] TRANSA
|
||||
*> \verbatim
|
||||
*> TRANSA is CHARACTER*1
|
||||
*> On entry, TRANSA specifies the form of op( A ) to be used in
|
||||
*> the matrix multiplication as follows:
|
||||
*>
|
||||
*> TRANSA = 'N' or 'n', op( A ) = A.
|
||||
*>
|
||||
*> TRANSA = 'T' or 't', op( A ) = A**T.
|
||||
*>
|
||||
*> TRANSA = 'C' or 'c', op( A ) = A**T.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANSB
|
||||
*> \verbatim
|
||||
*> TRANSB is CHARACTER*1
|
||||
*> On entry, TRANSB specifies the form of op( B ) to be used in
|
||||
*> the matrix multiplication as follows:
|
||||
*>
|
||||
*> TRANSB = 'N' or 'n', op( B ) = B.
|
||||
*>
|
||||
*> TRANSB = 'T' or 't', op( B ) = B**T.
|
||||
*>
|
||||
*> TRANSB = 'C' or 'c', op( B ) = B**T.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of the matrix
|
||||
*> op( A ) and of the matrix C. M must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of the matrix
|
||||
*> op( B ) and the number of columns of the matrix C. N must be
|
||||
*> at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> On entry, K specifies the number of columns of the matrix
|
||||
*> op( A ) and the number of rows of the matrix op( B ). K must
|
||||
*> be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is DOUBLE PRECISION.
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
|
||||
*> k when TRANSA = 'N' or 'n', and is m otherwise.
|
||||
*> Before entry with TRANSA = 'N' or 'n', the leading m by k
|
||||
*> part of the array A must contain the matrix A, otherwise
|
||||
*> the leading k by m part of the array A must contain the
|
||||
*> matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. When TRANSA = 'N' or 'n' then
|
||||
*> LDA must be at least max( 1, m ), otherwise LDA must be at
|
||||
*> least max( 1, k ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> B is DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
|
||||
*> n when TRANSB = 'N' or 'n', and is k otherwise.
|
||||
*> Before entry with TRANSB = 'N' or 'n', the leading k by n
|
||||
*> part of the array B must contain the matrix B, otherwise
|
||||
*> the leading n by k part of the array B must contain the
|
||||
*> matrix B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> On entry, LDB specifies the first dimension of B as declared
|
||||
*> in the calling (sub) program. When TRANSB = 'N' or 'n' then
|
||||
*> LDB must be at least max( 1, k ), otherwise LDB must be at
|
||||
*> least max( 1, n ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is DOUBLE PRECISION.
|
||||
*> On entry, BETA specifies the scalar beta. When BETA is
|
||||
*> supplied as zero then C need not be set on input.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is DOUBLE PRECISION array of DIMENSION ( LDC, n ).
|
||||
*> Before entry, the leading m by n part of the array C must
|
||||
*> contain the matrix C, except when beta is zero, in which
|
||||
*> case C need not be set on entry.
|
||||
*> On exit, the array C is overwritten by the m by n matrix
|
||||
*> ( alpha*op( A )*op( B ) + beta*C ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> On entry, LDC specifies the first dimension of C as declared
|
||||
*> in the calling (sub) program. LDC must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level3
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 3 Blas routine.
|
||||
*>
|
||||
*> -- Written on 8-February-1989.
|
||||
*> Jack Dongarra, Argonne National Laboratory.
|
||||
*> Iain Duff, AERE Harwell.
|
||||
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
*> Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* -- Reference BLAS level3 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA,BETA
|
||||
INTEGER K,LDA,LDB,LDC,M,N
|
||||
CHARACTER TRANSA,TRANSB
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB
|
||||
LOGICAL NOTA,NOTB
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
*
|
||||
* Set NOTA and NOTB as true if A and B respectively are not
|
||||
* transposed and set NROWA, NCOLA and NROWB as the number of rows
|
||||
* and columns of A and the number of rows of B respectively.
|
||||
*
|
||||
NOTA = LSAME(TRANSA,'N')
|
||||
NOTB = LSAME(TRANSB,'N')
|
||||
IF (NOTA) THEN
|
||||
NROWA = M
|
||||
NCOLA = K
|
||||
ELSE
|
||||
NROWA = K
|
||||
NCOLA = M
|
||||
END IF
|
||||
IF (NOTB) THEN
|
||||
NROWB = K
|
||||
ELSE
|
||||
NROWB = N
|
||||
END IF
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND.
|
||||
+ (.NOT.LSAME(TRANSA,'T'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND.
|
||||
+ (.NOT.LSAME(TRANSB,'T'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 8
|
||||
ELSE IF (LDB.LT.MAX(1,NROWB)) THEN
|
||||
INFO = 10
|
||||
ELSE IF (LDC.LT.MAX(1,M)) THEN
|
||||
INFO = 13
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DGEMM ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
|
||||
+ (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* And if alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
DO 30 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
END IF
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (NOTB) THEN
|
||||
IF (NOTA) THEN
|
||||
*
|
||||
* Form C := alpha*A*B + beta*C.
|
||||
*
|
||||
DO 90 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 50 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
50 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 60 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
60 CONTINUE
|
||||
END IF
|
||||
DO 80 L = 1,K
|
||||
IF (B(L,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(L,J)
|
||||
DO 70 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
70 CONTINUE
|
||||
END IF
|
||||
80 CONTINUE
|
||||
90 CONTINUE
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**T*B + beta*C
|
||||
*
|
||||
DO 120 J = 1,N
|
||||
DO 110 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 100 L = 1,K
|
||||
TEMP = TEMP + A(L,I)*B(L,J)
|
||||
100 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
110 CONTINUE
|
||||
120 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (NOTA) THEN
|
||||
*
|
||||
* Form C := alpha*A*B**T + beta*C
|
||||
*
|
||||
DO 170 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 130 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
130 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 140 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
140 CONTINUE
|
||||
END IF
|
||||
DO 160 L = 1,K
|
||||
IF (B(J,L).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(J,L)
|
||||
DO 150 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
150 CONTINUE
|
||||
END IF
|
||||
160 CONTINUE
|
||||
170 CONTINUE
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**T*B**T + beta*C
|
||||
*
|
||||
DO 200 J = 1,N
|
||||
DO 190 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 180 L = 1,K
|
||||
TEMP = TEMP + A(L,I)*B(J,L)
|
||||
180 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
190 CONTINUE
|
||||
200 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DGEMM .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,334 +0,0 @@
|
|||
*> \brief \b DGEMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION ALPHA,BETA
|
||||
* INTEGER INCX,INCY,LDA,M,N
|
||||
* CHARACTER TRANS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DGEMV performs one of the matrix-vector operations
|
||||
*>
|
||||
*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y,
|
||||
*>
|
||||
*> where alpha and beta are scalars, x and y are vectors and A is an
|
||||
*> m by n matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the operation to be performed as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of the matrix A.
|
||||
*> M must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is DOUBLE PRECISION.
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
*> Before entry, the leading m by n part of the array A must
|
||||
*> contain the matrix of coefficients.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION array of DIMENSION at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
|
||||
*> and at least
|
||||
*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
|
||||
*> Before entry, the incremented array X must contain the
|
||||
*> vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is DOUBLE PRECISION.
|
||||
*> On entry, BETA specifies the scalar beta. When BETA is
|
||||
*> supplied as zero then Y need not be set on input.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] Y
|
||||
*> \verbatim
|
||||
*> Y is DOUBLE PRECISION array of DIMENSION at least
|
||||
*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
|
||||
*> and at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
|
||||
*> Before entry with BETA non-zero, the incremented array Y
|
||||
*> must contain the vector y. On exit, Y is overwritten by the
|
||||
*> updated vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA,BETA
|
||||
INTEGER INCX,INCY,LDA,M,N
|
||||
CHARACTER TRANS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (LDA.LT.MAX(1,M)) THEN
|
||||
INFO = 6
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 8
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 11
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DGEMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
|
||||
+ ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* Set LENX and LENY, the lengths of the vectors x and y, and set
|
||||
* up the start points in X and Y.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
LENX = N
|
||||
LENY = M
|
||||
ELSE
|
||||
LENX = M
|
||||
LENY = N
|
||||
END IF
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (LENX-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (LENY-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,LENY
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,LENY
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,LENY
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,LENY
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form y := alpha*A*x + y.
|
||||
*
|
||||
JX = KX
|
||||
IF (INCY.EQ.1) THEN
|
||||
DO 60 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
DO 50 I = 1,M
|
||||
Y(I) = Y(I) + TEMP*A(I,J)
|
||||
50 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
IY = KY
|
||||
DO 70 I = 1,M
|
||||
Y(IY) = Y(IY) + TEMP*A(I,J)
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y := alpha*A**T*x + y.
|
||||
*
|
||||
JY = KY
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP = ZERO
|
||||
DO 90 I = 1,M
|
||||
TEMP = TEMP + A(I,J)*X(I)
|
||||
90 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP
|
||||
JY = JY + INCY
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
DO 120 J = 1,N
|
||||
TEMP = ZERO
|
||||
IX = KX
|
||||
DO 110 I = 1,M
|
||||
TEMP = TEMP + A(I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
110 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP
|
||||
JY = JY + INCY
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DGEMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,227 +0,0 @@
|
|||
*> \brief \b DGER
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION ALPHA
|
||||
* INTEGER INCX,INCY,LDA,M,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DGER performs the rank 1 operation
|
||||
*>
|
||||
*> A := alpha*x*y**T + A,
|
||||
*>
|
||||
*> where alpha is a scalar, x is an m element vector, y is an n element
|
||||
*> vector and A is an m by n matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of the matrix A.
|
||||
*> M must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is DOUBLE PRECISION.
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION array of dimension at least
|
||||
*> ( 1 + ( m - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the m
|
||||
*> element vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] Y
|
||||
*> \verbatim
|
||||
*> Y is DOUBLE PRECISION array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
*> Before entry, the incremented array Y must contain the n
|
||||
*> element vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
*> Before entry, the leading m by n part of the array A must
|
||||
*> contain the matrix of coefficients. On exit, A is
|
||||
*> overwritten by the updated matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA
|
||||
INTEGER INCX,INCY,LDA,M,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER (ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,IX,J,JY,KX
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (M.LT.0) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDA.LT.MAX(1,M)) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DGER ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
IF (INCY.GT.0) THEN
|
||||
JY = 1
|
||||
ELSE
|
||||
JY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = 1,N
|
||||
IF (Y(JY).NE.ZERO) THEN
|
||||
TEMP = ALPHA*Y(JY)
|
||||
DO 10 I = 1,M
|
||||
A(I,J) = A(I,J) + X(I)*TEMP
|
||||
10 CONTINUE
|
||||
END IF
|
||||
JY = JY + INCY
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (M-1)*INCX
|
||||
END IF
|
||||
DO 40 J = 1,N
|
||||
IF (Y(JY).NE.ZERO) THEN
|
||||
TEMP = ALPHA*Y(JY)
|
||||
IX = KX
|
||||
DO 30 I = 1,M
|
||||
A(I,J) = A(I,J) + X(IX)*TEMP
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JY = JY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DGER .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,112 +0,0 @@
|
|||
*> \brief \b DNRM2
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DNRM2 returns the euclidean norm of a vector via the function
|
||||
*> name, so that
|
||||
*>
|
||||
*> DNRM2 := sqrt( x'*x )
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> -- This version written on 25-October-1982.
|
||||
*> Modified on 14-October-1993 to inline the call to DLASSQ.
|
||||
*> Sven Hammarling, Nag Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ
|
||||
INTEGER IX
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS,SQRT
|
||||
* ..
|
||||
IF (N.LT.1 .OR. INCX.LT.1) THEN
|
||||
NORM = ZERO
|
||||
ELSE IF (N.EQ.1) THEN
|
||||
NORM = ABS(X(1))
|
||||
ELSE
|
||||
SCALE = ZERO
|
||||
SSQ = ONE
|
||||
* The following loop is equivalent to this call to the LAPACK
|
||||
* auxiliary routine:
|
||||
* CALL DLASSQ( N, X, INCX, SCALE, SSQ )
|
||||
*
|
||||
DO 10 IX = 1,1 + (N-1)*INCX,INCX
|
||||
IF (X(IX).NE.ZERO) THEN
|
||||
ABSXI = ABS(X(IX))
|
||||
IF (SCALE.LT.ABSXI) THEN
|
||||
SSQ = ONE + SSQ* (SCALE/ABSXI)**2
|
||||
SCALE = ABSXI
|
||||
ELSE
|
||||
SSQ = SSQ + (ABSXI/SCALE)**2
|
||||
END IF
|
||||
END IF
|
||||
10 CONTINUE
|
||||
NORM = SCALE*SQRT(SSQ)
|
||||
END IF
|
||||
*
|
||||
DNRM2 = NORM
|
||||
RETURN
|
||||
*
|
||||
* End of DNRM2.
|
||||
*
|
||||
END
|
||||
|
|
@ -1,101 +0,0 @@
|
|||
*> \brief \b DROT
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION C,S
|
||||
* INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION DX(*),DY(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DROT applies a plane rotation.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION C,S
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DX(*),DY(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION DTEMP
|
||||
INTEGER I,IX,IY
|
||||
* ..
|
||||
IF (N.LE.0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
DO I = 1,N
|
||||
DTEMP = C*DX(I) + S*DY(I)
|
||||
DY(I) = C*DY(I) - S*DX(I)
|
||||
DX(I) = DTEMP
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments not equal
|
||||
* to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
DTEMP = C*DX(IX) + S*DY(IY)
|
||||
DY(IY) = C*DY(IY) - S*DX(IX)
|
||||
DX(IX) = DTEMP
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,86 +0,0 @@
|
|||
*> \brief \b DROTG
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DROTG(DA,DB,C,S)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION C,DA,DB,S
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DROTG construct givens plane rotation.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DROTG(DA,DB,C,S)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION C,DA,DB,S
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION R,ROE,SCALE,Z
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DABS,DSIGN,DSQRT
|
||||
* ..
|
||||
ROE = DB
|
||||
IF (DABS(DA).GT.DABS(DB)) ROE = DA
|
||||
SCALE = DABS(DA) + DABS(DB)
|
||||
IF (SCALE.EQ.0.0d0) THEN
|
||||
C = 1.0d0
|
||||
S = 0.0d0
|
||||
R = 0.0d0
|
||||
Z = 0.0d0
|
||||
ELSE
|
||||
R = SCALE*DSQRT((DA/SCALE)**2+ (DB/SCALE)**2)
|
||||
R = DSIGN(1.0d0,ROE)*R
|
||||
C = DA/R
|
||||
S = DB/R
|
||||
Z = 1.0d0
|
||||
IF (DABS(DA).GT.DABS(DB)) Z = S
|
||||
IF (DABS(DB).GE.DABS(DA) .AND. C.NE.0.0d0) Z = 1.0d0/C
|
||||
END IF
|
||||
DA = R
|
||||
DB = Z
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,202 +0,0 @@
|
|||
*> \brief \b DROTM
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DROTM(N,DX,INCX,DY,INCY,DPARAM)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION DPARAM(5),DX(*),DY(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX
|
||||
*>
|
||||
*> (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN
|
||||
*> (DY**T)
|
||||
*>
|
||||
*> DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE
|
||||
*> LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY.
|
||||
*> WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
|
||||
*>
|
||||
*> DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0
|
||||
*>
|
||||
*> (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0)
|
||||
*> H=( ) ( ) ( ) ( )
|
||||
*> (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0).
|
||||
*> SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> number of elements in input vector(s)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] DX
|
||||
*> \verbatim
|
||||
*> DX is DOUBLE PRECISION array, dimension N
|
||||
*> double precision vector with N elements
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> storage spacing between elements of DX
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] DY
|
||||
*> \verbatim
|
||||
*> DY is DOUBLE PRECISION array, dimension N
|
||||
*> double precision vector with N elements
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> storage spacing between elements of DY
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] DPARAM
|
||||
*> \verbatim
|
||||
*> DPARAM is DOUBLE PRECISION array, dimension 5
|
||||
*> DPARAM(1)=DFLAG
|
||||
*> DPARAM(2)=DH11
|
||||
*> DPARAM(3)=DH21
|
||||
*> DPARAM(4)=DH12
|
||||
*> DPARAM(5)=DH22
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level1
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DROTM(N,DX,INCX,DY,INCY,DPARAM)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DPARAM(5),DX(*),DY(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,TWO,W,Z,ZERO
|
||||
INTEGER I,KX,KY,NSTEPS
|
||||
* ..
|
||||
* .. Data statements ..
|
||||
DATA ZERO,TWO/0.D0,2.D0/
|
||||
* ..
|
||||
*
|
||||
DFLAG = DPARAM(1)
|
||||
IF (N.LE.0 .OR. (DFLAG+TWO.EQ.ZERO)) RETURN
|
||||
IF (INCX.EQ.INCY.AND.INCX.GT.0) THEN
|
||||
*
|
||||
NSTEPS = N*INCX
|
||||
IF (DFLAG.LT.ZERO) THEN
|
||||
DH11 = DPARAM(2)
|
||||
DH12 = DPARAM(4)
|
||||
DH21 = DPARAM(3)
|
||||
DH22 = DPARAM(5)
|
||||
DO I = 1,NSTEPS,INCX
|
||||
W = DX(I)
|
||||
Z = DY(I)
|
||||
DX(I) = W*DH11 + Z*DH12
|
||||
DY(I) = W*DH21 + Z*DH22
|
||||
END DO
|
||||
ELSE IF (DFLAG.EQ.ZERO) THEN
|
||||
DH12 = DPARAM(4)
|
||||
DH21 = DPARAM(3)
|
||||
DO I = 1,NSTEPS,INCX
|
||||
W = DX(I)
|
||||
Z = DY(I)
|
||||
DX(I) = W + Z*DH12
|
||||
DY(I) = W*DH21 + Z
|
||||
END DO
|
||||
ELSE
|
||||
DH11 = DPARAM(2)
|
||||
DH22 = DPARAM(5)
|
||||
DO I = 1,NSTEPS,INCX
|
||||
W = DX(I)
|
||||
Z = DY(I)
|
||||
DX(I) = W*DH11 + Z
|
||||
DY(I) = -W + DH22*Z
|
||||
END DO
|
||||
END IF
|
||||
ELSE
|
||||
KX = 1
|
||||
KY = 1
|
||||
IF (INCX.LT.0) KX = 1 + (1-N)*INCX
|
||||
IF (INCY.LT.0) KY = 1 + (1-N)*INCY
|
||||
*
|
||||
IF (DFLAG.LT.ZERO) THEN
|
||||
DH11 = DPARAM(2)
|
||||
DH12 = DPARAM(4)
|
||||
DH21 = DPARAM(3)
|
||||
DH22 = DPARAM(5)
|
||||
DO I = 1,N
|
||||
W = DX(KX)
|
||||
Z = DY(KY)
|
||||
DX(KX) = W*DH11 + Z*DH12
|
||||
DY(KY) = W*DH21 + Z*DH22
|
||||
KX = KX + INCX
|
||||
KY = KY + INCY
|
||||
END DO
|
||||
ELSE IF (DFLAG.EQ.ZERO) THEN
|
||||
DH12 = DPARAM(4)
|
||||
DH21 = DPARAM(3)
|
||||
DO I = 1,N
|
||||
W = DX(KX)
|
||||
Z = DY(KY)
|
||||
DX(KX) = W + Z*DH12
|
||||
DY(KY) = W*DH21 + Z
|
||||
KX = KX + INCX
|
||||
KY = KY + INCY
|
||||
END DO
|
||||
ELSE
|
||||
DH11 = DPARAM(2)
|
||||
DH22 = DPARAM(5)
|
||||
DO I = 1,N
|
||||
W = DX(KX)
|
||||
Z = DY(KY)
|
||||
DX(KX) = W*DH11 + Z
|
||||
DY(KY) = -W + DH22*Z
|
||||
KX = KX + INCX
|
||||
KY = KY + INCY
|
||||
END DO
|
||||
END IF
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,251 +0,0 @@
|
|||
*> \brief \b DROTMG
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION DD1,DD2,DX1,DY1
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION DPARAM(5)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
|
||||
*> THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)*> DY2)**T.
|
||||
*> WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
|
||||
*>
|
||||
*> DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0
|
||||
*>
|
||||
*> (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0)
|
||||
*> H=( ) ( ) ( ) ( )
|
||||
*> (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0).
|
||||
*> LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22
|
||||
*> RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
|
||||
*> VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.)
|
||||
*>
|
||||
*> THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
|
||||
*> INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
|
||||
*> OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
|
||||
*>
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in,out] DD1
|
||||
*> \verbatim
|
||||
*> DD1 is DOUBLE PRECISION
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] DD2
|
||||
*> \verbatim
|
||||
*> DD2 is DOUBLE PRECISION
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] DX1
|
||||
*> \verbatim
|
||||
*> DX1 is DOUBLE PRECISION
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DY1
|
||||
*> \verbatim
|
||||
*> DY1 is DOUBLE PRECISION
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] DPARAM
|
||||
*> \verbatim
|
||||
*> DPARAM is DOUBLE PRECISION array, dimension 5
|
||||
*> DPARAM(1)=DFLAG
|
||||
*> DPARAM(2)=DH11
|
||||
*> DPARAM(3)=DH21
|
||||
*> DPARAM(4)=DH12
|
||||
*> DPARAM(5)=DH22
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level1
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION DD1,DD2,DX1,DY1
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DPARAM(5)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP,
|
||||
$ DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DABS
|
||||
* ..
|
||||
* .. Data statements ..
|
||||
*
|
||||
DATA ZERO,ONE,TWO/0.D0,1.D0,2.D0/
|
||||
DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/
|
||||
* ..
|
||||
|
||||
IF (DD1.LT.ZERO) THEN
|
||||
* GO ZERO-H-D-AND-DX1..
|
||||
DFLAG = -ONE
|
||||
DH11 = ZERO
|
||||
DH12 = ZERO
|
||||
DH21 = ZERO
|
||||
DH22 = ZERO
|
||||
*
|
||||
DD1 = ZERO
|
||||
DD2 = ZERO
|
||||
DX1 = ZERO
|
||||
ELSE
|
||||
* CASE-DD1-NONNEGATIVE
|
||||
DP2 = DD2*DY1
|
||||
IF (DP2.EQ.ZERO) THEN
|
||||
DFLAG = -TWO
|
||||
DPARAM(1) = DFLAG
|
||||
RETURN
|
||||
END IF
|
||||
* REGULAR-CASE..
|
||||
DP1 = DD1*DX1
|
||||
DQ2 = DP2*DY1
|
||||
DQ1 = DP1*DX1
|
||||
*
|
||||
IF (DABS(DQ1).GT.DABS(DQ2)) THEN
|
||||
DH21 = -DY1/DX1
|
||||
DH12 = DP2/DP1
|
||||
*
|
||||
DU = ONE - DH12*DH21
|
||||
*
|
||||
IF (DU.GT.ZERO) THEN
|
||||
DFLAG = ZERO
|
||||
DD1 = DD1/DU
|
||||
DD2 = DD2/DU
|
||||
DX1 = DX1*DU
|
||||
END IF
|
||||
ELSE
|
||||
|
||||
IF (DQ2.LT.ZERO) THEN
|
||||
* GO ZERO-H-D-AND-DX1..
|
||||
DFLAG = -ONE
|
||||
DH11 = ZERO
|
||||
DH12 = ZERO
|
||||
DH21 = ZERO
|
||||
DH22 = ZERO
|
||||
*
|
||||
DD1 = ZERO
|
||||
DD2 = ZERO
|
||||
DX1 = ZERO
|
||||
ELSE
|
||||
DFLAG = ONE
|
||||
DH11 = DP1/DP2
|
||||
DH22 = DX1/DY1
|
||||
DU = ONE + DH11*DH22
|
||||
DTEMP = DD2/DU
|
||||
DD2 = DD1/DU
|
||||
DD1 = DTEMP
|
||||
DX1 = DY1*DU
|
||||
END IF
|
||||
END IF
|
||||
|
||||
* PROCEDURE..SCALE-CHECK
|
||||
IF (DD1.NE.ZERO) THEN
|
||||
DO WHILE ((DD1.LE.RGAMSQ) .OR. (DD1.GE.GAMSQ))
|
||||
IF (DFLAG.EQ.ZERO) THEN
|
||||
DH11 = ONE
|
||||
DH22 = ONE
|
||||
DFLAG = -ONE
|
||||
ELSE
|
||||
DH21 = -ONE
|
||||
DH12 = ONE
|
||||
DFLAG = -ONE
|
||||
END IF
|
||||
IF (DD1.LE.RGAMSQ) THEN
|
||||
DD1 = DD1*GAM**2
|
||||
DX1 = DX1/GAM
|
||||
DH11 = DH11/GAM
|
||||
DH12 = DH12/GAM
|
||||
ELSE
|
||||
DD1 = DD1/GAM**2
|
||||
DX1 = DX1*GAM
|
||||
DH11 = DH11*GAM
|
||||
DH12 = DH12*GAM
|
||||
END IF
|
||||
ENDDO
|
||||
END IF
|
||||
|
||||
IF (DD2.NE.ZERO) THEN
|
||||
DO WHILE ( (DABS(DD2).LE.RGAMSQ) .OR. (DABS(DD2).GE.GAMSQ) )
|
||||
IF (DFLAG.EQ.ZERO) THEN
|
||||
DH11 = ONE
|
||||
DH22 = ONE
|
||||
DFLAG = -ONE
|
||||
ELSE
|
||||
DH21 = -ONE
|
||||
DH12 = ONE
|
||||
DFLAG = -ONE
|
||||
END IF
|
||||
IF (DABS(DD2).LE.RGAMSQ) THEN
|
||||
DD2 = DD2*GAM**2
|
||||
DH21 = DH21/GAM
|
||||
DH22 = DH22/GAM
|
||||
ELSE
|
||||
DD2 = DD2/GAM**2
|
||||
DH21 = DH21*GAM
|
||||
DH22 = DH22*GAM
|
||||
END IF
|
||||
END DO
|
||||
END IF
|
||||
|
||||
END IF
|
||||
|
||||
IF (DFLAG.LT.ZERO) THEN
|
||||
DPARAM(2) = DH11
|
||||
DPARAM(3) = DH21
|
||||
DPARAM(4) = DH12
|
||||
DPARAM(5) = DH22
|
||||
ELSE IF (DFLAG.EQ.ZERO) THEN
|
||||
DPARAM(3) = DH21
|
||||
DPARAM(4) = DH12
|
||||
ELSE
|
||||
DPARAM(2) = DH11
|
||||
DPARAM(5) = DH22
|
||||
END IF
|
||||
|
||||
DPARAM(1) = DFLAG
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,375 +0,0 @@
|
|||
*> \brief \b DSBMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION ALPHA,BETA
|
||||
* INTEGER INCX,INCY,K,LDA,N
|
||||
* CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DSBMV performs the matrix-vector operation
|
||||
*>
|
||||
*> y := alpha*A*x + beta*y,
|
||||
*>
|
||||
*> where alpha and beta are scalars, x and y are n element vectors and
|
||||
*> A is an n by n symmetric band matrix, with k super-diagonals.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the band matrix A is being supplied as
|
||||
*> follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' The upper triangular part of A is
|
||||
*> being supplied.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' The lower triangular part of A is
|
||||
*> being supplied.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> On entry, K specifies the number of super-diagonals of the
|
||||
*> matrix A. K must satisfy 0 .le. K.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is DOUBLE PRECISION.
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
|
||||
*> by n part of the array A must contain the upper triangular
|
||||
*> band part of the symmetric matrix, supplied column by
|
||||
*> column, with the leading diagonal of the matrix in row
|
||||
*> ( k + 1 ) of the array, the first super-diagonal starting at
|
||||
*> position 2 in row k, and so on. The top left k by k triangle
|
||||
*> of the array A is not referenced.
|
||||
*> The following program segment will transfer the upper
|
||||
*> triangular part of a symmetric band matrix from conventional
|
||||
*> full matrix storage to band storage:
|
||||
*>
|
||||
*> DO 20, J = 1, N
|
||||
*> M = K + 1 - J
|
||||
*> DO 10, I = MAX( 1, J - K ), J
|
||||
*> A( M + I, J ) = matrix( I, J )
|
||||
*> 10 CONTINUE
|
||||
*> 20 CONTINUE
|
||||
*>
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
|
||||
*> by n part of the array A must contain the lower triangular
|
||||
*> band part of the symmetric matrix, supplied column by
|
||||
*> column, with the leading diagonal of the matrix in row 1 of
|
||||
*> the array, the first sub-diagonal starting at position 1 in
|
||||
*> row 2, and so on. The bottom right k by k triangle of the
|
||||
*> array A is not referenced.
|
||||
*> The following program segment will transfer the lower
|
||||
*> triangular part of a symmetric band matrix from conventional
|
||||
*> full matrix storage to band storage:
|
||||
*>
|
||||
*> DO 20, J = 1, N
|
||||
*> M = 1 - J
|
||||
*> DO 10, I = J, MIN( N, J + K )
|
||||
*> A( M + I, J ) = matrix( I, J )
|
||||
*> 10 CONTINUE
|
||||
*> 20 CONTINUE
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> ( k + 1 ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION array of DIMENSION at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the
|
||||
*> vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is DOUBLE PRECISION.
|
||||
*> On entry, BETA specifies the scalar beta.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] Y
|
||||
*> \verbatim
|
||||
*> Y is DOUBLE PRECISION array of DIMENSION at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
*> Before entry, the incremented array Y must contain the
|
||||
*> vector y. On exit, Y is overwritten by the updated vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA,BETA
|
||||
INTEGER INCX,INCY,K,LDA,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,KPLUS1,KX,KY,L
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX,MIN
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (LDA.LT. (K+1)) THEN
|
||||
INFO = 6
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 8
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 11
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DSBMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* Set up the start points in X and Y.
|
||||
*
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (N-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of the array A
|
||||
* are accessed sequentially with one pass through A.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,N
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,N
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,N
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,N
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form y when upper triangle of A is stored.
|
||||
*
|
||||
KPLUS1 = K + 1
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 60 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
L = KPLUS1 - J
|
||||
DO 50 I = MAX(1,J-K),J - 1
|
||||
Y(I) = Y(I) + TEMP1*A(L+I,J)
|
||||
TEMP2 = TEMP2 + A(L+I,J)*X(I)
|
||||
50 CONTINUE
|
||||
Y(J) = Y(J) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 80 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
IX = KX
|
||||
IY = KY
|
||||
L = KPLUS1 - J
|
||||
DO 70 I = MAX(1,J-K),J - 1
|
||||
Y(IY) = Y(IY) + TEMP1*A(L+I,J)
|
||||
TEMP2 = TEMP2 + A(L+I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
Y(JY) = Y(JY) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
IF (J.GT.K) THEN
|
||||
KX = KX + INCX
|
||||
KY = KY + INCY
|
||||
END IF
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y when lower triangle of A is stored.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
Y(J) = Y(J) + TEMP1*A(1,J)
|
||||
L = 1 - J
|
||||
DO 90 I = J + 1,MIN(N,J+K)
|
||||
Y(I) = Y(I) + TEMP1*A(L+I,J)
|
||||
TEMP2 = TEMP2 + A(L+I,J)*X(I)
|
||||
90 CONTINUE
|
||||
Y(J) = Y(J) + ALPHA*TEMP2
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 120 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
Y(JY) = Y(JY) + TEMP1*A(1,J)
|
||||
L = 1 - J
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 110 I = J + 1,MIN(N,J+K)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
Y(IY) = Y(IY) + TEMP1*A(L+I,J)
|
||||
TEMP2 = TEMP2 + A(L+I,J)*X(IX)
|
||||
110 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSBMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,110 +0,0 @@
|
|||
*> \brief \b DSCAL
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DSCAL(N,DA,DX,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION DA
|
||||
* INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION DX(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DSCAL scales a vector by a constant.
|
||||
*> uses unrolled loops for increment equal to one.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 3/93 to return if incx .le. 0.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DSCAL(N,DA,DX,INCX)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION DA
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DX(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I,M,MP1,NINCX
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD
|
||||
* ..
|
||||
IF (N.LE.0 .OR. INCX.LE.0) RETURN
|
||||
IF (INCX.EQ.1) THEN
|
||||
*
|
||||
* code for increment equal to 1
|
||||
*
|
||||
*
|
||||
* clean-up loop
|
||||
*
|
||||
M = MOD(N,5)
|
||||
IF (M.NE.0) THEN
|
||||
DO I = 1,M
|
||||
DX(I) = DA*DX(I)
|
||||
END DO
|
||||
IF (N.LT.5) RETURN
|
||||
END IF
|
||||
MP1 = M + 1
|
||||
DO I = MP1,N,5
|
||||
DX(I) = DA*DX(I)
|
||||
DX(I+1) = DA*DX(I+1)
|
||||
DX(I+2) = DA*DX(I+2)
|
||||
DX(I+3) = DA*DX(I+3)
|
||||
DX(I+4) = DA*DX(I+4)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for increment not equal to 1
|
||||
*
|
||||
NINCX = N*INCX
|
||||
DO I = 1,NINCX,INCX
|
||||
DX(I) = DA*DX(I)
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,172 +0,0 @@
|
|||
*> \brief \b DSDOT
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* DOUBLE PRECISION FUNCTION DSDOT(N,SX,INCX,SY,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL SX(*),SY(*)
|
||||
* ..
|
||||
*
|
||||
* AUTHORS
|
||||
* =======
|
||||
* Lawson, C. L., (JPL), Hanson, R. J., (SNLA),
|
||||
* Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL)
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Compute the inner product of two vectors with extended
|
||||
*> precision accumulation and result.
|
||||
*>
|
||||
*> Returns D.P. dot product accumulated in D.P., for S.P. SX and SY
|
||||
*> DSDOT = sum for I = 0 to N-1 of SX(LX+I*INCX) * SY(LY+I*INCY),
|
||||
*> where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
|
||||
*> defined in a similar way using INCY.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> number of elements in input vector(s)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] SX
|
||||
*> \verbatim
|
||||
*> SX is REAL array, dimension(N)
|
||||
*> single precision vector with N elements
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> storage spacing between elements of SX
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] SY
|
||||
*> \verbatim
|
||||
*> SY is REAL array, dimension(N)
|
||||
*> single precision vector with N elements
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> storage spacing between elements of SY
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \result DSDOT
|
||||
*> \verbatim
|
||||
*> DSDOT is DOUBLE PRECISION
|
||||
*> DSDOT double precision dot product (zero if N.LE.0)
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*> \endverbatim
|
||||
*
|
||||
*> \par References:
|
||||
* ================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*>
|
||||
*> C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
|
||||
*> Krogh, Basic linear algebra subprograms for Fortran
|
||||
*> usage, Algorithm No. 539, Transactions on Mathematical
|
||||
*> Software 5, 3 (September 1979), pp. 308-323.
|
||||
*>
|
||||
*> REVISION HISTORY (YYMMDD)
|
||||
*>
|
||||
*> 791001 DATE WRITTEN
|
||||
*> 890831 Modified array declarations. (WRB)
|
||||
*> 890831 REVISION DATE from Version 3.2
|
||||
*> 891214 Prologue converted to Version 4.0 format. (BAB)
|
||||
*> 920310 Corrected definition of LX in DESCRIPTION. (WRB)
|
||||
*> 920501 Reformatted the REFERENCES section. (WRB)
|
||||
*> 070118 Reformat to LAPACK style (JL)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
DOUBLE PRECISION FUNCTION DSDOT(N,SX,INCX,SY,INCY)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL SX(*),SY(*)
|
||||
* ..
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
* Lawson, C. L., (JPL), Hanson, R. J., (SNLA),
|
||||
* Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL)
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I,KX,KY,NS
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DBLE
|
||||
* ..
|
||||
DSDOT = 0.0D0
|
||||
IF (N.LE.0) RETURN
|
||||
IF (INCX.EQ.INCY .AND. INCX.GT.0) THEN
|
||||
*
|
||||
* Code for equal, positive, non-unit increments.
|
||||
*
|
||||
NS = N*INCX
|
||||
DO I = 1,NS,INCX
|
||||
DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I))
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* Code for unequal or nonpositive increments.
|
||||
*
|
||||
KX = 1
|
||||
KY = 1
|
||||
IF (INCX.LT.0) KX = 1 + (1-N)*INCX
|
||||
IF (INCY.LT.0) KY = 1 + (1-N)*INCY
|
||||
DO I = 1,N
|
||||
DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY))
|
||||
KX = KX + INCX
|
||||
KY = KY + INCY
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,331 +0,0 @@
|
|||
*> \brief \b DSPMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION ALPHA,BETA
|
||||
* INTEGER INCX,INCY,N
|
||||
* CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION AP(*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DSPMV performs the matrix-vector operation
|
||||
*>
|
||||
*> y := alpha*A*x + beta*y,
|
||||
*>
|
||||
*> where alpha and beta are scalars, x and y are n element vectors and
|
||||
*> A is an n by n symmetric matrix, supplied in packed form.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the matrix A is supplied in the packed
|
||||
*> array AP as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' The upper triangular part of A is
|
||||
*> supplied in AP.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' The lower triangular part of A is
|
||||
*> supplied in AP.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is DOUBLE PRECISION.
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] AP
|
||||
*> \verbatim
|
||||
*> AP is DOUBLE PRECISION array of DIMENSION at least
|
||||
*> ( ( n*( n + 1 ) )/2 ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the array AP must
|
||||
*> contain the upper triangular part of the symmetric matrix
|
||||
*> packed sequentially, column by column, so that AP( 1 )
|
||||
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
|
||||
*> and a( 2, 2 ) respectively, and so on.
|
||||
*> Before entry with UPLO = 'L' or 'l', the array AP must
|
||||
*> contain the lower triangular part of the symmetric matrix
|
||||
*> packed sequentially, column by column, so that AP( 1 )
|
||||
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
|
||||
*> and a( 3, 1 ) respectively, and so on.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is DOUBLE PRECISION.
|
||||
*> On entry, BETA specifies the scalar beta. When BETA is
|
||||
*> supplied as zero then Y need not be set on input.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] Y
|
||||
*> \verbatim
|
||||
*> Y is DOUBLE PRECISION array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
*> Before entry, the incremented array Y must contain the n
|
||||
*> element vector y. On exit, Y is overwritten by the updated
|
||||
*> vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA,BETA
|
||||
INTEGER INCX,INCY,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION AP(*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 6
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DSPMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* Set up the start points in X and Y.
|
||||
*
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (N-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of the array AP
|
||||
* are accessed sequentially with one pass through AP.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,N
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,N
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,N
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,N
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
KK = 1
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form y when AP contains the upper triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 60 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
K = KK
|
||||
DO 50 I = 1,J - 1
|
||||
Y(I) = Y(I) + TEMP1*AP(K)
|
||||
TEMP2 = TEMP2 + AP(K)*X(I)
|
||||
K = K + 1
|
||||
50 CONTINUE
|
||||
Y(J) = Y(J) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2
|
||||
KK = KK + J
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 80 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
IX = KX
|
||||
IY = KY
|
||||
DO 70 K = KK,KK + J - 2
|
||||
Y(IY) = Y(IY) + TEMP1*AP(K)
|
||||
TEMP2 = TEMP2 + AP(K)*X(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
Y(JY) = Y(JY) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
KK = KK + J
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y when AP contains the lower triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
Y(J) = Y(J) + TEMP1*AP(KK)
|
||||
K = KK + 1
|
||||
DO 90 I = J + 1,N
|
||||
Y(I) = Y(I) + TEMP1*AP(K)
|
||||
TEMP2 = TEMP2 + AP(K)*X(I)
|
||||
K = K + 1
|
||||
90 CONTINUE
|
||||
Y(J) = Y(J) + ALPHA*TEMP2
|
||||
KK = KK + (N-J+1)
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 120 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
Y(JY) = Y(JY) + TEMP1*AP(KK)
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 110 K = KK + 1,KK + N - J
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
Y(IY) = Y(IY) + TEMP1*AP(K)
|
||||
TEMP2 = TEMP2 + AP(K)*X(IX)
|
||||
110 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
KK = KK + (N-J+1)
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSPMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,261 +0,0 @@
|
|||
*> \brief \b DSPR
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DSPR(UPLO,N,ALPHA,X,INCX,AP)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION ALPHA
|
||||
* INTEGER INCX,N
|
||||
* CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION AP(*),X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DSPR performs the symmetric rank 1 operation
|
||||
*>
|
||||
*> A := alpha*x*x**T + A,
|
||||
*>
|
||||
*> where alpha is a real scalar, x is an n element vector and A is an
|
||||
*> n by n symmetric matrix, supplied in packed form.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the matrix A is supplied in the packed
|
||||
*> array AP as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' The upper triangular part of A is
|
||||
*> supplied in AP.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' The lower triangular part of A is
|
||||
*> supplied in AP.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is DOUBLE PRECISION.
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] AP
|
||||
*> \verbatim
|
||||
*> AP is DOUBLE PRECISION array of DIMENSION at least
|
||||
*> ( ( n*( n + 1 ) )/2 ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the array AP must
|
||||
*> contain the upper triangular part of the symmetric matrix
|
||||
*> packed sequentially, column by column, so that AP( 1 )
|
||||
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
|
||||
*> and a( 2, 2 ) respectively, and so on. On exit, the array
|
||||
*> AP is overwritten by the upper triangular part of the
|
||||
*> updated matrix.
|
||||
*> Before entry with UPLO = 'L' or 'l', the array AP must
|
||||
*> contain the lower triangular part of the symmetric matrix
|
||||
*> packed sequentially, column by column, so that AP( 1 )
|
||||
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
|
||||
*> and a( 3, 1 ) respectively, and so on. On exit, the array
|
||||
*> AP is overwritten by the lower triangular part of the
|
||||
*> updated matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DSPR(UPLO,N,ALPHA,X,INCX,AP)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA
|
||||
INTEGER INCX,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION AP(*),X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER (ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,IX,J,JX,K,KK,KX
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 5
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DSPR ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
|
||||
*
|
||||
* Set the start point in X if the increment is not unity.
|
||||
*
|
||||
IF (INCX.LE.0) THEN
|
||||
KX = 1 - (N-1)*INCX
|
||||
ELSE IF (INCX.NE.1) THEN
|
||||
KX = 1
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of the array AP
|
||||
* are accessed sequentially with one pass through AP.
|
||||
*
|
||||
KK = 1
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form A when upper triangle is stored in AP.
|
||||
*
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(J)
|
||||
K = KK
|
||||
DO 10 I = 1,J
|
||||
AP(K) = AP(K) + X(I)*TEMP
|
||||
K = K + 1
|
||||
10 CONTINUE
|
||||
END IF
|
||||
KK = KK + J
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 40 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
IX = KX
|
||||
DO 30 K = KK,KK + J - 1
|
||||
AP(K) = AP(K) + X(IX)*TEMP
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
KK = KK + J
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form A when lower triangle is stored in AP.
|
||||
*
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 60 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(J)
|
||||
K = KK
|
||||
DO 50 I = J,N
|
||||
AP(K) = AP(K) + X(I)*TEMP
|
||||
K = K + 1
|
||||
50 CONTINUE
|
||||
END IF
|
||||
KK = KK + N - J + 1
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 80 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
IX = JX
|
||||
DO 70 K = KK,KK + N - J
|
||||
AP(K) = AP(K) + X(IX)*TEMP
|
||||
IX = IX + INCX
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
KK = KK + N - J + 1
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSPR .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,296 +0,0 @@
|
|||
*> \brief \b DSPR2
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION ALPHA
|
||||
* INTEGER INCX,INCY,N
|
||||
* CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION AP(*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DSPR2 performs the symmetric rank 2 operation
|
||||
*>
|
||||
*> A := alpha*x*y**T + alpha*y*x**T + A,
|
||||
*>
|
||||
*> where alpha is a scalar, x and y are n element vectors and A is an
|
||||
*> n by n symmetric matrix, supplied in packed form.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the matrix A is supplied in the packed
|
||||
*> array AP as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' The upper triangular part of A is
|
||||
*> supplied in AP.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' The lower triangular part of A is
|
||||
*> supplied in AP.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is DOUBLE PRECISION.
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] Y
|
||||
*> \verbatim
|
||||
*> Y is DOUBLE PRECISION array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
*> Before entry, the incremented array Y must contain the n
|
||||
*> element vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] AP
|
||||
*> \verbatim
|
||||
*> AP is DOUBLE PRECISION array of DIMENSION at least
|
||||
*> ( ( n*( n + 1 ) )/2 ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the array AP must
|
||||
*> contain the upper triangular part of the symmetric matrix
|
||||
*> packed sequentially, column by column, so that AP( 1 )
|
||||
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
|
||||
*> and a( 2, 2 ) respectively, and so on. On exit, the array
|
||||
*> AP is overwritten by the upper triangular part of the
|
||||
*> updated matrix.
|
||||
*> Before entry with UPLO = 'L' or 'l', the array AP must
|
||||
*> contain the lower triangular part of the symmetric matrix
|
||||
*> packed sequentially, column by column, so that AP( 1 )
|
||||
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
|
||||
*> and a( 3, 1 ) respectively, and so on. On exit, the array
|
||||
*> AP is overwritten by the lower triangular part of the
|
||||
*> updated matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA
|
||||
INTEGER INCX,INCY,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION AP(*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER (ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 7
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DSPR2 ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
|
||||
*
|
||||
* Set up the start points in X and Y if the increments are not both
|
||||
* unity.
|
||||
*
|
||||
IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (N-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
JX = KX
|
||||
JY = KY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of the array AP
|
||||
* are accessed sequentially with one pass through AP.
|
||||
*
|
||||
KK = 1
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form A when upper triangle is stored in AP.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 20 J = 1,N
|
||||
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*Y(J)
|
||||
TEMP2 = ALPHA*X(J)
|
||||
K = KK
|
||||
DO 10 I = 1,J
|
||||
AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
|
||||
K = K + 1
|
||||
10 CONTINUE
|
||||
END IF
|
||||
KK = KK + J
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*Y(JY)
|
||||
TEMP2 = ALPHA*X(JX)
|
||||
IX = KX
|
||||
IY = KY
|
||||
DO 30 K = KK,KK + J - 1
|
||||
AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
KK = KK + J
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form A when lower triangle is stored in AP.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 60 J = 1,N
|
||||
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*Y(J)
|
||||
TEMP2 = ALPHA*X(J)
|
||||
K = KK
|
||||
DO 50 I = J,N
|
||||
AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
|
||||
K = K + 1
|
||||
50 CONTINUE
|
||||
END IF
|
||||
KK = KK + N - J + 1
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*Y(JY)
|
||||
TEMP2 = ALPHA*X(JX)
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 70 K = KK,KK + N - J
|
||||
AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
KK = KK + N - J + 1
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSPR2 .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,122 +0,0 @@
|
|||
*> \brief \b DSWAP
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DSWAP(N,DX,INCX,DY,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION DX(*),DY(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> interchanges two vectors.
|
||||
*> uses unrolled loops for increments equal one.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DSWAP(N,DX,INCX,DY,INCY)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DX(*),DY(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION DTEMP
|
||||
INTEGER I,IX,IY,M,MP1
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD
|
||||
* ..
|
||||
IF (N.LE.0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
*
|
||||
* clean-up loop
|
||||
*
|
||||
M = MOD(N,3)
|
||||
IF (M.NE.0) THEN
|
||||
DO I = 1,M
|
||||
DTEMP = DX(I)
|
||||
DX(I) = DY(I)
|
||||
DY(I) = DTEMP
|
||||
END DO
|
||||
IF (N.LT.3) RETURN
|
||||
END IF
|
||||
MP1 = M + 1
|
||||
DO I = MP1,N,3
|
||||
DTEMP = DX(I)
|
||||
DX(I) = DY(I)
|
||||
DY(I) = DTEMP
|
||||
DTEMP = DX(I+1)
|
||||
DX(I+1) = DY(I+1)
|
||||
DY(I+1) = DTEMP
|
||||
DTEMP = DX(I+2)
|
||||
DX(I+2) = DY(I+2)
|
||||
DY(I+2) = DTEMP
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments not equal
|
||||
* to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
DTEMP = DX(IX)
|
||||
DX(IX) = DY(IY)
|
||||
DY(IY) = DTEMP
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,367 +0,0 @@
|
|||
*> \brief \b DSYMM
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION ALPHA,BETA
|
||||
* INTEGER LDA,LDB,LDC,M,N
|
||||
* CHARACTER SIDE,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DSYMM performs one of the matrix-matrix operations
|
||||
*>
|
||||
*> C := alpha*A*B + beta*C,
|
||||
*>
|
||||
*> or
|
||||
*>
|
||||
*> C := alpha*B*A + beta*C,
|
||||
*>
|
||||
*> where alpha and beta are scalars, A is a symmetric matrix and B and
|
||||
*> C are m by n matrices.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> On entry, SIDE specifies whether the symmetric matrix A
|
||||
*> appears on the left or right in the operation as follows:
|
||||
*>
|
||||
*> SIDE = 'L' or 'l' C := alpha*A*B + beta*C,
|
||||
*>
|
||||
*> SIDE = 'R' or 'r' C := alpha*B*A + beta*C,
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the symmetric matrix A is to be
|
||||
*> referenced as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' Only the upper triangular part of the
|
||||
*> symmetric matrix is to be referenced.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' Only the lower triangular part of the
|
||||
*> symmetric matrix is to be referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of the matrix C.
|
||||
*> M must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of the matrix C.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is DOUBLE PRECISION.
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
|
||||
*> m when SIDE = 'L' or 'l' and is n otherwise.
|
||||
*> Before entry with SIDE = 'L' or 'l', the m by m part of
|
||||
*> the array A must contain the symmetric matrix, such that
|
||||
*> when UPLO = 'U' or 'u', the leading m by m upper triangular
|
||||
*> part of the array A must contain the upper triangular part
|
||||
*> of the symmetric matrix and the strictly lower triangular
|
||||
*> part of A is not referenced, and when UPLO = 'L' or 'l',
|
||||
*> the leading m by m lower triangular part of the array A
|
||||
*> must contain the lower triangular part of the symmetric
|
||||
*> matrix and the strictly upper triangular part of A is not
|
||||
*> referenced.
|
||||
*> Before entry with SIDE = 'R' or 'r', the n by n part of
|
||||
*> the array A must contain the symmetric matrix, such that
|
||||
*> when UPLO = 'U' or 'u', the leading n by n upper triangular
|
||||
*> part of the array A must contain the upper triangular part
|
||||
*> of the symmetric matrix and the strictly lower triangular
|
||||
*> part of A is not referenced, and when UPLO = 'L' or 'l',
|
||||
*> the leading n by n lower triangular part of the array A
|
||||
*> must contain the lower triangular part of the symmetric
|
||||
*> matrix and the strictly upper triangular part of A is not
|
||||
*> referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. When SIDE = 'L' or 'l' then
|
||||
*> LDA must be at least max( 1, m ), otherwise LDA must be at
|
||||
*> least max( 1, n ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> B is DOUBLE PRECISION array of DIMENSION ( LDB, n ).
|
||||
*> Before entry, the leading m by n part of the array B must
|
||||
*> contain the matrix B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> On entry, LDB specifies the first dimension of B as declared
|
||||
*> in the calling (sub) program. LDB must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is DOUBLE PRECISION.
|
||||
*> On entry, BETA specifies the scalar beta. When BETA is
|
||||
*> supplied as zero then C need not be set on input.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is DOUBLE PRECISION array of DIMENSION ( LDC, n ).
|
||||
*> Before entry, the leading m by n part of the array C must
|
||||
*> contain the matrix C, except when beta is zero, in which
|
||||
*> case C need not be set on entry.
|
||||
*> On exit, the array C is overwritten by the m by n updated
|
||||
*> matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> On entry, LDC specifies the first dimension of C as declared
|
||||
*> in the calling (sub) program. LDC must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level3
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 3 Blas routine.
|
||||
*>
|
||||
*> -- Written on 8-February-1989.
|
||||
*> Jack Dongarra, Argonne National Laboratory.
|
||||
*> Iain Duff, AERE Harwell.
|
||||
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
*> Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* -- Reference BLAS level3 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA,BETA
|
||||
INTEGER LDA,LDB,LDC,M,N
|
||||
CHARACTER SIDE,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP1,TEMP2
|
||||
INTEGER I,INFO,J,K,NROWA
|
||||
LOGICAL UPPER
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
*
|
||||
* Set NROWA as the number of rows of A.
|
||||
*
|
||||
IF (LSAME(SIDE,'L')) THEN
|
||||
NROWA = M
|
||||
ELSE
|
||||
NROWA = N
|
||||
END IF
|
||||
UPPER = LSAME(UPLO,'U')
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.LSAME(SIDE,'L')) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDB.LT.MAX(1,M)) THEN
|
||||
INFO = 9
|
||||
ELSE IF (LDC.LT.MAX(1,M)) THEN
|
||||
INFO = 12
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DSYMM ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
|
||||
+ ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* And when alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
DO 30 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
END IF
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (LSAME(SIDE,'L')) THEN
|
||||
*
|
||||
* Form C := alpha*A*B + beta*C.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 70 J = 1,N
|
||||
DO 60 I = 1,M
|
||||
TEMP1 = ALPHA*B(I,J)
|
||||
TEMP2 = ZERO
|
||||
DO 50 K = 1,I - 1
|
||||
C(K,J) = C(K,J) + TEMP1*A(K,I)
|
||||
TEMP2 = TEMP2 + B(K,J)*A(K,I)
|
||||
50 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2
|
||||
ELSE
|
||||
C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) +
|
||||
+ ALPHA*TEMP2
|
||||
END IF
|
||||
60 CONTINUE
|
||||
70 CONTINUE
|
||||
ELSE
|
||||
DO 100 J = 1,N
|
||||
DO 90 I = M,1,-1
|
||||
TEMP1 = ALPHA*B(I,J)
|
||||
TEMP2 = ZERO
|
||||
DO 80 K = I + 1,M
|
||||
C(K,J) = C(K,J) + TEMP1*A(K,I)
|
||||
TEMP2 = TEMP2 + B(K,J)*A(K,I)
|
||||
80 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2
|
||||
ELSE
|
||||
C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) +
|
||||
+ ALPHA*TEMP2
|
||||
END IF
|
||||
90 CONTINUE
|
||||
100 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*B*A + beta*C.
|
||||
*
|
||||
DO 170 J = 1,N
|
||||
TEMP1 = ALPHA*A(J,J)
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 110 I = 1,M
|
||||
C(I,J) = TEMP1*B(I,J)
|
||||
110 CONTINUE
|
||||
ELSE
|
||||
DO 120 I = 1,M
|
||||
C(I,J) = BETA*C(I,J) + TEMP1*B(I,J)
|
||||
120 CONTINUE
|
||||
END IF
|
||||
DO 140 K = 1,J - 1
|
||||
IF (UPPER) THEN
|
||||
TEMP1 = ALPHA*A(K,J)
|
||||
ELSE
|
||||
TEMP1 = ALPHA*A(J,K)
|
||||
END IF
|
||||
DO 130 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP1*B(I,K)
|
||||
130 CONTINUE
|
||||
140 CONTINUE
|
||||
DO 160 K = J + 1,N
|
||||
IF (UPPER) THEN
|
||||
TEMP1 = ALPHA*A(J,K)
|
||||
ELSE
|
||||
TEMP1 = ALPHA*A(K,J)
|
||||
END IF
|
||||
DO 150 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP1*B(I,K)
|
||||
150 CONTINUE
|
||||
160 CONTINUE
|
||||
170 CONTINUE
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSYMM .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,333 +0,0 @@
|
|||
*> \brief \b DSYMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION ALPHA,BETA
|
||||
* INTEGER INCX,INCY,LDA,N
|
||||
* CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DSYMV performs the matrix-vector operation
|
||||
*>
|
||||
*> y := alpha*A*x + beta*y,
|
||||
*>
|
||||
*> where alpha and beta are scalars, x and y are n element vectors and
|
||||
*> A is an n by n symmetric matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the array A is to be referenced as
|
||||
*> follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' Only the upper triangular part of A
|
||||
*> is to be referenced.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' Only the lower triangular part of A
|
||||
*> is to be referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is DOUBLE PRECISION.
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
*> upper triangular part of the array A must contain the upper
|
||||
*> triangular part of the symmetric matrix and the strictly
|
||||
*> lower triangular part of A is not referenced.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
*> lower triangular part of the array A must contain the lower
|
||||
*> triangular part of the symmetric matrix and the strictly
|
||||
*> upper triangular part of A is not referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, n ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is DOUBLE PRECISION.
|
||||
*> On entry, BETA specifies the scalar beta. When BETA is
|
||||
*> supplied as zero then Y need not be set on input.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] Y
|
||||
*> \verbatim
|
||||
*> Y is DOUBLE PRECISION array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
*> Before entry, the incremented array Y must contain the n
|
||||
*> element vector y. On exit, Y is overwritten by the updated
|
||||
*> vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA,BETA
|
||||
INTEGER INCX,INCY,LDA,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (LDA.LT.MAX(1,N)) THEN
|
||||
INFO = 5
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 7
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 10
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DSYMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* Set up the start points in X and Y.
|
||||
*
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (N-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through the triangular part
|
||||
* of A.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,N
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,N
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,N
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,N
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form y when A is stored in upper triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 60 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
DO 50 I = 1,J - 1
|
||||
Y(I) = Y(I) + TEMP1*A(I,J)
|
||||
TEMP2 = TEMP2 + A(I,J)*X(I)
|
||||
50 CONTINUE
|
||||
Y(J) = Y(J) + TEMP1*A(J,J) + ALPHA*TEMP2
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 80 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
IX = KX
|
||||
IY = KY
|
||||
DO 70 I = 1,J - 1
|
||||
Y(IY) = Y(IY) + TEMP1*A(I,J)
|
||||
TEMP2 = TEMP2 + A(I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
Y(JY) = Y(JY) + TEMP1*A(J,J) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y when A is stored in lower triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
Y(J) = Y(J) + TEMP1*A(J,J)
|
||||
DO 90 I = J + 1,N
|
||||
Y(I) = Y(I) + TEMP1*A(I,J)
|
||||
TEMP2 = TEMP2 + A(I,J)*X(I)
|
||||
90 CONTINUE
|
||||
Y(J) = Y(J) + ALPHA*TEMP2
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 120 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
Y(JY) = Y(JY) + TEMP1*A(J,J)
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 110 I = J + 1,N
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
Y(IY) = Y(IY) + TEMP1*A(I,J)
|
||||
TEMP2 = TEMP2 + A(I,J)*X(IX)
|
||||
110 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSYMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,263 +0,0 @@
|
|||
*> \brief \b DSYR
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DSYR(UPLO,N,ALPHA,X,INCX,A,LDA)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION ALPHA
|
||||
* INTEGER INCX,LDA,N
|
||||
* CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DSYR performs the symmetric rank 1 operation
|
||||
*>
|
||||
*> A := alpha*x*x**T + A,
|
||||
*>
|
||||
*> where alpha is a real scalar, x is an n element vector and A is an
|
||||
*> n by n symmetric matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the array A is to be referenced as
|
||||
*> follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' Only the upper triangular part of A
|
||||
*> is to be referenced.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' Only the lower triangular part of A
|
||||
*> is to be referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is DOUBLE PRECISION.
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
*> upper triangular part of the array A must contain the upper
|
||||
*> triangular part of the symmetric matrix and the strictly
|
||||
*> lower triangular part of A is not referenced. On exit, the
|
||||
*> upper triangular part of the array A is overwritten by the
|
||||
*> upper triangular part of the updated matrix.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
*> lower triangular part of the array A must contain the lower
|
||||
*> triangular part of the symmetric matrix and the strictly
|
||||
*> upper triangular part of A is not referenced. On exit, the
|
||||
*> lower triangular part of the array A is overwritten by the
|
||||
*> lower triangular part of the updated matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, n ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DSYR(UPLO,N,ALPHA,X,INCX,A,LDA)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA
|
||||
INTEGER INCX,LDA,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER (ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,IX,J,JX,KX
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (LDA.LT.MAX(1,N)) THEN
|
||||
INFO = 7
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DSYR ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
|
||||
*
|
||||
* Set the start point in X if the increment is not unity.
|
||||
*
|
||||
IF (INCX.LE.0) THEN
|
||||
KX = 1 - (N-1)*INCX
|
||||
ELSE IF (INCX.NE.1) THEN
|
||||
KX = 1
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through the triangular part
|
||||
* of A.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form A when A is stored in upper triangle.
|
||||
*
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(J)
|
||||
DO 10 I = 1,J
|
||||
A(I,J) = A(I,J) + X(I)*TEMP
|
||||
10 CONTINUE
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 40 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
IX = KX
|
||||
DO 30 I = 1,J
|
||||
A(I,J) = A(I,J) + X(IX)*TEMP
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form A when A is stored in lower triangle.
|
||||
*
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 60 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(J)
|
||||
DO 50 I = J,N
|
||||
A(I,J) = A(I,J) + X(I)*TEMP
|
||||
50 CONTINUE
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 80 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
IX = JX
|
||||
DO 70 I = J,N
|
||||
A(I,J) = A(I,J) + X(IX)*TEMP
|
||||
IX = IX + INCX
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSYR .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,298 +0,0 @@
|
|||
*> \brief \b DSYR2
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION ALPHA
|
||||
* INTEGER INCX,INCY,LDA,N
|
||||
* CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DSYR2 performs the symmetric rank 2 operation
|
||||
*>
|
||||
*> A := alpha*x*y**T + alpha*y*x**T + A,
|
||||
*>
|
||||
*> where alpha is a scalar, x and y are n element vectors and A is an n
|
||||
*> by n symmetric matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the array A is to be referenced as
|
||||
*> follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' Only the upper triangular part of A
|
||||
*> is to be referenced.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' Only the lower triangular part of A
|
||||
*> is to be referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is DOUBLE PRECISION.
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] Y
|
||||
*> \verbatim
|
||||
*> Y is DOUBLE PRECISION array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
*> Before entry, the incremented array Y must contain the n
|
||||
*> element vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
*> upper triangular part of the array A must contain the upper
|
||||
*> triangular part of the symmetric matrix and the strictly
|
||||
*> lower triangular part of A is not referenced. On exit, the
|
||||
*> upper triangular part of the array A is overwritten by the
|
||||
*> upper triangular part of the updated matrix.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
*> lower triangular part of the array A must contain the lower
|
||||
*> triangular part of the symmetric matrix and the strictly
|
||||
*> upper triangular part of A is not referenced. On exit, the
|
||||
*> lower triangular part of the array A is overwritten by the
|
||||
*> lower triangular part of the updated matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, n ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA
|
||||
INTEGER INCX,INCY,LDA,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER (ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDA.LT.MAX(1,N)) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DSYR2 ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
|
||||
*
|
||||
* Set up the start points in X and Y if the increments are not both
|
||||
* unity.
|
||||
*
|
||||
IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (N-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
JX = KX
|
||||
JY = KY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through the triangular part
|
||||
* of A.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form A when A is stored in the upper triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 20 J = 1,N
|
||||
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*Y(J)
|
||||
TEMP2 = ALPHA*X(J)
|
||||
DO 10 I = 1,J
|
||||
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
|
||||
10 CONTINUE
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*Y(JY)
|
||||
TEMP2 = ALPHA*X(JX)
|
||||
IX = KX
|
||||
IY = KY
|
||||
DO 30 I = 1,J
|
||||
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form A when A is stored in the lower triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 60 J = 1,N
|
||||
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*Y(J)
|
||||
TEMP2 = ALPHA*X(J)
|
||||
DO 50 I = J,N
|
||||
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
|
||||
50 CONTINUE
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*Y(JY)
|
||||
TEMP2 = ALPHA*X(JX)
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 70 I = J,N
|
||||
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSYR2 .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,399 +0,0 @@
|
|||
*> \brief \b DSYR2K
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION ALPHA,BETA
|
||||
* INTEGER K,LDA,LDB,LDC,N
|
||||
* CHARACTER TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DSYR2K performs one of the symmetric rank 2k operations
|
||||
*>
|
||||
*> C := alpha*A*B**T + alpha*B*A**T + beta*C,
|
||||
*>
|
||||
*> or
|
||||
*>
|
||||
*> C := alpha*A**T*B + alpha*B**T*A + beta*C,
|
||||
*>
|
||||
*> where alpha and beta are scalars, C is an n by n symmetric matrix
|
||||
*> and A and B are n by k matrices in the first case and k by n
|
||||
*> matrices in the second case.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the array C is to be referenced as
|
||||
*> follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' Only the upper triangular part of C
|
||||
*> is to be referenced.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' Only the lower triangular part of C
|
||||
*> is to be referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the operation to be performed as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' C := alpha*A*B**T + alpha*B*A**T +
|
||||
*> beta*C.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' C := alpha*A**T*B + alpha*B**T*A +
|
||||
*> beta*C.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' C := alpha*A**T*B + alpha*B**T*A +
|
||||
*> beta*C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix C. N must be
|
||||
*> at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> On entry with TRANS = 'N' or 'n', K specifies the number
|
||||
*> of columns of the matrices A and B, and on entry with
|
||||
*> TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
|
||||
*> of rows of the matrices A and B. K must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is DOUBLE PRECISION.
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
|
||||
*> k when TRANS = 'N' or 'n', and is n otherwise.
|
||||
*> Before entry with TRANS = 'N' or 'n', the leading n by k
|
||||
*> part of the array A must contain the matrix A, otherwise
|
||||
*> the leading k by n part of the array A must contain the
|
||||
*> matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. When TRANS = 'N' or 'n'
|
||||
*> then LDA must be at least max( 1, n ), otherwise LDA must
|
||||
*> be at least max( 1, k ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> B is DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
|
||||
*> k when TRANS = 'N' or 'n', and is n otherwise.
|
||||
*> Before entry with TRANS = 'N' or 'n', the leading n by k
|
||||
*> part of the array B must contain the matrix B, otherwise
|
||||
*> the leading k by n part of the array B must contain the
|
||||
*> matrix B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> On entry, LDB specifies the first dimension of B as declared
|
||||
*> in the calling (sub) program. When TRANS = 'N' or 'n'
|
||||
*> then LDB must be at least max( 1, n ), otherwise LDB must
|
||||
*> be at least max( 1, k ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is DOUBLE PRECISION.
|
||||
*> On entry, BETA specifies the scalar beta.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is DOUBLE PRECISION array of DIMENSION ( LDC, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
*> upper triangular part of the array C must contain the upper
|
||||
*> triangular part of the symmetric matrix and the strictly
|
||||
*> lower triangular part of C is not referenced. On exit, the
|
||||
*> upper triangular part of the array C is overwritten by the
|
||||
*> upper triangular part of the updated matrix.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
*> lower triangular part of the array C must contain the lower
|
||||
*> triangular part of the symmetric matrix and the strictly
|
||||
*> upper triangular part of C is not referenced. On exit, the
|
||||
*> lower triangular part of the array C is overwritten by the
|
||||
*> lower triangular part of the updated matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> On entry, LDC specifies the first dimension of C as declared
|
||||
*> in the calling (sub) program. LDC must be at least
|
||||
*> max( 1, n ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level3
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 3 Blas routine.
|
||||
*>
|
||||
*>
|
||||
*> -- Written on 8-February-1989.
|
||||
*> Jack Dongarra, Argonne National Laboratory.
|
||||
*> Iain Duff, AERE Harwell.
|
||||
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
*> Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* -- Reference BLAS level3 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA,BETA
|
||||
INTEGER K,LDA,LDB,LDC,N
|
||||
CHARACTER TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP1,TEMP2
|
||||
INTEGER I,INFO,J,L,NROWA
|
||||
LOGICAL UPPER
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
NROWA = N
|
||||
ELSE
|
||||
NROWA = K
|
||||
END IF
|
||||
UPPER = LSAME(UPLO,'U')
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
|
||||
+ (.NOT.LSAME(TRANS,'T')) .AND.
|
||||
+ (.NOT.LSAME(TRANS,'C'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDB.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 9
|
||||
ELSE IF (LDC.LT.MAX(1,N)) THEN
|
||||
INFO = 12
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DSYR2K',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
|
||||
+ (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* And when alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
IF (UPPER) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,J
|
||||
C(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
DO 30 I = 1,J
|
||||
C(I,J) = BETA*C(I,J)
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 60 J = 1,N
|
||||
DO 50 I = J,N
|
||||
C(I,J) = ZERO
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
DO 70 I = J,N
|
||||
C(I,J) = BETA*C(I,J)
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form C := alpha*A*B**T + alpha*B*A**T + C.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 130 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 90 I = 1,J
|
||||
C(I,J) = ZERO
|
||||
90 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 100 I = 1,J
|
||||
C(I,J) = BETA*C(I,J)
|
||||
100 CONTINUE
|
||||
END IF
|
||||
DO 120 L = 1,K
|
||||
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*B(J,L)
|
||||
TEMP2 = ALPHA*A(J,L)
|
||||
DO 110 I = 1,J
|
||||
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
|
||||
+ B(I,L)*TEMP2
|
||||
110 CONTINUE
|
||||
END IF
|
||||
120 CONTINUE
|
||||
130 CONTINUE
|
||||
ELSE
|
||||
DO 180 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 140 I = J,N
|
||||
C(I,J) = ZERO
|
||||
140 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 150 I = J,N
|
||||
C(I,J) = BETA*C(I,J)
|
||||
150 CONTINUE
|
||||
END IF
|
||||
DO 170 L = 1,K
|
||||
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*B(J,L)
|
||||
TEMP2 = ALPHA*A(J,L)
|
||||
DO 160 I = J,N
|
||||
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
|
||||
+ B(I,L)*TEMP2
|
||||
160 CONTINUE
|
||||
END IF
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**T*B + alpha*B**T*A + C.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 210 J = 1,N
|
||||
DO 200 I = 1,J
|
||||
TEMP1 = ZERO
|
||||
TEMP2 = ZERO
|
||||
DO 190 L = 1,K
|
||||
TEMP1 = TEMP1 + A(L,I)*B(L,J)
|
||||
TEMP2 = TEMP2 + B(L,I)*A(L,J)
|
||||
190 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
|
||||
ELSE
|
||||
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
|
||||
+ ALPHA*TEMP2
|
||||
END IF
|
||||
200 CONTINUE
|
||||
210 CONTINUE
|
||||
ELSE
|
||||
DO 240 J = 1,N
|
||||
DO 230 I = J,N
|
||||
TEMP1 = ZERO
|
||||
TEMP2 = ZERO
|
||||
DO 220 L = 1,K
|
||||
TEMP1 = TEMP1 + A(L,I)*B(L,J)
|
||||
TEMP2 = TEMP2 + B(L,I)*A(L,J)
|
||||
220 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
|
||||
ELSE
|
||||
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
|
||||
+ ALPHA*TEMP2
|
||||
END IF
|
||||
230 CONTINUE
|
||||
240 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSYR2K.
|
||||
*
|
||||
END
|
||||
|
|
@ -1,364 +0,0 @@
|
|||
*> \brief \b DSYRK
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION ALPHA,BETA
|
||||
* INTEGER K,LDA,LDC,N
|
||||
* CHARACTER TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A(LDA,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DSYRK performs one of the symmetric rank k operations
|
||||
*>
|
||||
*> C := alpha*A*A**T + beta*C,
|
||||
*>
|
||||
*> or
|
||||
*>
|
||||
*> C := alpha*A**T*A + beta*C,
|
||||
*>
|
||||
*> where alpha and beta are scalars, C is an n by n symmetric matrix
|
||||
*> and A is an n by k matrix in the first case and a k by n matrix
|
||||
*> in the second case.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the array C is to be referenced as
|
||||
*> follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' Only the upper triangular part of C
|
||||
*> is to be referenced.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' Only the lower triangular part of C
|
||||
*> is to be referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the operation to be performed as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' C := alpha*A*A**T + beta*C.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' C := alpha*A**T*A + beta*C.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' C := alpha*A**T*A + beta*C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix C. N must be
|
||||
*> at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> On entry with TRANS = 'N' or 'n', K specifies the number
|
||||
*> of columns of the matrix A, and on entry with
|
||||
*> TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
|
||||
*> of rows of the matrix A. K must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is DOUBLE PRECISION.
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
|
||||
*> k when TRANS = 'N' or 'n', and is n otherwise.
|
||||
*> Before entry with TRANS = 'N' or 'n', the leading n by k
|
||||
*> part of the array A must contain the matrix A, otherwise
|
||||
*> the leading k by n part of the array A must contain the
|
||||
*> matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. When TRANS = 'N' or 'n'
|
||||
*> then LDA must be at least max( 1, n ), otherwise LDA must
|
||||
*> be at least max( 1, k ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is DOUBLE PRECISION.
|
||||
*> On entry, BETA specifies the scalar beta.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is DOUBLE PRECISION array of DIMENSION ( LDC, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
*> upper triangular part of the array C must contain the upper
|
||||
*> triangular part of the symmetric matrix and the strictly
|
||||
*> lower triangular part of C is not referenced. On exit, the
|
||||
*> upper triangular part of the array C is overwritten by the
|
||||
*> upper triangular part of the updated matrix.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
*> lower triangular part of the array C must contain the lower
|
||||
*> triangular part of the symmetric matrix and the strictly
|
||||
*> upper triangular part of C is not referenced. On exit, the
|
||||
*> lower triangular part of the array C is overwritten by the
|
||||
*> lower triangular part of the updated matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> On entry, LDC specifies the first dimension of C as declared
|
||||
*> in the calling (sub) program. LDC must be at least
|
||||
*> max( 1, n ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level3
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 3 Blas routine.
|
||||
*>
|
||||
*> -- Written on 8-February-1989.
|
||||
*> Jack Dongarra, Argonne National Laboratory.
|
||||
*> Iain Duff, AERE Harwell.
|
||||
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
*> Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
|
||||
*
|
||||
* -- Reference BLAS level3 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA,BETA
|
||||
INTEGER K,LDA,LDC,N
|
||||
CHARACTER TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,J,L,NROWA
|
||||
LOGICAL UPPER
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
NROWA = N
|
||||
ELSE
|
||||
NROWA = K
|
||||
END IF
|
||||
UPPER = LSAME(UPLO,'U')
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
|
||||
+ (.NOT.LSAME(TRANS,'T')) .AND.
|
||||
+ (.NOT.LSAME(TRANS,'C'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDC.LT.MAX(1,N)) THEN
|
||||
INFO = 10
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DSYRK ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
|
||||
+ (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* And when alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
IF (UPPER) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,J
|
||||
C(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
DO 30 I = 1,J
|
||||
C(I,J) = BETA*C(I,J)
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 60 J = 1,N
|
||||
DO 50 I = J,N
|
||||
C(I,J) = ZERO
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
DO 70 I = J,N
|
||||
C(I,J) = BETA*C(I,J)
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form C := alpha*A*A**T + beta*C.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 130 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 90 I = 1,J
|
||||
C(I,J) = ZERO
|
||||
90 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 100 I = 1,J
|
||||
C(I,J) = BETA*C(I,J)
|
||||
100 CONTINUE
|
||||
END IF
|
||||
DO 120 L = 1,K
|
||||
IF (A(J,L).NE.ZERO) THEN
|
||||
TEMP = ALPHA*A(J,L)
|
||||
DO 110 I = 1,J
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
110 CONTINUE
|
||||
END IF
|
||||
120 CONTINUE
|
||||
130 CONTINUE
|
||||
ELSE
|
||||
DO 180 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 140 I = J,N
|
||||
C(I,J) = ZERO
|
||||
140 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 150 I = J,N
|
||||
C(I,J) = BETA*C(I,J)
|
||||
150 CONTINUE
|
||||
END IF
|
||||
DO 170 L = 1,K
|
||||
IF (A(J,L).NE.ZERO) THEN
|
||||
TEMP = ALPHA*A(J,L)
|
||||
DO 160 I = J,N
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
160 CONTINUE
|
||||
END IF
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**T*A + beta*C.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 210 J = 1,N
|
||||
DO 200 I = 1,J
|
||||
TEMP = ZERO
|
||||
DO 190 L = 1,K
|
||||
TEMP = TEMP + A(L,I)*A(L,J)
|
||||
190 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
200 CONTINUE
|
||||
210 CONTINUE
|
||||
ELSE
|
||||
DO 240 J = 1,N
|
||||
DO 230 I = J,N
|
||||
TEMP = ZERO
|
||||
DO 220 L = 1,K
|
||||
TEMP = TEMP + A(L,I)*A(L,J)
|
||||
220 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
230 CONTINUE
|
||||
240 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSYRK .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,398 +0,0 @@
|
|||
*> \brief \b DTBMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,K,LDA,N
|
||||
* CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DTBMV performs one of the matrix-vector operations
|
||||
*>
|
||||
*> x := A*x, or x := A**T*x,
|
||||
*>
|
||||
*> where x is an n element vector and A is an n by n unit, or non-unit,
|
||||
*> upper or lower triangular band matrix, with ( k + 1 ) diagonals.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the matrix is an upper or
|
||||
*> lower triangular matrix as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the operation to be performed as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' x := A*x.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' x := A**T*x.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' x := A**T*x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIAG
|
||||
*> \verbatim
|
||||
*> DIAG is CHARACTER*1
|
||||
*> On entry, DIAG specifies whether or not A is unit
|
||||
*> triangular as follows:
|
||||
*>
|
||||
*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*>
|
||||
*> DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
*> triangular.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> On entry with UPLO = 'U' or 'u', K specifies the number of
|
||||
*> super-diagonals of the matrix A.
|
||||
*> On entry with UPLO = 'L' or 'l', K specifies the number of
|
||||
*> sub-diagonals of the matrix A.
|
||||
*> K must satisfy 0 .le. K.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
|
||||
*> by n part of the array A must contain the upper triangular
|
||||
*> band part of the matrix of coefficients, supplied column by
|
||||
*> column, with the leading diagonal of the matrix in row
|
||||
*> ( k + 1 ) of the array, the first super-diagonal starting at
|
||||
*> position 2 in row k, and so on. The top left k by k triangle
|
||||
*> of the array A is not referenced.
|
||||
*> The following program segment will transfer an upper
|
||||
*> triangular band matrix from conventional full matrix storage
|
||||
*> to band storage:
|
||||
*>
|
||||
*> DO 20, J = 1, N
|
||||
*> M = K + 1 - J
|
||||
*> DO 10, I = MAX( 1, J - K ), J
|
||||
*> A( M + I, J ) = matrix( I, J )
|
||||
*> 10 CONTINUE
|
||||
*> 20 CONTINUE
|
||||
*>
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
|
||||
*> by n part of the array A must contain the lower triangular
|
||||
*> band part of the matrix of coefficients, supplied column by
|
||||
*> column, with the leading diagonal of the matrix in row 1 of
|
||||
*> the array, the first sub-diagonal starting at position 1 in
|
||||
*> row 2, and so on. The bottom right k by k triangle of the
|
||||
*> array A is not referenced.
|
||||
*> The following program segment will transfer a lower
|
||||
*> triangular band matrix from conventional full matrix storage
|
||||
*> to band storage:
|
||||
*>
|
||||
*> DO 20, J = 1, N
|
||||
*> M = 1 - J
|
||||
*> DO 10, I = J, MIN( N, J + K )
|
||||
*> A( M + I, J ) = matrix( I, J )
|
||||
*> 10 CONTINUE
|
||||
*> 20 CONTINUE
|
||||
*>
|
||||
*> Note that when DIAG = 'U' or 'u' the elements of the array A
|
||||
*> corresponding to the diagonal elements of the matrix are not
|
||||
*> referenced, but are assumed to be unity.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> ( k + 1 ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x. On exit, X is overwritten with the
|
||||
*> tranformed vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,K,LDA,N
|
||||
CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER (ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L
|
||||
LOGICAL NOUNIT
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX,MIN
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 2
|
||||
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (LDA.LT. (K+1)) THEN
|
||||
INFO = 7
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DTBMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (N.EQ.0) RETURN
|
||||
*
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
*
|
||||
* Set up the start point in X if the increment is not unity. This
|
||||
* will be ( N - 1 )*INCX too small for descending loops.
|
||||
*
|
||||
IF (INCX.LE.0) THEN
|
||||
KX = 1 - (N-1)*INCX
|
||||
ELSE IF (INCX.NE.1) THEN
|
||||
KX = 1
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form x := A*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
KPLUS1 = K + 1
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = X(J)
|
||||
L = KPLUS1 - J
|
||||
DO 10 I = MAX(1,J-K),J - 1
|
||||
X(I) = X(I) + TEMP*A(L+I,J)
|
||||
10 CONTINUE
|
||||
IF (NOUNIT) X(J) = X(J)*A(KPLUS1,J)
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 40 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
L = KPLUS1 - J
|
||||
DO 30 I = MAX(1,J-K),J - 1
|
||||
X(IX) = X(IX) + TEMP*A(L+I,J)
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
IF (NOUNIT) X(JX) = X(JX)*A(KPLUS1,J)
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
IF (J.GT.K) KX = KX + INCX
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 60 J = N,1,-1
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = X(J)
|
||||
L = 1 - J
|
||||
DO 50 I = MIN(N,J+K),J + 1,-1
|
||||
X(I) = X(I) + TEMP*A(L+I,J)
|
||||
50 CONTINUE
|
||||
IF (NOUNIT) X(J) = X(J)*A(1,J)
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
KX = KX + (N-1)*INCX
|
||||
JX = KX
|
||||
DO 80 J = N,1,-1
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
L = 1 - J
|
||||
DO 70 I = MIN(N,J+K),J + 1,-1
|
||||
X(IX) = X(IX) + TEMP*A(L+I,J)
|
||||
IX = IX - INCX
|
||||
70 CONTINUE
|
||||
IF (NOUNIT) X(JX) = X(JX)*A(1,J)
|
||||
END IF
|
||||
JX = JX - INCX
|
||||
IF ((N-J).GE.K) KX = KX - INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form x := A**T*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
KPLUS1 = K + 1
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 100 J = N,1,-1
|
||||
TEMP = X(J)
|
||||
L = KPLUS1 - J
|
||||
IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J)
|
||||
DO 90 I = J - 1,MAX(1,J-K),-1
|
||||
TEMP = TEMP + A(L+I,J)*X(I)
|
||||
90 CONTINUE
|
||||
X(J) = TEMP
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
KX = KX + (N-1)*INCX
|
||||
JX = KX
|
||||
DO 120 J = N,1,-1
|
||||
TEMP = X(JX)
|
||||
KX = KX - INCX
|
||||
IX = KX
|
||||
L = KPLUS1 - J
|
||||
IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J)
|
||||
DO 110 I = J - 1,MAX(1,J-K),-1
|
||||
TEMP = TEMP + A(L+I,J)*X(IX)
|
||||
IX = IX - INCX
|
||||
110 CONTINUE
|
||||
X(JX) = TEMP
|
||||
JX = JX - INCX
|
||||
120 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 140 J = 1,N
|
||||
TEMP = X(J)
|
||||
L = 1 - J
|
||||
IF (NOUNIT) TEMP = TEMP*A(1,J)
|
||||
DO 130 I = J + 1,MIN(N,J+K)
|
||||
TEMP = TEMP + A(L+I,J)*X(I)
|
||||
130 CONTINUE
|
||||
X(J) = TEMP
|
||||
140 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 160 J = 1,N
|
||||
TEMP = X(JX)
|
||||
KX = KX + INCX
|
||||
IX = KX
|
||||
L = 1 - J
|
||||
IF (NOUNIT) TEMP = TEMP*A(1,J)
|
||||
DO 150 I = J + 1,MIN(N,J+K)
|
||||
TEMP = TEMP + A(L+I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
150 CONTINUE
|
||||
X(JX) = TEMP
|
||||
JX = JX + INCX
|
||||
160 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DTBMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,401 +0,0 @@
|
|||
*> \brief \b DTBSV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,K,LDA,N
|
||||
* CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DTBSV solves one of the systems of equations
|
||||
*>
|
||||
*> A*x = b, or A**T*x = b,
|
||||
*>
|
||||
*> where b and x are n element vectors and A is an n by n unit, or
|
||||
*> non-unit, upper or lower triangular band matrix, with ( k + 1 )
|
||||
*> diagonals.
|
||||
*>
|
||||
*> No test for singularity or near-singularity is included in this
|
||||
*> routine. Such tests must be performed before calling this routine.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the matrix is an upper or
|
||||
*> lower triangular matrix as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the equations to be solved as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' A*x = b.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' A**T*x = b.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' A**T*x = b.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIAG
|
||||
*> \verbatim
|
||||
*> DIAG is CHARACTER*1
|
||||
*> On entry, DIAG specifies whether or not A is unit
|
||||
*> triangular as follows:
|
||||
*>
|
||||
*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*>
|
||||
*> DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
*> triangular.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> On entry with UPLO = 'U' or 'u', K specifies the number of
|
||||
*> super-diagonals of the matrix A.
|
||||
*> On entry with UPLO = 'L' or 'l', K specifies the number of
|
||||
*> sub-diagonals of the matrix A.
|
||||
*> K must satisfy 0 .le. K.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
|
||||
*> by n part of the array A must contain the upper triangular
|
||||
*> band part of the matrix of coefficients, supplied column by
|
||||
*> column, with the leading diagonal of the matrix in row
|
||||
*> ( k + 1 ) of the array, the first super-diagonal starting at
|
||||
*> position 2 in row k, and so on. The top left k by k triangle
|
||||
*> of the array A is not referenced.
|
||||
*> The following program segment will transfer an upper
|
||||
*> triangular band matrix from conventional full matrix storage
|
||||
*> to band storage:
|
||||
*>
|
||||
*> DO 20, J = 1, N
|
||||
*> M = K + 1 - J
|
||||
*> DO 10, I = MAX( 1, J - K ), J
|
||||
*> A( M + I, J ) = matrix( I, J )
|
||||
*> 10 CONTINUE
|
||||
*> 20 CONTINUE
|
||||
*>
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
|
||||
*> by n part of the array A must contain the lower triangular
|
||||
*> band part of the matrix of coefficients, supplied column by
|
||||
*> column, with the leading diagonal of the matrix in row 1 of
|
||||
*> the array, the first sub-diagonal starting at position 1 in
|
||||
*> row 2, and so on. The bottom right k by k triangle of the
|
||||
*> array A is not referenced.
|
||||
*> The following program segment will transfer a lower
|
||||
*> triangular band matrix from conventional full matrix storage
|
||||
*> to band storage:
|
||||
*>
|
||||
*> DO 20, J = 1, N
|
||||
*> M = 1 - J
|
||||
*> DO 10, I = J, MIN( N, J + K )
|
||||
*> A( M + I, J ) = matrix( I, J )
|
||||
*> 10 CONTINUE
|
||||
*> 20 CONTINUE
|
||||
*>
|
||||
*> Note that when DIAG = 'U' or 'u' the elements of the array A
|
||||
*> corresponding to the diagonal elements of the matrix are not
|
||||
*> referenced, but are assumed to be unity.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> ( k + 1 ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element right-hand side vector b. On exit, X is overwritten
|
||||
*> with the solution vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,K,LDA,N
|
||||
CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER (ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L
|
||||
LOGICAL NOUNIT
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX,MIN
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 2
|
||||
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (LDA.LT. (K+1)) THEN
|
||||
INFO = 7
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DTBSV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (N.EQ.0) RETURN
|
||||
*
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
*
|
||||
* Set up the start point in X if the increment is not unity. This
|
||||
* will be ( N - 1 )*INCX too small for descending loops.
|
||||
*
|
||||
IF (INCX.LE.0) THEN
|
||||
KX = 1 - (N-1)*INCX
|
||||
ELSE IF (INCX.NE.1) THEN
|
||||
KX = 1
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed by sequentially with one pass through A.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form x := inv( A )*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
KPLUS1 = K + 1
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = N,1,-1
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
L = KPLUS1 - J
|
||||
IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J)
|
||||
TEMP = X(J)
|
||||
DO 10 I = J - 1,MAX(1,J-K),-1
|
||||
X(I) = X(I) - TEMP*A(L+I,J)
|
||||
10 CONTINUE
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
KX = KX + (N-1)*INCX
|
||||
JX = KX
|
||||
DO 40 J = N,1,-1
|
||||
KX = KX - INCX
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
IX = KX
|
||||
L = KPLUS1 - J
|
||||
IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J)
|
||||
TEMP = X(JX)
|
||||
DO 30 I = J - 1,MAX(1,J-K),-1
|
||||
X(IX) = X(IX) - TEMP*A(L+I,J)
|
||||
IX = IX - INCX
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JX = JX - INCX
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 60 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
L = 1 - J
|
||||
IF (NOUNIT) X(J) = X(J)/A(1,J)
|
||||
TEMP = X(J)
|
||||
DO 50 I = J + 1,MIN(N,J+K)
|
||||
X(I) = X(I) - TEMP*A(L+I,J)
|
||||
50 CONTINUE
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 80 J = 1,N
|
||||
KX = KX + INCX
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
IX = KX
|
||||
L = 1 - J
|
||||
IF (NOUNIT) X(JX) = X(JX)/A(1,J)
|
||||
TEMP = X(JX)
|
||||
DO 70 I = J + 1,MIN(N,J+K)
|
||||
X(IX) = X(IX) - TEMP*A(L+I,J)
|
||||
IX = IX + INCX
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form x := inv( A**T)*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
KPLUS1 = K + 1
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP = X(J)
|
||||
L = KPLUS1 - J
|
||||
DO 90 I = MAX(1,J-K),J - 1
|
||||
TEMP = TEMP - A(L+I,J)*X(I)
|
||||
90 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J)
|
||||
X(J) = TEMP
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 120 J = 1,N
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
L = KPLUS1 - J
|
||||
DO 110 I = MAX(1,J-K),J - 1
|
||||
TEMP = TEMP - A(L+I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
110 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J)
|
||||
X(JX) = TEMP
|
||||
JX = JX + INCX
|
||||
IF (J.GT.K) KX = KX + INCX
|
||||
120 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 140 J = N,1,-1
|
||||
TEMP = X(J)
|
||||
L = 1 - J
|
||||
DO 130 I = MIN(N,J+K),J + 1,-1
|
||||
TEMP = TEMP - A(L+I,J)*X(I)
|
||||
130 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/A(1,J)
|
||||
X(J) = TEMP
|
||||
140 CONTINUE
|
||||
ELSE
|
||||
KX = KX + (N-1)*INCX
|
||||
JX = KX
|
||||
DO 160 J = N,1,-1
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
L = 1 - J
|
||||
DO 150 I = MIN(N,J+K),J + 1,-1
|
||||
TEMP = TEMP - A(L+I,J)*X(IX)
|
||||
IX = IX - INCX
|
||||
150 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/A(1,J)
|
||||
X(JX) = TEMP
|
||||
JX = JX - INCX
|
||||
IF ((N-J).GE.K) KX = KX - INCX
|
||||
160 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DTBSV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,352 +0,0 @@
|
|||
*> \brief \b DTPMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,N
|
||||
* CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION AP(*),X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DTPMV performs one of the matrix-vector operations
|
||||
*>
|
||||
*> x := A*x, or x := A**T*x,
|
||||
*>
|
||||
*> where x is an n element vector and A is an n by n unit, or non-unit,
|
||||
*> upper or lower triangular matrix, supplied in packed form.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the matrix is an upper or
|
||||
*> lower triangular matrix as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the operation to be performed as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' x := A*x.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' x := A**T*x.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' x := A**T*x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIAG
|
||||
*> \verbatim
|
||||
*> DIAG is CHARACTER*1
|
||||
*> On entry, DIAG specifies whether or not A is unit
|
||||
*> triangular as follows:
|
||||
*>
|
||||
*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*>
|
||||
*> DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
*> triangular.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] AP
|
||||
*> \verbatim
|
||||
*> AP is DOUBLE PRECISION array of DIMENSION at least
|
||||
*> ( ( n*( n + 1 ) )/2 ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the array AP must
|
||||
*> contain the upper triangular matrix packed sequentially,
|
||||
*> column by column, so that AP( 1 ) contains a( 1, 1 ),
|
||||
*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
|
||||
*> respectively, and so on.
|
||||
*> Before entry with UPLO = 'L' or 'l', the array AP must
|
||||
*> contain the lower triangular matrix packed sequentially,
|
||||
*> column by column, so that AP( 1 ) contains a( 1, 1 ),
|
||||
*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
|
||||
*> respectively, and so on.
|
||||
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
*> A are not referenced, but are assumed to be unity.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x. On exit, X is overwritten with the
|
||||
*> tranformed vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,N
|
||||
CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION AP(*),X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER (ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,IX,J,JX,K,KK,KX
|
||||
LOGICAL NOUNIT
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 2
|
||||
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 7
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DTPMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (N.EQ.0) RETURN
|
||||
*
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
*
|
||||
* Set up the start point in X if the increment is not unity. This
|
||||
* will be ( N - 1 )*INCX too small for descending loops.
|
||||
*
|
||||
IF (INCX.LE.0) THEN
|
||||
KX = 1 - (N-1)*INCX
|
||||
ELSE IF (INCX.NE.1) THEN
|
||||
KX = 1
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of AP are
|
||||
* accessed sequentially with one pass through AP.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form x:= A*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
KK = 1
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = X(J)
|
||||
K = KK
|
||||
DO 10 I = 1,J - 1
|
||||
X(I) = X(I) + TEMP*AP(K)
|
||||
K = K + 1
|
||||
10 CONTINUE
|
||||
IF (NOUNIT) X(J) = X(J)*AP(KK+J-1)
|
||||
END IF
|
||||
KK = KK + J
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 40 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
DO 30 K = KK,KK + J - 2
|
||||
X(IX) = X(IX) + TEMP*AP(K)
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
IF (NOUNIT) X(JX) = X(JX)*AP(KK+J-1)
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
KK = KK + J
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
KK = (N* (N+1))/2
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 60 J = N,1,-1
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = X(J)
|
||||
K = KK
|
||||
DO 50 I = N,J + 1,-1
|
||||
X(I) = X(I) + TEMP*AP(K)
|
||||
K = K - 1
|
||||
50 CONTINUE
|
||||
IF (NOUNIT) X(J) = X(J)*AP(KK-N+J)
|
||||
END IF
|
||||
KK = KK - (N-J+1)
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
KX = KX + (N-1)*INCX
|
||||
JX = KX
|
||||
DO 80 J = N,1,-1
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
DO 70 K = KK,KK - (N- (J+1)),-1
|
||||
X(IX) = X(IX) + TEMP*AP(K)
|
||||
IX = IX - INCX
|
||||
70 CONTINUE
|
||||
IF (NOUNIT) X(JX) = X(JX)*AP(KK-N+J)
|
||||
END IF
|
||||
JX = JX - INCX
|
||||
KK = KK - (N-J+1)
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form x := A**T*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
KK = (N* (N+1))/2
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 100 J = N,1,-1
|
||||
TEMP = X(J)
|
||||
IF (NOUNIT) TEMP = TEMP*AP(KK)
|
||||
K = KK - 1
|
||||
DO 90 I = J - 1,1,-1
|
||||
TEMP = TEMP + AP(K)*X(I)
|
||||
K = K - 1
|
||||
90 CONTINUE
|
||||
X(J) = TEMP
|
||||
KK = KK - J
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX + (N-1)*INCX
|
||||
DO 120 J = N,1,-1
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
IF (NOUNIT) TEMP = TEMP*AP(KK)
|
||||
DO 110 K = KK - 1,KK - J + 1,-1
|
||||
IX = IX - INCX
|
||||
TEMP = TEMP + AP(K)*X(IX)
|
||||
110 CONTINUE
|
||||
X(JX) = TEMP
|
||||
JX = JX - INCX
|
||||
KK = KK - J
|
||||
120 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
KK = 1
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 140 J = 1,N
|
||||
TEMP = X(J)
|
||||
IF (NOUNIT) TEMP = TEMP*AP(KK)
|
||||
K = KK + 1
|
||||
DO 130 I = J + 1,N
|
||||
TEMP = TEMP + AP(K)*X(I)
|
||||
K = K + 1
|
||||
130 CONTINUE
|
||||
X(J) = TEMP
|
||||
KK = KK + (N-J+1)
|
||||
140 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 160 J = 1,N
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
IF (NOUNIT) TEMP = TEMP*AP(KK)
|
||||
DO 150 K = KK + 1,KK + N - J
|
||||
IX = IX + INCX
|
||||
TEMP = TEMP + AP(K)*X(IX)
|
||||
150 CONTINUE
|
||||
X(JX) = TEMP
|
||||
JX = JX + INCX
|
||||
KK = KK + (N-J+1)
|
||||
160 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DTPMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,354 +0,0 @@
|
|||
*> \brief \b DTPSV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,N
|
||||
* CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION AP(*),X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DTPSV solves one of the systems of equations
|
||||
*>
|
||||
*> A*x = b, or A**T*x = b,
|
||||
*>
|
||||
*> where b and x are n element vectors and A is an n by n unit, or
|
||||
*> non-unit, upper or lower triangular matrix, supplied in packed form.
|
||||
*>
|
||||
*> No test for singularity or near-singularity is included in this
|
||||
*> routine. Such tests must be performed before calling this routine.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the matrix is an upper or
|
||||
*> lower triangular matrix as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the equations to be solved as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' A*x = b.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' A**T*x = b.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' A**T*x = b.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIAG
|
||||
*> \verbatim
|
||||
*> DIAG is CHARACTER*1
|
||||
*> On entry, DIAG specifies whether or not A is unit
|
||||
*> triangular as follows:
|
||||
*>
|
||||
*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*>
|
||||
*> DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
*> triangular.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] AP
|
||||
*> \verbatim
|
||||
*> AP is DOUBLE PRECISION array of DIMENSION at least
|
||||
*> ( ( n*( n + 1 ) )/2 ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the array AP must
|
||||
*> contain the upper triangular matrix packed sequentially,
|
||||
*> column by column, so that AP( 1 ) contains a( 1, 1 ),
|
||||
*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
|
||||
*> respectively, and so on.
|
||||
*> Before entry with UPLO = 'L' or 'l', the array AP must
|
||||
*> contain the lower triangular matrix packed sequentially,
|
||||
*> column by column, so that AP( 1 ) contains a( 1, 1 ),
|
||||
*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
|
||||
*> respectively, and so on.
|
||||
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
*> A are not referenced, but are assumed to be unity.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element right-hand side vector b. On exit, X is overwritten
|
||||
*> with the solution vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,N
|
||||
CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION AP(*),X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER (ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,IX,J,JX,K,KK,KX
|
||||
LOGICAL NOUNIT
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 2
|
||||
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 7
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DTPSV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (N.EQ.0) RETURN
|
||||
*
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
*
|
||||
* Set up the start point in X if the increment is not unity. This
|
||||
* will be ( N - 1 )*INCX too small for descending loops.
|
||||
*
|
||||
IF (INCX.LE.0) THEN
|
||||
KX = 1 - (N-1)*INCX
|
||||
ELSE IF (INCX.NE.1) THEN
|
||||
KX = 1
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of AP are
|
||||
* accessed sequentially with one pass through AP.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form x := inv( A )*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
KK = (N* (N+1))/2
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = N,1,-1
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
IF (NOUNIT) X(J) = X(J)/AP(KK)
|
||||
TEMP = X(J)
|
||||
K = KK - 1
|
||||
DO 10 I = J - 1,1,-1
|
||||
X(I) = X(I) - TEMP*AP(K)
|
||||
K = K - 1
|
||||
10 CONTINUE
|
||||
END IF
|
||||
KK = KK - J
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX + (N-1)*INCX
|
||||
DO 40 J = N,1,-1
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
IF (NOUNIT) X(JX) = X(JX)/AP(KK)
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
DO 30 K = KK - 1,KK - J + 1,-1
|
||||
IX = IX - INCX
|
||||
X(IX) = X(IX) - TEMP*AP(K)
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JX = JX - INCX
|
||||
KK = KK - J
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
KK = 1
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 60 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
IF (NOUNIT) X(J) = X(J)/AP(KK)
|
||||
TEMP = X(J)
|
||||
K = KK + 1
|
||||
DO 50 I = J + 1,N
|
||||
X(I) = X(I) - TEMP*AP(K)
|
||||
K = K + 1
|
||||
50 CONTINUE
|
||||
END IF
|
||||
KK = KK + (N-J+1)
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 80 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
IF (NOUNIT) X(JX) = X(JX)/AP(KK)
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
DO 70 K = KK + 1,KK + N - J
|
||||
IX = IX + INCX
|
||||
X(IX) = X(IX) - TEMP*AP(K)
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
KK = KK + (N-J+1)
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form x := inv( A**T )*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
KK = 1
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP = X(J)
|
||||
K = KK
|
||||
DO 90 I = 1,J - 1
|
||||
TEMP = TEMP - AP(K)*X(I)
|
||||
K = K + 1
|
||||
90 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/AP(KK+J-1)
|
||||
X(J) = TEMP
|
||||
KK = KK + J
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 120 J = 1,N
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
DO 110 K = KK,KK + J - 2
|
||||
TEMP = TEMP - AP(K)*X(IX)
|
||||
IX = IX + INCX
|
||||
110 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/AP(KK+J-1)
|
||||
X(JX) = TEMP
|
||||
JX = JX + INCX
|
||||
KK = KK + J
|
||||
120 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
KK = (N* (N+1))/2
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 140 J = N,1,-1
|
||||
TEMP = X(J)
|
||||
K = KK
|
||||
DO 130 I = N,J + 1,-1
|
||||
TEMP = TEMP - AP(K)*X(I)
|
||||
K = K - 1
|
||||
130 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/AP(KK-N+J)
|
||||
X(J) = TEMP
|
||||
KK = KK - (N-J+1)
|
||||
140 CONTINUE
|
||||
ELSE
|
||||
KX = KX + (N-1)*INCX
|
||||
JX = KX
|
||||
DO 160 J = N,1,-1
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
DO 150 K = KK,KK - (N- (J+1)),-1
|
||||
TEMP = TEMP - AP(K)*X(IX)
|
||||
IX = IX - INCX
|
||||
150 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/AP(KK-N+J)
|
||||
X(JX) = TEMP
|
||||
JX = JX - INCX
|
||||
KK = KK - (N-J+1)
|
||||
160 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DTPSV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,415 +0,0 @@
|
|||
*> \brief \b DTRMM
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION ALPHA
|
||||
* INTEGER LDA,LDB,M,N
|
||||
* CHARACTER DIAG,SIDE,TRANSA,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A(LDA,*),B(LDB,*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DTRMM performs one of the matrix-matrix operations
|
||||
*>
|
||||
*> B := alpha*op( A )*B, or B := alpha*B*op( A ),
|
||||
*>
|
||||
*> where alpha is a scalar, B is an m by n matrix, A is a unit, or
|
||||
*> non-unit, upper or lower triangular matrix and op( A ) is one of
|
||||
*>
|
||||
*> op( A ) = A or op( A ) = A**T.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> On entry, SIDE specifies whether op( A ) multiplies B from
|
||||
*> the left or right as follows:
|
||||
*>
|
||||
*> SIDE = 'L' or 'l' B := alpha*op( A )*B.
|
||||
*>
|
||||
*> SIDE = 'R' or 'r' B := alpha*B*op( A ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the matrix A is an upper or
|
||||
*> lower triangular matrix as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANSA
|
||||
*> \verbatim
|
||||
*> TRANSA is CHARACTER*1
|
||||
*> On entry, TRANSA specifies the form of op( A ) to be used in
|
||||
*> the matrix multiplication as follows:
|
||||
*>
|
||||
*> TRANSA = 'N' or 'n' op( A ) = A.
|
||||
*>
|
||||
*> TRANSA = 'T' or 't' op( A ) = A**T.
|
||||
*>
|
||||
*> TRANSA = 'C' or 'c' op( A ) = A**T.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIAG
|
||||
*> \verbatim
|
||||
*> DIAG is CHARACTER*1
|
||||
*> On entry, DIAG specifies whether or not A is unit triangular
|
||||
*> as follows:
|
||||
*>
|
||||
*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*>
|
||||
*> DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
*> triangular.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of B. M must be at
|
||||
*> least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of B. N must be
|
||||
*> at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is DOUBLE PRECISION.
|
||||
*> On entry, ALPHA specifies the scalar alpha. When alpha is
|
||||
*> zero then A is not referenced and B need not be set before
|
||||
*> entry.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
|
||||
*> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading k by k
|
||||
*> upper triangular part of the array A must contain the upper
|
||||
*> triangular matrix and the strictly lower triangular part of
|
||||
*> A is not referenced.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading k by k
|
||||
*> lower triangular part of the array A must contain the lower
|
||||
*> triangular matrix and the strictly upper triangular part of
|
||||
*> A is not referenced.
|
||||
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
*> A are not referenced either, but are assumed to be unity.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. When SIDE = 'L' or 'l' then
|
||||
*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
|
||||
*> then LDA must be at least max( 1, n ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] B
|
||||
*> \verbatim
|
||||
*> B is DOUBLE PRECISION array of DIMENSION ( LDB, n ).
|
||||
*> Before entry, the leading m by n part of the array B must
|
||||
*> contain the matrix B, and on exit is overwritten by the
|
||||
*> transformed matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> On entry, LDB specifies the first dimension of B as declared
|
||||
*> in the calling (sub) program. LDB must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level3
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 3 Blas routine.
|
||||
*>
|
||||
*> -- Written on 8-February-1989.
|
||||
*> Jack Dongarra, Argonne National Laboratory.
|
||||
*> Iain Duff, AERE Harwell.
|
||||
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
*> Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
|
||||
*
|
||||
* -- Reference BLAS level3 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA
|
||||
INTEGER LDA,LDB,M,N
|
||||
CHARACTER DIAG,SIDE,TRANSA,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),B(LDB,*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,J,K,NROWA
|
||||
LOGICAL LSIDE,NOUNIT,UPPER
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
LSIDE = LSAME(SIDE,'L')
|
||||
IF (LSIDE) THEN
|
||||
NROWA = M
|
||||
ELSE
|
||||
NROWA = N
|
||||
END IF
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
UPPER = LSAME(UPLO,'U')
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
|
||||
+ (.NOT.LSAME(TRANSA,'T')) .AND.
|
||||
+ (.NOT.LSAME(TRANSA,'C'))) THEN
|
||||
INFO = 3
|
||||
ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
|
||||
INFO = 4
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 6
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 9
|
||||
ELSE IF (LDB.LT.MAX(1,M)) THEN
|
||||
INFO = 11
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DTRMM ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (M.EQ.0 .OR. N.EQ.0) RETURN
|
||||
*
|
||||
* And when alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,M
|
||||
B(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (LSIDE) THEN
|
||||
IF (LSAME(TRANSA,'N')) THEN
|
||||
*
|
||||
* Form B := alpha*A*B.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 50 J = 1,N
|
||||
DO 40 K = 1,M
|
||||
IF (B(K,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(K,J)
|
||||
DO 30 I = 1,K - 1
|
||||
B(I,J) = B(I,J) + TEMP*A(I,K)
|
||||
30 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP*A(K,K)
|
||||
B(K,J) = TEMP
|
||||
END IF
|
||||
40 CONTINUE
|
||||
50 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
DO 70 K = M,1,-1
|
||||
IF (B(K,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(K,J)
|
||||
B(K,J) = TEMP
|
||||
IF (NOUNIT) B(K,J) = B(K,J)*A(K,K)
|
||||
DO 60 I = K + 1,M
|
||||
B(I,J) = B(I,J) + TEMP*A(I,K)
|
||||
60 CONTINUE
|
||||
END IF
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form B := alpha*A**T*B.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 110 J = 1,N
|
||||
DO 100 I = M,1,-1
|
||||
TEMP = B(I,J)
|
||||
IF (NOUNIT) TEMP = TEMP*A(I,I)
|
||||
DO 90 K = 1,I - 1
|
||||
TEMP = TEMP + A(K,I)*B(K,J)
|
||||
90 CONTINUE
|
||||
B(I,J) = ALPHA*TEMP
|
||||
100 CONTINUE
|
||||
110 CONTINUE
|
||||
ELSE
|
||||
DO 140 J = 1,N
|
||||
DO 130 I = 1,M
|
||||
TEMP = B(I,J)
|
||||
IF (NOUNIT) TEMP = TEMP*A(I,I)
|
||||
DO 120 K = I + 1,M
|
||||
TEMP = TEMP + A(K,I)*B(K,J)
|
||||
120 CONTINUE
|
||||
B(I,J) = ALPHA*TEMP
|
||||
130 CONTINUE
|
||||
140 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
IF (LSAME(TRANSA,'N')) THEN
|
||||
*
|
||||
* Form B := alpha*B*A.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 180 J = N,1,-1
|
||||
TEMP = ALPHA
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 150 I = 1,M
|
||||
B(I,J) = TEMP*B(I,J)
|
||||
150 CONTINUE
|
||||
DO 170 K = 1,J - 1
|
||||
IF (A(K,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*A(K,J)
|
||||
DO 160 I = 1,M
|
||||
B(I,J) = B(I,J) + TEMP*B(I,K)
|
||||
160 CONTINUE
|
||||
END IF
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
ELSE
|
||||
DO 220 J = 1,N
|
||||
TEMP = ALPHA
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 190 I = 1,M
|
||||
B(I,J) = TEMP*B(I,J)
|
||||
190 CONTINUE
|
||||
DO 210 K = J + 1,N
|
||||
IF (A(K,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*A(K,J)
|
||||
DO 200 I = 1,M
|
||||
B(I,J) = B(I,J) + TEMP*B(I,K)
|
||||
200 CONTINUE
|
||||
END IF
|
||||
210 CONTINUE
|
||||
220 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form B := alpha*B*A**T.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 260 K = 1,N
|
||||
DO 240 J = 1,K - 1
|
||||
IF (A(J,K).NE.ZERO) THEN
|
||||
TEMP = ALPHA*A(J,K)
|
||||
DO 230 I = 1,M
|
||||
B(I,J) = B(I,J) + TEMP*B(I,K)
|
||||
230 CONTINUE
|
||||
END IF
|
||||
240 CONTINUE
|
||||
TEMP = ALPHA
|
||||
IF (NOUNIT) TEMP = TEMP*A(K,K)
|
||||
IF (TEMP.NE.ONE) THEN
|
||||
DO 250 I = 1,M
|
||||
B(I,K) = TEMP*B(I,K)
|
||||
250 CONTINUE
|
||||
END IF
|
||||
260 CONTINUE
|
||||
ELSE
|
||||
DO 300 K = N,1,-1
|
||||
DO 280 J = K + 1,N
|
||||
IF (A(J,K).NE.ZERO) THEN
|
||||
TEMP = ALPHA*A(J,K)
|
||||
DO 270 I = 1,M
|
||||
B(I,J) = B(I,J) + TEMP*B(I,K)
|
||||
270 CONTINUE
|
||||
END IF
|
||||
280 CONTINUE
|
||||
TEMP = ALPHA
|
||||
IF (NOUNIT) TEMP = TEMP*A(K,K)
|
||||
IF (TEMP.NE.ONE) THEN
|
||||
DO 290 I = 1,M
|
||||
B(I,K) = TEMP*B(I,K)
|
||||
290 CONTINUE
|
||||
END IF
|
||||
300 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DTRMM .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,342 +0,0 @@
|
|||
*> \brief \b DTRMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,LDA,N
|
||||
* CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DTRMV performs one of the matrix-vector operations
|
||||
*>
|
||||
*> x := A*x, or x := A**T*x,
|
||||
*>
|
||||
*> where x is an n element vector and A is an n by n unit, or non-unit,
|
||||
*> upper or lower triangular matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the matrix is an upper or
|
||||
*> lower triangular matrix as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the operation to be performed as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' x := A*x.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' x := A**T*x.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' x := A**T*x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIAG
|
||||
*> \verbatim
|
||||
*> DIAG is CHARACTER*1
|
||||
*> On entry, DIAG specifies whether or not A is unit
|
||||
*> triangular as follows:
|
||||
*>
|
||||
*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*>
|
||||
*> DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
*> triangular.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
*> upper triangular part of the array A must contain the upper
|
||||
*> triangular matrix and the strictly lower triangular part of
|
||||
*> A is not referenced.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
*> lower triangular part of the array A must contain the lower
|
||||
*> triangular matrix and the strictly upper triangular part of
|
||||
*> A is not referenced.
|
||||
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
*> A are not referenced either, but are assumed to be unity.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, n ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x. On exit, X is overwritten with the
|
||||
*> tranformed vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,LDA,N
|
||||
CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER (ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,IX,J,JX,KX
|
||||
LOGICAL NOUNIT
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 2
|
||||
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (LDA.LT.MAX(1,N)) THEN
|
||||
INFO = 6
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 8
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DTRMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (N.EQ.0) RETURN
|
||||
*
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
*
|
||||
* Set up the start point in X if the increment is not unity. This
|
||||
* will be ( N - 1 )*INCX too small for descending loops.
|
||||
*
|
||||
IF (INCX.LE.0) THEN
|
||||
KX = 1 - (N-1)*INCX
|
||||
ELSE IF (INCX.NE.1) THEN
|
||||
KX = 1
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form x := A*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = X(J)
|
||||
DO 10 I = 1,J - 1
|
||||
X(I) = X(I) + TEMP*A(I,J)
|
||||
10 CONTINUE
|
||||
IF (NOUNIT) X(J) = X(J)*A(J,J)
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 40 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
DO 30 I = 1,J - 1
|
||||
X(IX) = X(IX) + TEMP*A(I,J)
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
IF (NOUNIT) X(JX) = X(JX)*A(J,J)
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 60 J = N,1,-1
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = X(J)
|
||||
DO 50 I = N,J + 1,-1
|
||||
X(I) = X(I) + TEMP*A(I,J)
|
||||
50 CONTINUE
|
||||
IF (NOUNIT) X(J) = X(J)*A(J,J)
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
KX = KX + (N-1)*INCX
|
||||
JX = KX
|
||||
DO 80 J = N,1,-1
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
DO 70 I = N,J + 1,-1
|
||||
X(IX) = X(IX) + TEMP*A(I,J)
|
||||
IX = IX - INCX
|
||||
70 CONTINUE
|
||||
IF (NOUNIT) X(JX) = X(JX)*A(J,J)
|
||||
END IF
|
||||
JX = JX - INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form x := A**T*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 100 J = N,1,-1
|
||||
TEMP = X(J)
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 90 I = J - 1,1,-1
|
||||
TEMP = TEMP + A(I,J)*X(I)
|
||||
90 CONTINUE
|
||||
X(J) = TEMP
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX + (N-1)*INCX
|
||||
DO 120 J = N,1,-1
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 110 I = J - 1,1,-1
|
||||
IX = IX - INCX
|
||||
TEMP = TEMP + A(I,J)*X(IX)
|
||||
110 CONTINUE
|
||||
X(JX) = TEMP
|
||||
JX = JX - INCX
|
||||
120 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 140 J = 1,N
|
||||
TEMP = X(J)
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 130 I = J + 1,N
|
||||
TEMP = TEMP + A(I,J)*X(I)
|
||||
130 CONTINUE
|
||||
X(J) = TEMP
|
||||
140 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 160 J = 1,N
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 150 I = J + 1,N
|
||||
IX = IX + INCX
|
||||
TEMP = TEMP + A(I,J)*X(IX)
|
||||
150 CONTINUE
|
||||
X(JX) = TEMP
|
||||
JX = JX + INCX
|
||||
160 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DTRMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,443 +0,0 @@
|
|||
*> \brief \b DTRSM
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION ALPHA
|
||||
* INTEGER LDA,LDB,M,N
|
||||
* CHARACTER DIAG,SIDE,TRANSA,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A(LDA,*),B(LDB,*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DTRSM solves one of the matrix equations
|
||||
*>
|
||||
*> op( A )*X = alpha*B, or X*op( A ) = alpha*B,
|
||||
*>
|
||||
*> where alpha is a scalar, X and B are m by n matrices, A is a unit, or
|
||||
*> non-unit, upper or lower triangular matrix and op( A ) is one of
|
||||
*>
|
||||
*> op( A ) = A or op( A ) = A**T.
|
||||
*>
|
||||
*> The matrix X is overwritten on B.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> On entry, SIDE specifies whether op( A ) appears on the left
|
||||
*> or right of X as follows:
|
||||
*>
|
||||
*> SIDE = 'L' or 'l' op( A )*X = alpha*B.
|
||||
*>
|
||||
*> SIDE = 'R' or 'r' X*op( A ) = alpha*B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the matrix A is an upper or
|
||||
*> lower triangular matrix as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANSA
|
||||
*> \verbatim
|
||||
*> TRANSA is CHARACTER*1
|
||||
*> On entry, TRANSA specifies the form of op( A ) to be used in
|
||||
*> the matrix multiplication as follows:
|
||||
*>
|
||||
*> TRANSA = 'N' or 'n' op( A ) = A.
|
||||
*>
|
||||
*> TRANSA = 'T' or 't' op( A ) = A**T.
|
||||
*>
|
||||
*> TRANSA = 'C' or 'c' op( A ) = A**T.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIAG
|
||||
*> \verbatim
|
||||
*> DIAG is CHARACTER*1
|
||||
*> On entry, DIAG specifies whether or not A is unit triangular
|
||||
*> as follows:
|
||||
*>
|
||||
*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*>
|
||||
*> DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
*> triangular.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of B. M must be at
|
||||
*> least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of B. N must be
|
||||
*> at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is DOUBLE PRECISION.
|
||||
*> On entry, ALPHA specifies the scalar alpha. When alpha is
|
||||
*> zero then A is not referenced and B need not be set before
|
||||
*> entry.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array of DIMENSION ( LDA, k ),
|
||||
*> where k is m when SIDE = 'L' or 'l'
|
||||
*> and k is n when SIDE = 'R' or 'r'.
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading k by k
|
||||
*> upper triangular part of the array A must contain the upper
|
||||
*> triangular matrix and the strictly lower triangular part of
|
||||
*> A is not referenced.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading k by k
|
||||
*> lower triangular part of the array A must contain the lower
|
||||
*> triangular matrix and the strictly upper triangular part of
|
||||
*> A is not referenced.
|
||||
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
*> A are not referenced either, but are assumed to be unity.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. When SIDE = 'L' or 'l' then
|
||||
*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
|
||||
*> then LDA must be at least max( 1, n ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] B
|
||||
*> \verbatim
|
||||
*> B is DOUBLE PRECISION array of DIMENSION ( LDB, n ).
|
||||
*> Before entry, the leading m by n part of the array B must
|
||||
*> contain the right-hand side matrix B, and on exit is
|
||||
*> overwritten by the solution matrix X.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> On entry, LDB specifies the first dimension of B as declared
|
||||
*> in the calling (sub) program. LDB must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level3
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 3 Blas routine.
|
||||
*>
|
||||
*>
|
||||
*> -- Written on 8-February-1989.
|
||||
*> Jack Dongarra, Argonne National Laboratory.
|
||||
*> Iain Duff, AERE Harwell.
|
||||
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
*> Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
|
||||
*
|
||||
* -- Reference BLAS level3 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA
|
||||
INTEGER LDA,LDB,M,N
|
||||
CHARACTER DIAG,SIDE,TRANSA,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),B(LDB,*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,J,K,NROWA
|
||||
LOGICAL LSIDE,NOUNIT,UPPER
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
LSIDE = LSAME(SIDE,'L')
|
||||
IF (LSIDE) THEN
|
||||
NROWA = M
|
||||
ELSE
|
||||
NROWA = N
|
||||
END IF
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
UPPER = LSAME(UPLO,'U')
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
|
||||
+ (.NOT.LSAME(TRANSA,'T')) .AND.
|
||||
+ (.NOT.LSAME(TRANSA,'C'))) THEN
|
||||
INFO = 3
|
||||
ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
|
||||
INFO = 4
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 6
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 9
|
||||
ELSE IF (LDB.LT.MAX(1,M)) THEN
|
||||
INFO = 11
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DTRSM ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (M.EQ.0 .OR. N.EQ.0) RETURN
|
||||
*
|
||||
* And when alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,M
|
||||
B(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (LSIDE) THEN
|
||||
IF (LSAME(TRANSA,'N')) THEN
|
||||
*
|
||||
* Form B := alpha*inv( A )*B.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 60 J = 1,N
|
||||
IF (ALPHA.NE.ONE) THEN
|
||||
DO 30 I = 1,M
|
||||
B(I,J) = ALPHA*B(I,J)
|
||||
30 CONTINUE
|
||||
END IF
|
||||
DO 50 K = M,1,-1
|
||||
IF (B(K,J).NE.ZERO) THEN
|
||||
IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
|
||||
DO 40 I = 1,K - 1
|
||||
B(I,J) = B(I,J) - B(K,J)*A(I,K)
|
||||
40 CONTINUE
|
||||
END IF
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 100 J = 1,N
|
||||
IF (ALPHA.NE.ONE) THEN
|
||||
DO 70 I = 1,M
|
||||
B(I,J) = ALPHA*B(I,J)
|
||||
70 CONTINUE
|
||||
END IF
|
||||
DO 90 K = 1,M
|
||||
IF (B(K,J).NE.ZERO) THEN
|
||||
IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
|
||||
DO 80 I = K + 1,M
|
||||
B(I,J) = B(I,J) - B(K,J)*A(I,K)
|
||||
80 CONTINUE
|
||||
END IF
|
||||
90 CONTINUE
|
||||
100 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form B := alpha*inv( A**T )*B.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 130 J = 1,N
|
||||
DO 120 I = 1,M
|
||||
TEMP = ALPHA*B(I,J)
|
||||
DO 110 K = 1,I - 1
|
||||
TEMP = TEMP - A(K,I)*B(K,J)
|
||||
110 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/A(I,I)
|
||||
B(I,J) = TEMP
|
||||
120 CONTINUE
|
||||
130 CONTINUE
|
||||
ELSE
|
||||
DO 160 J = 1,N
|
||||
DO 150 I = M,1,-1
|
||||
TEMP = ALPHA*B(I,J)
|
||||
DO 140 K = I + 1,M
|
||||
TEMP = TEMP - A(K,I)*B(K,J)
|
||||
140 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/A(I,I)
|
||||
B(I,J) = TEMP
|
||||
150 CONTINUE
|
||||
160 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
IF (LSAME(TRANSA,'N')) THEN
|
||||
*
|
||||
* Form B := alpha*B*inv( A ).
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 210 J = 1,N
|
||||
IF (ALPHA.NE.ONE) THEN
|
||||
DO 170 I = 1,M
|
||||
B(I,J) = ALPHA*B(I,J)
|
||||
170 CONTINUE
|
||||
END IF
|
||||
DO 190 K = 1,J - 1
|
||||
IF (A(K,J).NE.ZERO) THEN
|
||||
DO 180 I = 1,M
|
||||
B(I,J) = B(I,J) - A(K,J)*B(I,K)
|
||||
180 CONTINUE
|
||||
END IF
|
||||
190 CONTINUE
|
||||
IF (NOUNIT) THEN
|
||||
TEMP = ONE/A(J,J)
|
||||
DO 200 I = 1,M
|
||||
B(I,J) = TEMP*B(I,J)
|
||||
200 CONTINUE
|
||||
END IF
|
||||
210 CONTINUE
|
||||
ELSE
|
||||
DO 260 J = N,1,-1
|
||||
IF (ALPHA.NE.ONE) THEN
|
||||
DO 220 I = 1,M
|
||||
B(I,J) = ALPHA*B(I,J)
|
||||
220 CONTINUE
|
||||
END IF
|
||||
DO 240 K = J + 1,N
|
||||
IF (A(K,J).NE.ZERO) THEN
|
||||
DO 230 I = 1,M
|
||||
B(I,J) = B(I,J) - A(K,J)*B(I,K)
|
||||
230 CONTINUE
|
||||
END IF
|
||||
240 CONTINUE
|
||||
IF (NOUNIT) THEN
|
||||
TEMP = ONE/A(J,J)
|
||||
DO 250 I = 1,M
|
||||
B(I,J) = TEMP*B(I,J)
|
||||
250 CONTINUE
|
||||
END IF
|
||||
260 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form B := alpha*B*inv( A**T ).
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 310 K = N,1,-1
|
||||
IF (NOUNIT) THEN
|
||||
TEMP = ONE/A(K,K)
|
||||
DO 270 I = 1,M
|
||||
B(I,K) = TEMP*B(I,K)
|
||||
270 CONTINUE
|
||||
END IF
|
||||
DO 290 J = 1,K - 1
|
||||
IF (A(J,K).NE.ZERO) THEN
|
||||
TEMP = A(J,K)
|
||||
DO 280 I = 1,M
|
||||
B(I,J) = B(I,J) - TEMP*B(I,K)
|
||||
280 CONTINUE
|
||||
END IF
|
||||
290 CONTINUE
|
||||
IF (ALPHA.NE.ONE) THEN
|
||||
DO 300 I = 1,M
|
||||
B(I,K) = ALPHA*B(I,K)
|
||||
300 CONTINUE
|
||||
END IF
|
||||
310 CONTINUE
|
||||
ELSE
|
||||
DO 360 K = 1,N
|
||||
IF (NOUNIT) THEN
|
||||
TEMP = ONE/A(K,K)
|
||||
DO 320 I = 1,M
|
||||
B(I,K) = TEMP*B(I,K)
|
||||
320 CONTINUE
|
||||
END IF
|
||||
DO 340 J = K + 1,N
|
||||
IF (A(J,K).NE.ZERO) THEN
|
||||
TEMP = A(J,K)
|
||||
DO 330 I = 1,M
|
||||
B(I,J) = B(I,J) - TEMP*B(I,K)
|
||||
330 CONTINUE
|
||||
END IF
|
||||
340 CONTINUE
|
||||
IF (ALPHA.NE.ONE) THEN
|
||||
DO 350 I = 1,M
|
||||
B(I,K) = ALPHA*B(I,K)
|
||||
350 CONTINUE
|
||||
END IF
|
||||
360 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DTRSM .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,338 +0,0 @@
|
|||
*> \brief \b DTRSV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,LDA,N
|
||||
* CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DTRSV solves one of the systems of equations
|
||||
*>
|
||||
*> A*x = b, or A**T*x = b,
|
||||
*>
|
||||
*> where b and x are n element vectors and A is an n by n unit, or
|
||||
*> non-unit, upper or lower triangular matrix.
|
||||
*>
|
||||
*> No test for singularity or near-singularity is included in this
|
||||
*> routine. Such tests must be performed before calling this routine.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the matrix is an upper or
|
||||
*> lower triangular matrix as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the equations to be solved as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' A*x = b.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' A**T*x = b.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' A**T*x = b.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIAG
|
||||
*> \verbatim
|
||||
*> DIAG is CHARACTER*1
|
||||
*> On entry, DIAG specifies whether or not A is unit
|
||||
*> triangular as follows:
|
||||
*>
|
||||
*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*>
|
||||
*> DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
*> triangular.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
*> upper triangular part of the array A must contain the upper
|
||||
*> triangular matrix and the strictly lower triangular part of
|
||||
*> A is not referenced.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
*> lower triangular part of the array A must contain the lower
|
||||
*> triangular matrix and the strictly upper triangular part of
|
||||
*> A is not referenced.
|
||||
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
*> A are not referenced either, but are assumed to be unity.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, n ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element right-hand side vector b. On exit, X is overwritten
|
||||
*> with the solution vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level1
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,LDA,N
|
||||
CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER (ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,IX,J,JX,KX
|
||||
LOGICAL NOUNIT
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 2
|
||||
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (LDA.LT.MAX(1,N)) THEN
|
||||
INFO = 6
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 8
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DTRSV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (N.EQ.0) RETURN
|
||||
*
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
*
|
||||
* Set up the start point in X if the increment is not unity. This
|
||||
* will be ( N - 1 )*INCX too small for descending loops.
|
||||
*
|
||||
IF (INCX.LE.0) THEN
|
||||
KX = 1 - (N-1)*INCX
|
||||
ELSE IF (INCX.NE.1) THEN
|
||||
KX = 1
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form x := inv( A )*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = N,1,-1
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
IF (NOUNIT) X(J) = X(J)/A(J,J)
|
||||
TEMP = X(J)
|
||||
DO 10 I = J - 1,1,-1
|
||||
X(I) = X(I) - TEMP*A(I,J)
|
||||
10 CONTINUE
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX + (N-1)*INCX
|
||||
DO 40 J = N,1,-1
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
IF (NOUNIT) X(JX) = X(JX)/A(J,J)
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
DO 30 I = J - 1,1,-1
|
||||
IX = IX - INCX
|
||||
X(IX) = X(IX) - TEMP*A(I,J)
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JX = JX - INCX
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 60 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
IF (NOUNIT) X(J) = X(J)/A(J,J)
|
||||
TEMP = X(J)
|
||||
DO 50 I = J + 1,N
|
||||
X(I) = X(I) - TEMP*A(I,J)
|
||||
50 CONTINUE
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 80 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
IF (NOUNIT) X(JX) = X(JX)/A(J,J)
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
DO 70 I = J + 1,N
|
||||
IX = IX + INCX
|
||||
X(IX) = X(IX) - TEMP*A(I,J)
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form x := inv( A**T )*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP = X(J)
|
||||
DO 90 I = 1,J - 1
|
||||
TEMP = TEMP - A(I,J)*X(I)
|
||||
90 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/A(J,J)
|
||||
X(J) = TEMP
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 120 J = 1,N
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
DO 110 I = 1,J - 1
|
||||
TEMP = TEMP - A(I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
110 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/A(J,J)
|
||||
X(JX) = TEMP
|
||||
JX = JX + INCX
|
||||
120 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 140 J = N,1,-1
|
||||
TEMP = X(J)
|
||||
DO 130 I = N,J + 1,-1
|
||||
TEMP = TEMP - A(I,J)*X(I)
|
||||
130 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/A(J,J)
|
||||
X(J) = TEMP
|
||||
140 CONTINUE
|
||||
ELSE
|
||||
KX = KX + (N-1)*INCX
|
||||
JX = KX
|
||||
DO 160 J = N,1,-1
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
DO 150 I = N,J + 1,-1
|
||||
TEMP = TEMP - A(I,J)*X(IX)
|
||||
IX = IX - INCX
|
||||
150 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP/A(J,J)
|
||||
X(JX) = TEMP
|
||||
JX = JX - INCX
|
||||
160 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DTRSV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,97 +0,0 @@
|
|||
*> \brief \b DZASUM
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* DOUBLE PRECISION FUNCTION DZASUM(N,ZX,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 ZX(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DZASUM takes the sum of the absolute values.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, 3/11/78.
|
||||
*> modified 3/93 to return if incx .le. 0.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
DOUBLE PRECISION FUNCTION DZASUM(N,ZX,INCX)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 ZX(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION STEMP
|
||||
INTEGER I,NINCX
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
DOUBLE PRECISION DCABS1
|
||||
EXTERNAL DCABS1
|
||||
* ..
|
||||
DZASUM = 0.0d0
|
||||
STEMP = 0.0d0
|
||||
IF (N.LE.0 .OR. INCX.LE.0) RETURN
|
||||
IF (INCX.EQ.1) THEN
|
||||
*
|
||||
* code for increment equal to 1
|
||||
*
|
||||
DO I = 1,N
|
||||
STEMP = STEMP + DCABS1(ZX(I))
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for increment not equal to 1
|
||||
*
|
||||
NINCX = N*INCX
|
||||
DO I = 1,NINCX,INCX
|
||||
STEMP = STEMP + DCABS1(ZX(I))
|
||||
END DO
|
||||
END IF
|
||||
DZASUM = STEMP
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,119 +0,0 @@
|
|||
*> \brief \b DZNRM2
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* DOUBLE PRECISION FUNCTION DZNRM2(N,X,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DZNRM2 returns the euclidean norm of a vector via the function
|
||||
*> name, so that
|
||||
*>
|
||||
*> DZNRM2 := sqrt( x**H*x )
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> -- This version written on 25-October-1982.
|
||||
*> Modified on 14-October-1993 to inline the call to ZLASSQ.
|
||||
*> Sven Hammarling, Nag Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
DOUBLE PRECISION FUNCTION DZNRM2(N,X,INCX)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION NORM,SCALE,SSQ,TEMP
|
||||
INTEGER IX
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS,DBLE,DIMAG,SQRT
|
||||
* ..
|
||||
IF (N.LT.1 .OR. INCX.LT.1) THEN
|
||||
NORM = ZERO
|
||||
ELSE
|
||||
SCALE = ZERO
|
||||
SSQ = ONE
|
||||
* The following loop is equivalent to this call to the LAPACK
|
||||
* auxiliary routine:
|
||||
* CALL ZLASSQ( N, X, INCX, SCALE, SSQ )
|
||||
*
|
||||
DO 10 IX = 1,1 + (N-1)*INCX,INCX
|
||||
IF (DBLE(X(IX)).NE.ZERO) THEN
|
||||
TEMP = ABS(DBLE(X(IX)))
|
||||
IF (SCALE.LT.TEMP) THEN
|
||||
SSQ = ONE + SSQ* (SCALE/TEMP)**2
|
||||
SCALE = TEMP
|
||||
ELSE
|
||||
SSQ = SSQ + (TEMP/SCALE)**2
|
||||
END IF
|
||||
END IF
|
||||
IF (DIMAG(X(IX)).NE.ZERO) THEN
|
||||
TEMP = ABS(DIMAG(X(IX)))
|
||||
IF (SCALE.LT.TEMP) THEN
|
||||
SSQ = ONE + SSQ* (SCALE/TEMP)**2
|
||||
SCALE = TEMP
|
||||
ELSE
|
||||
SSQ = SSQ + (TEMP/SCALE)**2
|
||||
END IF
|
||||
END IF
|
||||
10 CONTINUE
|
||||
NORM = SCALE*SQRT(SSQ)
|
||||
END IF
|
||||
*
|
||||
DZNRM2 = NORM
|
||||
RETURN
|
||||
*
|
||||
* End of DZNRM2.
|
||||
*
|
||||
END
|
||||
|
|
@ -1,107 +0,0 @@
|
|||
*> \brief \b ICAMAX
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* INTEGER FUNCTION ICAMAX(N,CX,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX CX(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ICAMAX finds the index of element having max. absolute value.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup aux_blas
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 3/93 to return if incx .le. 0.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
INTEGER FUNCTION ICAMAX(N,CX,INCX)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX CX(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
REAL SMAX
|
||||
INTEGER I,IX
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
REAL SCABS1
|
||||
EXTERNAL SCABS1
|
||||
* ..
|
||||
ICAMAX = 0
|
||||
IF (N.LT.1 .OR. INCX.LE.0) RETURN
|
||||
ICAMAX = 1
|
||||
IF (N.EQ.1) RETURN
|
||||
IF (INCX.EQ.1) THEN
|
||||
*
|
||||
* code for increment equal to 1
|
||||
*
|
||||
SMAX = SCABS1(CX(1))
|
||||
DO I = 2,N
|
||||
IF (SCABS1(CX(I)).GT.SMAX) THEN
|
||||
ICAMAX = I
|
||||
SMAX = SCABS1(CX(I))
|
||||
END IF
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for increment not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
SMAX = SCABS1(CX(1))
|
||||
IX = IX + INCX
|
||||
DO I = 2,N
|
||||
IF (SCABS1(CX(IX)).GT.SMAX) THEN
|
||||
ICAMAX = I
|
||||
SMAX = SCABS1(CX(IX))
|
||||
END IF
|
||||
IX = IX + INCX
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,106 +0,0 @@
|
|||
*> \brief \b IDAMAX
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* INTEGER FUNCTION IDAMAX(N,DX,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION DX(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> IDAMAX finds the index of element having max. absolute value.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup aux_blas
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 3/93 to return if incx .le. 0.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
INTEGER FUNCTION IDAMAX(N,DX,INCX)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DX(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION DMAX
|
||||
INTEGER I,IX
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DABS
|
||||
* ..
|
||||
IDAMAX = 0
|
||||
IF (N.LT.1 .OR. INCX.LE.0) RETURN
|
||||
IDAMAX = 1
|
||||
IF (N.EQ.1) RETURN
|
||||
IF (INCX.EQ.1) THEN
|
||||
*
|
||||
* code for increment equal to 1
|
||||
*
|
||||
DMAX = DABS(DX(1))
|
||||
DO I = 2,N
|
||||
IF (DABS(DX(I)).GT.DMAX) THEN
|
||||
IDAMAX = I
|
||||
DMAX = DABS(DX(I))
|
||||
END IF
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for increment not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
DMAX = DABS(DX(1))
|
||||
IX = IX + INCX
|
||||
DO I = 2,N
|
||||
IF (DABS(DX(IX)).GT.DMAX) THEN
|
||||
IDAMAX = I
|
||||
DMAX = DABS(DX(IX))
|
||||
END IF
|
||||
IX = IX + INCX
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,106 +0,0 @@
|
|||
*> \brief \b ISAMAX
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* INTEGER FUNCTION ISAMAX(N,SX,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL SX(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ISAMAX finds the index of element having max. absolute value.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup aux_blas
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 3/93 to return if incx .le. 0.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
INTEGER FUNCTION ISAMAX(N,SX,INCX)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL SX(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
REAL SMAX
|
||||
INTEGER I,IX
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS
|
||||
* ..
|
||||
ISAMAX = 0
|
||||
IF (N.LT.1 .OR. INCX.LE.0) RETURN
|
||||
ISAMAX = 1
|
||||
IF (N.EQ.1) RETURN
|
||||
IF (INCX.EQ.1) THEN
|
||||
*
|
||||
* code for increment equal to 1
|
||||
*
|
||||
SMAX = ABS(SX(1))
|
||||
DO I = 2,N
|
||||
IF (ABS(SX(I)).GT.SMAX) THEN
|
||||
ISAMAX = I
|
||||
SMAX = ABS(SX(I))
|
||||
END IF
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for increment not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
SMAX = ABS(SX(1))
|
||||
IX = IX + INCX
|
||||
DO I = 2,N
|
||||
IF (ABS(SX(IX)).GT.SMAX) THEN
|
||||
ISAMAX = I
|
||||
SMAX = ABS(SX(IX))
|
||||
END IF
|
||||
IX = IX + INCX
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,107 +0,0 @@
|
|||
*> \brief \b IZAMAX
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* INTEGER FUNCTION IZAMAX(N,ZX,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 ZX(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> IZAMAX finds the index of element having max. absolute value.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup aux_blas
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, 1/15/85.
|
||||
*> modified 3/93 to return if incx .le. 0.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
INTEGER FUNCTION IZAMAX(N,ZX,INCX)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 ZX(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION DMAX
|
||||
INTEGER I,IX
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
DOUBLE PRECISION DCABS1
|
||||
EXTERNAL DCABS1
|
||||
* ..
|
||||
IZAMAX = 0
|
||||
IF (N.LT.1 .OR. INCX.LE.0) RETURN
|
||||
IZAMAX = 1
|
||||
IF (N.EQ.1) RETURN
|
||||
IF (INCX.EQ.1) THEN
|
||||
*
|
||||
* code for increment equal to 1
|
||||
*
|
||||
DMAX = DCABS1(ZX(1))
|
||||
DO I = 2,N
|
||||
IF (DCABS1(ZX(I)).GT.DMAX) THEN
|
||||
IZAMAX = I
|
||||
DMAX = DCABS1(ZX(I))
|
||||
END IF
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for increment not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
DMAX = DCABS1(ZX(1))
|
||||
IX = IX + INCX
|
||||
DO I = 2,N
|
||||
IF (DCABS1(ZX(IX)).GT.DMAX) THEN
|
||||
IZAMAX = I
|
||||
DMAX = DCABS1(ZX(IX))
|
||||
END IF
|
||||
IX = IX + INCX
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,125 +0,0 @@
|
|||
*> \brief \b LSAME
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* LOGICAL FUNCTION LSAME(CA,CB)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER CA,CB
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> LSAME returns .TRUE. if CA is the same letter as CB regardless of
|
||||
*> case.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] CA
|
||||
*> \verbatim
|
||||
*> CA is CHARACTER*1
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] CB
|
||||
*> \verbatim
|
||||
*> CB is CHARACTER*1
|
||||
*> CA and CB specify the single characters to be compared.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup aux_blas
|
||||
*
|
||||
* =====================================================================
|
||||
LOGICAL FUNCTION LSAME(CA,CB)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.1) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER CA,CB
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ICHAR
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER INTA,INTB,ZCODE
|
||||
* ..
|
||||
*
|
||||
* Test if the characters are equal
|
||||
*
|
||||
LSAME = CA .EQ. CB
|
||||
IF (LSAME) RETURN
|
||||
*
|
||||
* Now test for equivalence if both characters are alphabetic.
|
||||
*
|
||||
ZCODE = ICHAR('Z')
|
||||
*
|
||||
* Use 'Z' rather than 'A' so that ASCII can be detected on Prime
|
||||
* machines, on which ICHAR returns a value with bit 8 set.
|
||||
* ICHAR('A') on Prime machines returns 193 which is the same as
|
||||
* ICHAR('A') on an EBCDIC machine.
|
||||
*
|
||||
INTA = ICHAR(CA)
|
||||
INTB = ICHAR(CB)
|
||||
*
|
||||
IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN
|
||||
*
|
||||
* ASCII is assumed - ZCODE is the ASCII code of either lower or
|
||||
* upper case 'Z'.
|
||||
*
|
||||
IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32
|
||||
IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32
|
||||
*
|
||||
ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN
|
||||
*
|
||||
* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
|
||||
* upper case 'Z'.
|
||||
*
|
||||
IF (INTA.GE.129 .AND. INTA.LE.137 .OR.
|
||||
+ INTA.GE.145 .AND. INTA.LE.153 .OR.
|
||||
+ INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64
|
||||
IF (INTB.GE.129 .AND. INTB.LE.137 .OR.
|
||||
+ INTB.GE.145 .AND. INTB.LE.153 .OR.
|
||||
+ INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64
|
||||
*
|
||||
ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN
|
||||
*
|
||||
* ASCII is assumed, on Prime machines - ZCODE is the ASCII code
|
||||
* plus 128 of either lower or upper case 'Z'.
|
||||
*
|
||||
IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32
|
||||
IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32
|
||||
END IF
|
||||
LSAME = INTA .EQ. INTB
|
||||
*
|
||||
* RETURN
|
||||
*
|
||||
* End of LSAME
|
||||
*
|
||||
END
|
||||
|
|
@ -1,112 +0,0 @@
|
|||
*> \brief \b SASUM
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* REAL FUNCTION SASUM(N,SX,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL SX(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SASUM takes the sum of the absolute values.
|
||||
*> uses unrolled loops for increment equal to one.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup single_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 3/93 to return if incx .le. 0.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
REAL FUNCTION SASUM(N,SX,INCX)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL SX(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
REAL STEMP
|
||||
INTEGER I,M,MP1,NINCX
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS,MOD
|
||||
* ..
|
||||
SASUM = 0.0e0
|
||||
STEMP = 0.0e0
|
||||
IF (N.LE.0 .OR. INCX.LE.0) RETURN
|
||||
IF (INCX.EQ.1) THEN
|
||||
* code for increment equal to 1
|
||||
*
|
||||
*
|
||||
* clean-up loop
|
||||
*
|
||||
M = MOD(N,6)
|
||||
IF (M.NE.0) THEN
|
||||
DO I = 1,M
|
||||
STEMP = STEMP + ABS(SX(I))
|
||||
END DO
|
||||
IF (N.LT.6) THEN
|
||||
SASUM = STEMP
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
MP1 = M + 1
|
||||
DO I = MP1,N,6
|
||||
STEMP = STEMP + ABS(SX(I)) + ABS(SX(I+1)) +
|
||||
$ ABS(SX(I+2)) + ABS(SX(I+3)) +
|
||||
$ ABS(SX(I+4)) + ABS(SX(I+5))
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for increment not equal to 1
|
||||
*
|
||||
NINCX = N*INCX
|
||||
DO I = 1,NINCX,INCX
|
||||
STEMP = STEMP + ABS(SX(I))
|
||||
END DO
|
||||
END IF
|
||||
SASUM = STEMP
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,115 +0,0 @@
|
|||
*> \brief \b SAXPY
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SAXPY(N,SA,SX,INCX,SY,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* REAL SA
|
||||
* INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL SX(*),SY(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SAXPY constant times a vector plus a vector.
|
||||
*> uses unrolled loops for increments equal to one.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup single_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE SAXPY(N,SA,SX,INCX,SY,INCY)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL SA
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL SX(*),SY(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I,IX,IY,M,MP1
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD
|
||||
* ..
|
||||
IF (N.LE.0) RETURN
|
||||
IF (SA.EQ.0.0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
*
|
||||
* clean-up loop
|
||||
*
|
||||
M = MOD(N,4)
|
||||
IF (M.NE.0) THEN
|
||||
DO I = 1,M
|
||||
SY(I) = SY(I) + SA*SX(I)
|
||||
END DO
|
||||
END IF
|
||||
IF (N.LT.4) RETURN
|
||||
MP1 = M + 1
|
||||
DO I = MP1,N,4
|
||||
SY(I) = SY(I) + SA*SX(I)
|
||||
SY(I+1) = SY(I+1) + SA*SX(I+1)
|
||||
SY(I+2) = SY(I+2) + SA*SX(I+2)
|
||||
SY(I+3) = SY(I+3) + SA*SX(I+3)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments
|
||||
* not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
SY(IY) = SY(IY) + SA*SX(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,57 +0,0 @@
|
|||
*> \brief \b SCABS1
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* REAL FUNCTION SCABS1(Z)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX Z
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SCABS1 computes absolute value of a complex number
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup single_blas_level1
|
||||
*
|
||||
* =====================================================================
|
||||
REAL FUNCTION SCABS1(Z)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX Z
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS,AIMAG,REAL
|
||||
* ..
|
||||
SCABS1 = ABS(REAL(Z)) + ABS(AIMAG(Z))
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,97 +0,0 @@
|
|||
*> \brief \b SCASUM
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* REAL FUNCTION SCASUM(N,CX,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX CX(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SCASUM takes the sum of the absolute values of a complex vector and
|
||||
*> returns a single precision result.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup single_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 3/93 to return if incx .le. 0.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
REAL FUNCTION SCASUM(N,CX,INCX)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX CX(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
REAL STEMP
|
||||
INTEGER I,NINCX
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS,AIMAG,REAL
|
||||
* ..
|
||||
SCASUM = 0.0e0
|
||||
STEMP = 0.0e0
|
||||
IF (N.LE.0 .OR. INCX.LE.0) RETURN
|
||||
IF (INCX.EQ.1) THEN
|
||||
*
|
||||
* code for increment equal to 1
|
||||
*
|
||||
DO I = 1,N
|
||||
STEMP = STEMP + ABS(REAL(CX(I))) + ABS(AIMAG(CX(I)))
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for increment not equal to 1
|
||||
*
|
||||
NINCX = N*INCX
|
||||
DO I = 1,NINCX,INCX
|
||||
STEMP = STEMP + ABS(REAL(CX(I))) + ABS(AIMAG(CX(I)))
|
||||
END DO
|
||||
END IF
|
||||
SCASUM = STEMP
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,119 +0,0 @@
|
|||
*> \brief \b SCNRM2
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* REAL FUNCTION SCNRM2(N,X,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SCNRM2 returns the euclidean norm of a vector via the function
|
||||
*> name, so that
|
||||
*>
|
||||
*> SCNRM2 := sqrt( x**H*x )
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup single_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> -- This version written on 25-October-1982.
|
||||
*> Modified on 14-October-1993 to inline the call to CLASSQ.
|
||||
*> Sven Hammarling, Nag Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
REAL FUNCTION SCNRM2(N,X,INCX)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ONE,ZERO
|
||||
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
REAL NORM,SCALE,SSQ,TEMP
|
||||
INTEGER IX
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS,AIMAG,REAL,SQRT
|
||||
* ..
|
||||
IF (N.LT.1 .OR. INCX.LT.1) THEN
|
||||
NORM = ZERO
|
||||
ELSE
|
||||
SCALE = ZERO
|
||||
SSQ = ONE
|
||||
* The following loop is equivalent to this call to the LAPACK
|
||||
* auxiliary routine:
|
||||
* CALL CLASSQ( N, X, INCX, SCALE, SSQ )
|
||||
*
|
||||
DO 10 IX = 1,1 + (N-1)*INCX,INCX
|
||||
IF (REAL(X(IX)).NE.ZERO) THEN
|
||||
TEMP = ABS(REAL(X(IX)))
|
||||
IF (SCALE.LT.TEMP) THEN
|
||||
SSQ = ONE + SSQ* (SCALE/TEMP)**2
|
||||
SCALE = TEMP
|
||||
ELSE
|
||||
SSQ = SSQ + (TEMP/SCALE)**2
|
||||
END IF
|
||||
END IF
|
||||
IF (AIMAG(X(IX)).NE.ZERO) THEN
|
||||
TEMP = ABS(AIMAG(X(IX)))
|
||||
IF (SCALE.LT.TEMP) THEN
|
||||
SSQ = ONE + SSQ* (SCALE/TEMP)**2
|
||||
SCALE = TEMP
|
||||
ELSE
|
||||
SSQ = SSQ + (TEMP/SCALE)**2
|
||||
END IF
|
||||
END IF
|
||||
10 CONTINUE
|
||||
NORM = SCALE*SQRT(SSQ)
|
||||
END IF
|
||||
*
|
||||
SCNRM2 = NORM
|
||||
RETURN
|
||||
*
|
||||
* End of SCNRM2.
|
||||
*
|
||||
END
|
||||
|
|
@ -1,115 +0,0 @@
|
|||
*> \brief \b SCOPY
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SCOPY(N,SX,INCX,SY,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL SX(*),SY(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SCOPY copies a vector, x, to a vector, y.
|
||||
*> uses unrolled loops for increments equal to 1.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup single_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE SCOPY(N,SX,INCX,SY,INCY)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL SX(*),SY(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I,IX,IY,M,MP1
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD
|
||||
* ..
|
||||
IF (N.LE.0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
*
|
||||
* clean-up loop
|
||||
*
|
||||
M = MOD(N,7)
|
||||
IF (M.NE.0) THEN
|
||||
DO I = 1,M
|
||||
SY(I) = SX(I)
|
||||
END DO
|
||||
IF (N.LT.7) RETURN
|
||||
END IF
|
||||
MP1 = M + 1
|
||||
DO I = MP1,N,7
|
||||
SY(I) = SX(I)
|
||||
SY(I+1) = SX(I+1)
|
||||
SY(I+2) = SX(I+2)
|
||||
SY(I+3) = SX(I+3)
|
||||
SY(I+4) = SX(I+4)
|
||||
SY(I+5) = SX(I+5)
|
||||
SY(I+6) = SX(I+6)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments
|
||||
* not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
SY(IY) = SX(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,117 +0,0 @@
|
|||
*> \brief \b SDOT
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* REAL FUNCTION SDOT(N,SX,INCX,SY,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL SX(*),SY(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SDOT forms the dot product of two vectors.
|
||||
*> uses unrolled loops for increments equal to one.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup single_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
REAL FUNCTION SDOT(N,SX,INCX,SY,INCY)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL SX(*),SY(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
REAL STEMP
|
||||
INTEGER I,IX,IY,M,MP1
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD
|
||||
* ..
|
||||
STEMP = 0.0e0
|
||||
SDOT = 0.0e0
|
||||
IF (N.LE.0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
*
|
||||
* clean-up loop
|
||||
*
|
||||
M = MOD(N,5)
|
||||
IF (M.NE.0) THEN
|
||||
DO I = 1,M
|
||||
STEMP = STEMP + SX(I)*SY(I)
|
||||
END DO
|
||||
IF (N.LT.5) THEN
|
||||
SDOT=STEMP
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
MP1 = M + 1
|
||||
DO I = MP1,N,5
|
||||
STEMP = STEMP + SX(I)*SY(I) + SX(I+1)*SY(I+1) +
|
||||
$ SX(I+2)*SY(I+2) + SX(I+3)*SY(I+3) + SX(I+4)*SY(I+4)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments
|
||||
* not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
STEMP = STEMP + SX(IX)*SY(IY)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
SDOT = STEMP
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,255 +0,0 @@
|
|||
*> \brief \b SDSDOT
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* REAL SB
|
||||
* INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL SX(*),SY(*)
|
||||
* ..
|
||||
*
|
||||
* PURPOSE
|
||||
* =======
|
||||
*
|
||||
* Compute the inner product of two vectors with extended
|
||||
* precision accumulation.
|
||||
*
|
||||
* Returns S.P. result with dot product accumulated in D.P.
|
||||
* SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY),
|
||||
* where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
|
||||
* defined in a similar way using INCY.
|
||||
*
|
||||
* AUTHOR
|
||||
* ======
|
||||
* Lawson, C. L., (JPL), Hanson, R. J., (SNLA),
|
||||
* Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL)
|
||||
*
|
||||
* ARGUMENTS
|
||||
* =========
|
||||
*
|
||||
* N (input) INTEGER
|
||||
* number of elements in input vector(s)
|
||||
*
|
||||
* SB (input) REAL
|
||||
* single precision scalar to be added to inner product
|
||||
*
|
||||
* SX (input) REAL array, dimension (N)
|
||||
* single precision vector with N elements
|
||||
*
|
||||
* INCX (input) INTEGER
|
||||
* storage spacing between elements of SX
|
||||
*
|
||||
* SY (input) REAL array, dimension (N)
|
||||
* single precision vector with N elements
|
||||
*
|
||||
* INCY (input) INTEGER
|
||||
* storage spacing between elements of SY
|
||||
*
|
||||
* SDSDOT (output) REAL
|
||||
* single precision dot product (SB if N .LE. 0)
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* REFERENCES
|
||||
*
|
||||
* C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
|
||||
* Krogh, Basic linear algebra subprograms for Fortran
|
||||
* usage, Algorithm No. 539, Transactions on Mathematical
|
||||
* Software 5, 3 (September 1979), pp. 308-323.
|
||||
*
|
||||
* REVISION HISTORY (YYMMDD)
|
||||
*
|
||||
* 791001 DATE WRITTEN
|
||||
* 890531 Changed all specific intrinsics to generic. (WRB)
|
||||
* 890831 Modified array declarations. (WRB)
|
||||
* 890831 REVISION DATE from Version 3.2
|
||||
* 891214 Prologue converted to Version 4.0 format. (BAB)
|
||||
* 920310 Corrected definition of LX in DESCRIPTION. (WRB)
|
||||
* 920501 Reformatted the REFERENCES section. (WRB)
|
||||
* 070118 Reformat to LAPACK coding style
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
* DOUBLE PRECISION DSDOT
|
||||
* INTEGER I,KX,KY,NS
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
* INTRINSIC DBLE
|
||||
* ..
|
||||
* DSDOT = SB
|
||||
* IF (N.LE.0) THEN
|
||||
* SDSDOT = DSDOT
|
||||
* RETURN
|
||||
* END IF
|
||||
* IF (INCX.EQ.INCY .AND. INCX.GT.0) THEN
|
||||
*
|
||||
* Code for equal and positive increments.
|
||||
*
|
||||
* NS = N*INCX
|
||||
* DO I = 1,NS,INCX
|
||||
* DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I))
|
||||
* END DO
|
||||
* ELSE
|
||||
*
|
||||
* Code for unequal or nonpositive increments.
|
||||
*
|
||||
* KX = 1
|
||||
* KY = 1
|
||||
* IF (INCX.LT.0) KX = 1 + (1-N)*INCX
|
||||
* IF (INCY.LT.0) KY = 1 + (1-N)*INCY
|
||||
* DO I = 1,N
|
||||
* DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY))
|
||||
* KX = KX + INCX
|
||||
* KY = KY + INCY
|
||||
* END DO
|
||||
* END IF
|
||||
* SDSDOT = DSDOT
|
||||
* RETURN
|
||||
* END
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup single_blas_level1
|
||||
*
|
||||
* =====================================================================
|
||||
REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL SB
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL SX(*),SY(*)
|
||||
* ..
|
||||
*
|
||||
* PURPOSE
|
||||
* =======
|
||||
*
|
||||
* Compute the inner product of two vectors with extended
|
||||
* precision accumulation.
|
||||
*
|
||||
* Returns S.P. result with dot product accumulated in D.P.
|
||||
* SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY),
|
||||
* where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
|
||||
* defined in a similar way using INCY.
|
||||
*
|
||||
* AUTHOR
|
||||
* ======
|
||||
* Lawson, C. L., (JPL), Hanson, R. J., (SNLA),
|
||||
* Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL)
|
||||
*
|
||||
* ARGUMENTS
|
||||
* =========
|
||||
*
|
||||
* N (input) INTEGER
|
||||
* number of elements in input vector(s)
|
||||
*
|
||||
* SB (input) REAL
|
||||
* single precision scalar to be added to inner product
|
||||
*
|
||||
* SX (input) REAL array, dimension (N)
|
||||
* single precision vector with N elements
|
||||
*
|
||||
* INCX (input) INTEGER
|
||||
* storage spacing between elements of SX
|
||||
*
|
||||
* SY (input) REAL array, dimension (N)
|
||||
* single precision vector with N elements
|
||||
*
|
||||
* INCY (input) INTEGER
|
||||
* storage spacing between elements of SY
|
||||
*
|
||||
* SDSDOT (output) REAL
|
||||
* single precision dot product (SB if N .LE. 0)
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* REFERENCES
|
||||
*
|
||||
* C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
|
||||
* Krogh, Basic linear algebra subprograms for Fortran
|
||||
* usage, Algorithm No. 539, Transactions on Mathematical
|
||||
* Software 5, 3 (September 1979), pp. 308-323.
|
||||
*
|
||||
* REVISION HISTORY (YYMMDD)
|
||||
*
|
||||
* 791001 DATE WRITTEN
|
||||
* 890531 Changed all specific intrinsics to generic. (WRB)
|
||||
* 890831 Modified array declarations. (WRB)
|
||||
* 890831 REVISION DATE from Version 3.2
|
||||
* 891214 Prologue converted to Version 4.0 format. (BAB)
|
||||
* 920310 Corrected definition of LX in DESCRIPTION. (WRB)
|
||||
* 920501 Reformatted the REFERENCES section. (WRB)
|
||||
* 070118 Reformat to LAPACK coding style
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION DSDOT
|
||||
INTEGER I,KX,KY,NS
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DBLE
|
||||
* ..
|
||||
DSDOT = SB
|
||||
IF (N.LE.0) THEN
|
||||
SDSDOT = DSDOT
|
||||
RETURN
|
||||
END IF
|
||||
IF (INCX.EQ.INCY .AND. INCX.GT.0) THEN
|
||||
*
|
||||
* Code for equal and positive increments.
|
||||
*
|
||||
NS = N*INCX
|
||||
DO I = 1,NS,INCX
|
||||
DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I))
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* Code for unequal or nonpositive increments.
|
||||
*
|
||||
KX = 1
|
||||
KY = 1
|
||||
IF (INCX.LT.0) KX = 1 + (1-N)*INCX
|
||||
IF (INCY.LT.0) KY = 1 + (1-N)*INCY
|
||||
DO I = 1,N
|
||||
DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY))
|
||||
KX = KX + INCX
|
||||
KY = KY + INCY
|
||||
END DO
|
||||
END IF
|
||||
SDSDOT = DSDOT
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,374 +0,0 @@
|
|||
*> \brief \b SGBMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* REAL ALPHA,BETA
|
||||
* INTEGER INCX,INCY,KL,KU,LDA,M,N
|
||||
* CHARACTER TRANS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SGBMV performs one of the matrix-vector operations
|
||||
*>
|
||||
*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y,
|
||||
*>
|
||||
*> where alpha and beta are scalars, x and y are vectors and A is an
|
||||
*> m by n band matrix, with kl sub-diagonals and ku super-diagonals.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the operation to be performed as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of the matrix A.
|
||||
*> M must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KL
|
||||
*> \verbatim
|
||||
*> KL is INTEGER
|
||||
*> On entry, KL specifies the number of sub-diagonals of the
|
||||
*> matrix A. KL must satisfy 0 .le. KL.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KU
|
||||
*> \verbatim
|
||||
*> KU is INTEGER
|
||||
*> On entry, KU specifies the number of super-diagonals of the
|
||||
*> matrix A. KU must satisfy 0 .le. KU.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is REAL
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is REAL array of DIMENSION ( LDA, n ).
|
||||
*> Before entry, the leading ( kl + ku + 1 ) by n part of the
|
||||
*> array A must contain the matrix of coefficients, supplied
|
||||
*> column by column, with the leading diagonal of the matrix in
|
||||
*> row ( ku + 1 ) of the array, the first super-diagonal
|
||||
*> starting at position 2 in row ku, the first sub-diagonal
|
||||
*> starting at position 1 in row ( ku + 2 ), and so on.
|
||||
*> Elements in the array A that do not correspond to elements
|
||||
*> in the band matrix (such as the top left ku by ku triangle)
|
||||
*> are not referenced.
|
||||
*> The following program segment will transfer a band matrix
|
||||
*> from conventional full matrix storage to band storage:
|
||||
*>
|
||||
*> DO 20, J = 1, N
|
||||
*> K = KU + 1 - J
|
||||
*> DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL )
|
||||
*> A( K + I, J ) = matrix( I, J )
|
||||
*> 10 CONTINUE
|
||||
*> 20 CONTINUE
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> ( kl + ku + 1 ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is REAL array of DIMENSION at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
|
||||
*> and at least
|
||||
*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
|
||||
*> Before entry, the incremented array X must contain the
|
||||
*> vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is REAL
|
||||
*> On entry, BETA specifies the scalar beta. When BETA is
|
||||
*> supplied as zero then Y need not be set on input.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] Y
|
||||
*> \verbatim
|
||||
*> Y is REAL array of DIMENSION at least
|
||||
*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
|
||||
*> and at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
|
||||
*> Before entry, the incremented array Y must contain the
|
||||
*> vector y. On exit, Y is overwritten by the updated vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup single_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE SGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL ALPHA,BETA
|
||||
INTEGER INCX,INCY,KL,KU,LDA,M,N
|
||||
CHARACTER TRANS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ONE,ZERO
|
||||
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
REAL TEMP
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,K,KUP1,KX,KY,LENX,LENY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX,MIN
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (KL.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (KU.LT.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (LDA.LT. (KL+KU+1)) THEN
|
||||
INFO = 8
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 10
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 13
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('SGBMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
|
||||
+ ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* Set LENX and LENY, the lengths of the vectors x and y, and set
|
||||
* up the start points in X and Y.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
LENX = N
|
||||
LENY = M
|
||||
ELSE
|
||||
LENX = M
|
||||
LENY = N
|
||||
END IF
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (LENX-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (LENY-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through the band part of A.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,LENY
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,LENY
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,LENY
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,LENY
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
KUP1 = KU + 1
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form y := alpha*A*x + y.
|
||||
*
|
||||
JX = KX
|
||||
IF (INCY.EQ.1) THEN
|
||||
DO 60 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
K = KUP1 - J
|
||||
DO 50 I = MAX(1,J-KU),MIN(M,J+KL)
|
||||
Y(I) = Y(I) + TEMP*A(K+I,J)
|
||||
50 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
IY = KY
|
||||
K = KUP1 - J
|
||||
DO 70 I = MAX(1,J-KU),MIN(M,J+KL)
|
||||
Y(IY) = Y(IY) + TEMP*A(K+I,J)
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
IF (J.GT.KU) KY = KY + INCY
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y := alpha*A**T*x + y.
|
||||
*
|
||||
JY = KY
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP = ZERO
|
||||
K = KUP1 - J
|
||||
DO 90 I = MAX(1,J-KU),MIN(M,J+KL)
|
||||
TEMP = TEMP + A(K+I,J)*X(I)
|
||||
90 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP
|
||||
JY = JY + INCY
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
DO 120 J = 1,N
|
||||
TEMP = ZERO
|
||||
IX = KX
|
||||
K = KUP1 - J
|
||||
DO 110 I = MAX(1,J-KU),MIN(M,J+KL)
|
||||
TEMP = TEMP + A(K+I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
110 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP
|
||||
JY = JY + INCY
|
||||
IF (J.GT.KU) KX = KX + INCX
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of SGBMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,388 +0,0 @@
|
|||
*> \brief \b SGEMM
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* REAL ALPHA,BETA
|
||||
* INTEGER K,LDA,LDB,LDC,M,N
|
||||
* CHARACTER TRANSA,TRANSB
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SGEMM performs one of the matrix-matrix operations
|
||||
*>
|
||||
*> C := alpha*op( A )*op( B ) + beta*C,
|
||||
*>
|
||||
*> where op( X ) is one of
|
||||
*>
|
||||
*> op( X ) = X or op( X ) = X**T,
|
||||
*>
|
||||
*> alpha and beta are scalars, and A, B and C are matrices, with op( A )
|
||||
*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] TRANSA
|
||||
*> \verbatim
|
||||
*> TRANSA is CHARACTER*1
|
||||
*> On entry, TRANSA specifies the form of op( A ) to be used in
|
||||
*> the matrix multiplication as follows:
|
||||
*>
|
||||
*> TRANSA = 'N' or 'n', op( A ) = A.
|
||||
*>
|
||||
*> TRANSA = 'T' or 't', op( A ) = A**T.
|
||||
*>
|
||||
*> TRANSA = 'C' or 'c', op( A ) = A**T.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANSB
|
||||
*> \verbatim
|
||||
*> TRANSB is CHARACTER*1
|
||||
*> On entry, TRANSB specifies the form of op( B ) to be used in
|
||||
*> the matrix multiplication as follows:
|
||||
*>
|
||||
*> TRANSB = 'N' or 'n', op( B ) = B.
|
||||
*>
|
||||
*> TRANSB = 'T' or 't', op( B ) = B**T.
|
||||
*>
|
||||
*> TRANSB = 'C' or 'c', op( B ) = B**T.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of the matrix
|
||||
*> op( A ) and of the matrix C. M must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of the matrix
|
||||
*> op( B ) and the number of columns of the matrix C. N must be
|
||||
*> at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> On entry, K specifies the number of columns of the matrix
|
||||
*> op( A ) and the number of rows of the matrix op( B ). K must
|
||||
*> be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is REAL
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is REAL array of DIMENSION ( LDA, ka ), where ka is
|
||||
*> k when TRANSA = 'N' or 'n', and is m otherwise.
|
||||
*> Before entry with TRANSA = 'N' or 'n', the leading m by k
|
||||
*> part of the array A must contain the matrix A, otherwise
|
||||
*> the leading k by m part of the array A must contain the
|
||||
*> matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. When TRANSA = 'N' or 'n' then
|
||||
*> LDA must be at least max( 1, m ), otherwise LDA must be at
|
||||
*> least max( 1, k ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> B is REAL array of DIMENSION ( LDB, kb ), where kb is
|
||||
*> n when TRANSB = 'N' or 'n', and is k otherwise.
|
||||
*> Before entry with TRANSB = 'N' or 'n', the leading k by n
|
||||
*> part of the array B must contain the matrix B, otherwise
|
||||
*> the leading n by k part of the array B must contain the
|
||||
*> matrix B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> On entry, LDB specifies the first dimension of B as declared
|
||||
*> in the calling (sub) program. When TRANSB = 'N' or 'n' then
|
||||
*> LDB must be at least max( 1, k ), otherwise LDB must be at
|
||||
*> least max( 1, n ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is REAL
|
||||
*> On entry, BETA specifies the scalar beta. When BETA is
|
||||
*> supplied as zero then C need not be set on input.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is REAL array of DIMENSION ( LDC, n ).
|
||||
*> Before entry, the leading m by n part of the array C must
|
||||
*> contain the matrix C, except when beta is zero, in which
|
||||
*> case C need not be set on entry.
|
||||
*> On exit, the array C is overwritten by the m by n matrix
|
||||
*> ( alpha*op( A )*op( B ) + beta*C ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> On entry, LDC specifies the first dimension of C as declared
|
||||
*> in the calling (sub) program. LDC must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup single_blas_level3
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 3 Blas routine.
|
||||
*>
|
||||
*> -- Written on 8-February-1989.
|
||||
*> Jack Dongarra, Argonne National Laboratory.
|
||||
*> Iain Duff, AERE Harwell.
|
||||
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
*> Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* -- Reference BLAS level3 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL ALPHA,BETA
|
||||
INTEGER K,LDA,LDB,LDC,M,N
|
||||
CHARACTER TRANSA,TRANSB
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
REAL TEMP
|
||||
INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB
|
||||
LOGICAL NOTA,NOTB
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
REAL ONE,ZERO
|
||||
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
|
||||
* ..
|
||||
*
|
||||
* Set NOTA and NOTB as true if A and B respectively are not
|
||||
* transposed and set NROWA, NCOLA and NROWB as the number of rows
|
||||
* and columns of A and the number of rows of B respectively.
|
||||
*
|
||||
NOTA = LSAME(TRANSA,'N')
|
||||
NOTB = LSAME(TRANSB,'N')
|
||||
IF (NOTA) THEN
|
||||
NROWA = M
|
||||
NCOLA = K
|
||||
ELSE
|
||||
NROWA = K
|
||||
NCOLA = M
|
||||
END IF
|
||||
IF (NOTB) THEN
|
||||
NROWB = K
|
||||
ELSE
|
||||
NROWB = N
|
||||
END IF
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND.
|
||||
+ (.NOT.LSAME(TRANSA,'T'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND.
|
||||
+ (.NOT.LSAME(TRANSB,'T'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 8
|
||||
ELSE IF (LDB.LT.MAX(1,NROWB)) THEN
|
||||
INFO = 10
|
||||
ELSE IF (LDC.LT.MAX(1,M)) THEN
|
||||
INFO = 13
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('SGEMM ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
|
||||
+ (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* And if alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
DO 30 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
END IF
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (NOTB) THEN
|
||||
IF (NOTA) THEN
|
||||
*
|
||||
* Form C := alpha*A*B + beta*C.
|
||||
*
|
||||
DO 90 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 50 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
50 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 60 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
60 CONTINUE
|
||||
END IF
|
||||
DO 80 L = 1,K
|
||||
IF (B(L,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(L,J)
|
||||
DO 70 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
70 CONTINUE
|
||||
END IF
|
||||
80 CONTINUE
|
||||
90 CONTINUE
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**T*B + beta*C
|
||||
*
|
||||
DO 120 J = 1,N
|
||||
DO 110 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 100 L = 1,K
|
||||
TEMP = TEMP + A(L,I)*B(L,J)
|
||||
100 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
110 CONTINUE
|
||||
120 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (NOTA) THEN
|
||||
*
|
||||
* Form C := alpha*A*B**T + beta*C
|
||||
*
|
||||
DO 170 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 130 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
130 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 140 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
140 CONTINUE
|
||||
END IF
|
||||
DO 160 L = 1,K
|
||||
IF (B(J,L).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(J,L)
|
||||
DO 150 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
150 CONTINUE
|
||||
END IF
|
||||
160 CONTINUE
|
||||
170 CONTINUE
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**T*B**T + beta*C
|
||||
*
|
||||
DO 200 J = 1,N
|
||||
DO 190 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 180 L = 1,K
|
||||
TEMP = TEMP + A(L,I)*B(J,L)
|
||||
180 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
190 CONTINUE
|
||||
200 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of SGEMM .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,334 +0,0 @@
|
|||
*> \brief \b SGEMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* REAL ALPHA,BETA
|
||||
* INTEGER INCX,INCY,LDA,M,N
|
||||
* CHARACTER TRANS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SGEMV performs one of the matrix-vector operations
|
||||
*>
|
||||
*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y,
|
||||
*>
|
||||
*> where alpha and beta are scalars, x and y are vectors and A is an
|
||||
*> m by n matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the operation to be performed as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of the matrix A.
|
||||
*> M must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is REAL
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is REAL array of DIMENSION ( LDA, n ).
|
||||
*> Before entry, the leading m by n part of the array A must
|
||||
*> contain the matrix of coefficients.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is REAL array of DIMENSION at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
|
||||
*> and at least
|
||||
*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
|
||||
*> Before entry, the incremented array X must contain the
|
||||
*> vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is REAL
|
||||
*> On entry, BETA specifies the scalar beta. When BETA is
|
||||
*> supplied as zero then Y need not be set on input.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] Y
|
||||
*> \verbatim
|
||||
*> Y is REAL array of DIMENSION at least
|
||||
*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
|
||||
*> and at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
|
||||
*> Before entry with BETA non-zero, the incremented array Y
|
||||
*> must contain the vector y. On exit, Y is overwritten by the
|
||||
*> updated vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup single_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE SGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL ALPHA,BETA
|
||||
INTEGER INCX,INCY,LDA,M,N
|
||||
CHARACTER TRANS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ONE,ZERO
|
||||
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
REAL TEMP
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (LDA.LT.MAX(1,M)) THEN
|
||||
INFO = 6
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 8
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 11
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('SGEMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
|
||||
+ ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* Set LENX and LENY, the lengths of the vectors x and y, and set
|
||||
* up the start points in X and Y.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
LENX = N
|
||||
LENY = M
|
||||
ELSE
|
||||
LENX = M
|
||||
LENY = N
|
||||
END IF
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (LENX-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (LENY-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,LENY
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,LENY
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,LENY
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,LENY
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form y := alpha*A*x + y.
|
||||
*
|
||||
JX = KX
|
||||
IF (INCY.EQ.1) THEN
|
||||
DO 60 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
DO 50 I = 1,M
|
||||
Y(I) = Y(I) + TEMP*A(I,J)
|
||||
50 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
IY = KY
|
||||
DO 70 I = 1,M
|
||||
Y(IY) = Y(IY) + TEMP*A(I,J)
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y := alpha*A**T*x + y.
|
||||
*
|
||||
JY = KY
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP = ZERO
|
||||
DO 90 I = 1,M
|
||||
TEMP = TEMP + A(I,J)*X(I)
|
||||
90 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP
|
||||
JY = JY + INCY
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
DO 120 J = 1,N
|
||||
TEMP = ZERO
|
||||
IX = KX
|
||||
DO 110 I = 1,M
|
||||
TEMP = TEMP + A(I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
110 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP
|
||||
JY = JY + INCY
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of SGEMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,227 +0,0 @@
|
|||
*> \brief \b SGER
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* REAL ALPHA
|
||||
* INTEGER INCX,INCY,LDA,M,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SGER performs the rank 1 operation
|
||||
*>
|
||||
*> A := alpha*x*y**T + A,
|
||||
*>
|
||||
*> where alpha is a scalar, x is an m element vector, y is an n element
|
||||
*> vector and A is an m by n matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of the matrix A.
|
||||
*> M must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is REAL
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is REAL array of dimension at least
|
||||
*> ( 1 + ( m - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the m
|
||||
*> element vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] Y
|
||||
*> \verbatim
|
||||
*> Y is REAL array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
*> Before entry, the incremented array Y must contain the n
|
||||
*> element vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is REAL array of DIMENSION ( LDA, n ).
|
||||
*> Before entry, the leading m by n part of the array A must
|
||||
*> contain the matrix of coefficients. On exit, A is
|
||||
*> overwritten by the updated matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup single_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL ALPHA
|
||||
INTEGER INCX,INCY,LDA,M,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ZERO
|
||||
PARAMETER (ZERO=0.0E+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
REAL TEMP
|
||||
INTEGER I,INFO,IX,J,JY,KX
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (M.LT.0) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDA.LT.MAX(1,M)) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('SGER ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
IF (INCY.GT.0) THEN
|
||||
JY = 1
|
||||
ELSE
|
||||
JY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = 1,N
|
||||
IF (Y(JY).NE.ZERO) THEN
|
||||
TEMP = ALPHA*Y(JY)
|
||||
DO 10 I = 1,M
|
||||
A(I,J) = A(I,J) + X(I)*TEMP
|
||||
10 CONTINUE
|
||||
END IF
|
||||
JY = JY + INCY
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (M-1)*INCX
|
||||
END IF
|
||||
DO 40 J = 1,N
|
||||
IF (Y(JY).NE.ZERO) THEN
|
||||
TEMP = ALPHA*Y(JY)
|
||||
IX = KX
|
||||
DO 30 I = 1,M
|
||||
A(I,J) = A(I,J) + X(IX)*TEMP
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JY = JY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of SGER .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,112 +0,0 @@
|
|||
*> \brief \b SNRM2
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* REAL FUNCTION SNRM2(N,X,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SNRM2 returns the euclidean norm of a vector via the function
|
||||
*> name, so that
|
||||
*>
|
||||
*> SNRM2 := sqrt( x'*x ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup single_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> -- This version written on 25-October-1982.
|
||||
*> Modified on 14-October-1993 to inline the call to SLASSQ.
|
||||
*> Sven Hammarling, Nag Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
REAL FUNCTION SNRM2(N,X,INCX)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ONE,ZERO
|
||||
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
REAL ABSXI,NORM,SCALE,SSQ
|
||||
INTEGER IX
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS,SQRT
|
||||
* ..
|
||||
IF (N.LT.1 .OR. INCX.LT.1) THEN
|
||||
NORM = ZERO
|
||||
ELSE IF (N.EQ.1) THEN
|
||||
NORM = ABS(X(1))
|
||||
ELSE
|
||||
SCALE = ZERO
|
||||
SSQ = ONE
|
||||
* The following loop is equivalent to this call to the LAPACK
|
||||
* auxiliary routine:
|
||||
* CALL SLASSQ( N, X, INCX, SCALE, SSQ )
|
||||
*
|
||||
DO 10 IX = 1,1 + (N-1)*INCX,INCX
|
||||
IF (X(IX).NE.ZERO) THEN
|
||||
ABSXI = ABS(X(IX))
|
||||
IF (SCALE.LT.ABSXI) THEN
|
||||
SSQ = ONE + SSQ* (SCALE/ABSXI)**2
|
||||
SCALE = ABSXI
|
||||
ELSE
|
||||
SSQ = SSQ + (ABSXI/SCALE)**2
|
||||
END IF
|
||||
END IF
|
||||
10 CONTINUE
|
||||
NORM = SCALE*SQRT(SSQ)
|
||||
END IF
|
||||
*
|
||||
SNRM2 = NORM
|
||||
RETURN
|
||||
*
|
||||
* End of SNRM2.
|
||||
*
|
||||
END
|
||||
|
|
@ -1,101 +0,0 @@
|
|||
*> \brief \b SROT
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SROT(N,SX,INCX,SY,INCY,C,S)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* REAL C,S
|
||||
* INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL SX(*),SY(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> applies a plane rotation.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup single_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE SROT(N,SX,INCX,SY,INCY,C,S)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL C,S
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL SX(*),SY(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
REAL STEMP
|
||||
INTEGER I,IX,IY
|
||||
* ..
|
||||
IF (N.LE.0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
DO I = 1,N
|
||||
STEMP = C*SX(I) + S*SY(I)
|
||||
SY(I) = C*SY(I) - S*SX(I)
|
||||
SX(I) = STEMP
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments not equal
|
||||
* to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
STEMP = C*SX(IX) + S*SY(IY)
|
||||
SY(IY) = C*SY(IY) - S*SX(IX)
|
||||
SX(IX) = STEMP
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,86 +0,0 @@
|
|||
*> \brief \b SROTG
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SROTG(SA,SB,C,S)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* REAL C,S,SA,SB
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SROTG construct givens plane rotation.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup single_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE SROTG(SA,SB,C,S)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL C,S,SA,SB
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
REAL R,ROE,SCALE,Z
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS,SIGN,SQRT
|
||||
* ..
|
||||
ROE = SB
|
||||
IF (ABS(SA).GT.ABS(SB)) ROE = SA
|
||||
SCALE = ABS(SA) + ABS(SB)
|
||||
IF (SCALE.EQ.0.0) THEN
|
||||
C = 1.0
|
||||
S = 0.0
|
||||
R = 0.0
|
||||
Z = 0.0
|
||||
ELSE
|
||||
R = SCALE*SQRT((SA/SCALE)**2+ (SB/SCALE)**2)
|
||||
R = SIGN(1.0,ROE)*R
|
||||
C = SA/R
|
||||
S = SB/R
|
||||
Z = 1.0
|
||||
IF (ABS(SA).GT.ABS(SB)) Z = S
|
||||
IF (ABS(SB).GE.ABS(SA) .AND. C.NE.0.0) Z = 1.0/C
|
||||
END IF
|
||||
SA = R
|
||||
SB = Z
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,203 +0,0 @@
|
|||
*> \brief \b SROTM
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SROTM(N,SX,INCX,SY,INCY,SPARAM)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL SPARAM(5),SX(*),SY(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX
|
||||
*>
|
||||
*> (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN
|
||||
*> (SX**T)
|
||||
*>
|
||||
*> SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE
|
||||
*> LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY.
|
||||
*> WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
|
||||
*>
|
||||
*> SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0
|
||||
*>
|
||||
*> (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0)
|
||||
*> H=( ) ( ) ( ) ( )
|
||||
*> (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0).
|
||||
*> SEE SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM.
|
||||
*>
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> number of elements in input vector(s)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] SX
|
||||
*> \verbatim
|
||||
*> SX is REAL array, dimension N
|
||||
*> double precision vector with N elements
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> storage spacing between elements of SX
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] SY
|
||||
*> \verbatim
|
||||
*> SY is REAL array, dimension N
|
||||
*> double precision vector with N elements
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> storage spacing between elements of SY
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] SPARAM
|
||||
*> \verbatim
|
||||
*> SPARAM is REAL array, dimension 5
|
||||
*> SPARAM(1)=SFLAG
|
||||
*> SPARAM(2)=SH11
|
||||
*> SPARAM(3)=SH21
|
||||
*> SPARAM(4)=SH12
|
||||
*> SPARAM(5)=SH22
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup single_blas_level1
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE SROTM(N,SX,INCX,SY,INCY,SPARAM)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL SPARAM(5),SX(*),SY(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
REAL SFLAG,SH11,SH12,SH21,SH22,TWO,W,Z,ZERO
|
||||
INTEGER I,KX,KY,NSTEPS
|
||||
* ..
|
||||
* .. Data statements ..
|
||||
DATA ZERO,TWO/0.E0,2.E0/
|
||||
* ..
|
||||
*
|
||||
SFLAG = SPARAM(1)
|
||||
IF (N.LE.0 .OR. (SFLAG+TWO.EQ.ZERO)) RETURN
|
||||
IF (INCX.EQ.INCY.AND.INCX.GT.0) THEN
|
||||
*
|
||||
NSTEPS = N*INCX
|
||||
IF (SFLAG.LT.ZERO) THEN
|
||||
SH11 = SPARAM(2)
|
||||
SH12 = SPARAM(4)
|
||||
SH21 = SPARAM(3)
|
||||
SH22 = SPARAM(5)
|
||||
DO I = 1,NSTEPS,INCX
|
||||
W = SX(I)
|
||||
Z = SY(I)
|
||||
SX(I) = W*SH11 + Z*SH12
|
||||
SY(I) = W*SH21 + Z*SH22
|
||||
END DO
|
||||
ELSE IF (SFLAG.EQ.ZERO) THEN
|
||||
SH12 = SPARAM(4)
|
||||
SH21 = SPARAM(3)
|
||||
DO I = 1,NSTEPS,INCX
|
||||
W = SX(I)
|
||||
Z = SY(I)
|
||||
SX(I) = W + Z*SH12
|
||||
SY(I) = W*SH21 + Z
|
||||
END DO
|
||||
ELSE
|
||||
SH11 = SPARAM(2)
|
||||
SH22 = SPARAM(5)
|
||||
DO I = 1,NSTEPS,INCX
|
||||
W = SX(I)
|
||||
Z = SY(I)
|
||||
SX(I) = W*SH11 + Z
|
||||
SY(I) = -W + SH22*Z
|
||||
END DO
|
||||
END IF
|
||||
ELSE
|
||||
KX = 1
|
||||
KY = 1
|
||||
IF (INCX.LT.0) KX = 1 + (1-N)*INCX
|
||||
IF (INCY.LT.0) KY = 1 + (1-N)*INCY
|
||||
*
|
||||
IF (SFLAG.LT.ZERO) THEN
|
||||
SH11 = SPARAM(2)
|
||||
SH12 = SPARAM(4)
|
||||
SH21 = SPARAM(3)
|
||||
SH22 = SPARAM(5)
|
||||
DO I = 1,N
|
||||
W = SX(KX)
|
||||
Z = SY(KY)
|
||||
SX(KX) = W*SH11 + Z*SH12
|
||||
SY(KY) = W*SH21 + Z*SH22
|
||||
KX = KX + INCX
|
||||
KY = KY + INCY
|
||||
END DO
|
||||
ELSE IF (SFLAG.EQ.ZERO) THEN
|
||||
SH12 = SPARAM(4)
|
||||
SH21 = SPARAM(3)
|
||||
DO I = 1,N
|
||||
W = SX(KX)
|
||||
Z = SY(KY)
|
||||
SX(KX) = W + Z*SH12
|
||||
SY(KY) = W*SH21 + Z
|
||||
KX = KX + INCX
|
||||
KY = KY + INCY
|
||||
END DO
|
||||
ELSE
|
||||
SH11 = SPARAM(2)
|
||||
SH22 = SPARAM(5)
|
||||
DO I = 1,N
|
||||
W = SX(KX)
|
||||
Z = SY(KY)
|
||||
SX(KX) = W*SH11 + Z
|
||||
SY(KY) = -W + SH22*Z
|
||||
KX = KX + INCX
|
||||
KY = KY + INCY
|
||||
END DO
|
||||
END IF
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,251 +0,0 @@
|
|||
*> \brief \b SROTMG
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* REAL SD1,SD2,SX1,SY1
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL SPARAM(5)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
|
||||
*> THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)*> SY2)**T.
|
||||
*> WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
|
||||
*>
|
||||
*> SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0
|
||||
*>
|
||||
*> (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0)
|
||||
*> H=( ) ( ) ( ) ( )
|
||||
*> (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0).
|
||||
*> LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22
|
||||
*> RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE
|
||||
*> VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.)
|
||||
*>
|
||||
*> THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
|
||||
*> INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
|
||||
*> OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
|
||||
*>
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in,out] SD1
|
||||
*> \verbatim
|
||||
*> SD1 is REAL
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] SD2
|
||||
*> \verbatim
|
||||
*> SD2 is REAL
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] SX1
|
||||
*> \verbatim
|
||||
*> SX1 is REAL
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] SY1
|
||||
*> \verbatim
|
||||
*> SY1 is REAL
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] SPARAM
|
||||
*> \verbatim
|
||||
*> SPARAM is REAL array, dimension 5
|
||||
*> SPARAM(1)=SFLAG
|
||||
*> SPARAM(2)=SH11
|
||||
*> SPARAM(3)=SH21
|
||||
*> SPARAM(4)=SH12
|
||||
*> SPARAM(5)=SH22
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup single_blas_level1
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL SD1,SD2,SX1,SY1
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL SPARAM(5)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
REAL GAM,GAMSQ,ONE,RGAMSQ,SFLAG,SH11,SH12,SH21,SH22,SP1,SP2,SQ1,
|
||||
$ SQ2,STEMP,SU,TWO,ZERO
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS
|
||||
* ..
|
||||
* .. Data statements ..
|
||||
*
|
||||
DATA ZERO,ONE,TWO/0.E0,1.E0,2.E0/
|
||||
DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/
|
||||
* ..
|
||||
|
||||
IF (SD1.LT.ZERO) THEN
|
||||
* GO ZERO-H-D-AND-SX1..
|
||||
SFLAG = -ONE
|
||||
SH11 = ZERO
|
||||
SH12 = ZERO
|
||||
SH21 = ZERO
|
||||
SH22 = ZERO
|
||||
*
|
||||
SD1 = ZERO
|
||||
SD2 = ZERO
|
||||
SX1 = ZERO
|
||||
ELSE
|
||||
* CASE-SD1-NONNEGATIVE
|
||||
SP2 = SD2*SY1
|
||||
IF (SP2.EQ.ZERO) THEN
|
||||
SFLAG = -TWO
|
||||
SPARAM(1) = SFLAG
|
||||
RETURN
|
||||
END IF
|
||||
* REGULAR-CASE..
|
||||
SP1 = SD1*SX1
|
||||
SQ2 = SP2*SY1
|
||||
SQ1 = SP1*SX1
|
||||
*
|
||||
IF (ABS(SQ1).GT.ABS(SQ2)) THEN
|
||||
SH21 = -SY1/SX1
|
||||
SH12 = SP2/SP1
|
||||
*
|
||||
SU = ONE - SH12*SH21
|
||||
*
|
||||
IF (SU.GT.ZERO) THEN
|
||||
SFLAG = ZERO
|
||||
SD1 = SD1/SU
|
||||
SD2 = SD2/SU
|
||||
SX1 = SX1*SU
|
||||
END IF
|
||||
ELSE
|
||||
|
||||
IF (SQ2.LT.ZERO) THEN
|
||||
* GO ZERO-H-D-AND-SX1..
|
||||
SFLAG = -ONE
|
||||
SH11 = ZERO
|
||||
SH12 = ZERO
|
||||
SH21 = ZERO
|
||||
SH22 = ZERO
|
||||
*
|
||||
SD1 = ZERO
|
||||
SD2 = ZERO
|
||||
SX1 = ZERO
|
||||
ELSE
|
||||
SFLAG = ONE
|
||||
SH11 = SP1/SP2
|
||||
SH22 = SX1/SY1
|
||||
SU = ONE + SH11*SH22
|
||||
STEMP = SD2/SU
|
||||
SD2 = SD1/SU
|
||||
SD1 = STEMP
|
||||
SX1 = SY1*SU
|
||||
END IF
|
||||
END IF
|
||||
|
||||
* PROCESURE..SCALE-CHECK
|
||||
IF (SD1.NE.ZERO) THEN
|
||||
DO WHILE ((SD1.LE.RGAMSQ) .OR. (SD1.GE.GAMSQ))
|
||||
IF (SFLAG.EQ.ZERO) THEN
|
||||
SH11 = ONE
|
||||
SH22 = ONE
|
||||
SFLAG = -ONE
|
||||
ELSE
|
||||
SH21 = -ONE
|
||||
SH12 = ONE
|
||||
SFLAG = -ONE
|
||||
END IF
|
||||
IF (SD1.LE.RGAMSQ) THEN
|
||||
SD1 = SD1*GAM**2
|
||||
SX1 = SX1/GAM
|
||||
SH11 = SH11/GAM
|
||||
SH12 = SH12/GAM
|
||||
ELSE
|
||||
SD1 = SD1/GAM**2
|
||||
SX1 = SX1*GAM
|
||||
SH11 = SH11*GAM
|
||||
SH12 = SH12*GAM
|
||||
END IF
|
||||
ENDDO
|
||||
END IF
|
||||
|
||||
IF (SD2.NE.ZERO) THEN
|
||||
DO WHILE ( (ABS(SD2).LE.RGAMSQ) .OR. (ABS(SD2).GE.GAMSQ) )
|
||||
IF (SFLAG.EQ.ZERO) THEN
|
||||
SH11 = ONE
|
||||
SH22 = ONE
|
||||
SFLAG = -ONE
|
||||
ELSE
|
||||
SH21 = -ONE
|
||||
SH12 = ONE
|
||||
SFLAG = -ONE
|
||||
END IF
|
||||
IF (ABS(SD2).LE.RGAMSQ) THEN
|
||||
SD2 = SD2*GAM**2
|
||||
SH21 = SH21/GAM
|
||||
SH22 = SH22/GAM
|
||||
ELSE
|
||||
SD2 = SD2/GAM**2
|
||||
SH21 = SH21*GAM
|
||||
SH22 = SH22*GAM
|
||||
END IF
|
||||
END DO
|
||||
END IF
|
||||
|
||||
END IF
|
||||
|
||||
IF (SFLAG.LT.ZERO) THEN
|
||||
SPARAM(2) = SH11
|
||||
SPARAM(3) = SH21
|
||||
SPARAM(4) = SH12
|
||||
SPARAM(5) = SH22
|
||||
ELSE IF (SFLAG.EQ.ZERO) THEN
|
||||
SPARAM(3) = SH21
|
||||
SPARAM(4) = SH12
|
||||
ELSE
|
||||
SPARAM(2) = SH11
|
||||
SPARAM(5) = SH22
|
||||
END IF
|
||||
|
||||
SPARAM(1) = SFLAG
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,375 +0,0 @@
|
|||
*> \brief \b SSBMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* REAL ALPHA,BETA
|
||||
* INTEGER INCX,INCY,K,LDA,N
|
||||
* CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SSBMV performs the matrix-vector operation
|
||||
*>
|
||||
*> y := alpha*A*x + beta*y,
|
||||
*>
|
||||
*> where alpha and beta are scalars, x and y are n element vectors and
|
||||
*> A is an n by n symmetric band matrix, with k super-diagonals.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the band matrix A is being supplied as
|
||||
*> follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' The upper triangular part of A is
|
||||
*> being supplied.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' The lower triangular part of A is
|
||||
*> being supplied.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> On entry, K specifies the number of super-diagonals of the
|
||||
*> matrix A. K must satisfy 0 .le. K.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is REAL
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is REAL array of DIMENSION ( LDA, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
|
||||
*> by n part of the array A must contain the upper triangular
|
||||
*> band part of the symmetric matrix, supplied column by
|
||||
*> column, with the leading diagonal of the matrix in row
|
||||
*> ( k + 1 ) of the array, the first super-diagonal starting at
|
||||
*> position 2 in row k, and so on. The top left k by k triangle
|
||||
*> of the array A is not referenced.
|
||||
*> The following program segment will transfer the upper
|
||||
*> triangular part of a symmetric band matrix from conventional
|
||||
*> full matrix storage to band storage:
|
||||
*>
|
||||
*> DO 20, J = 1, N
|
||||
*> M = K + 1 - J
|
||||
*> DO 10, I = MAX( 1, J - K ), J
|
||||
*> A( M + I, J ) = matrix( I, J )
|
||||
*> 10 CONTINUE
|
||||
*> 20 CONTINUE
|
||||
*>
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
|
||||
*> by n part of the array A must contain the lower triangular
|
||||
*> band part of the symmetric matrix, supplied column by
|
||||
*> column, with the leading diagonal of the matrix in row 1 of
|
||||
*> the array, the first sub-diagonal starting at position 1 in
|
||||
*> row 2, and so on. The bottom right k by k triangle of the
|
||||
*> array A is not referenced.
|
||||
*> The following program segment will transfer the lower
|
||||
*> triangular part of a symmetric band matrix from conventional
|
||||
*> full matrix storage to band storage:
|
||||
*>
|
||||
*> DO 20, J = 1, N
|
||||
*> M = 1 - J
|
||||
*> DO 10, I = J, MIN( N, J + K )
|
||||
*> A( M + I, J ) = matrix( I, J )
|
||||
*> 10 CONTINUE
|
||||
*> 20 CONTINUE
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> ( k + 1 ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is REAL array of DIMENSION at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the
|
||||
*> vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is REAL
|
||||
*> On entry, BETA specifies the scalar beta.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] Y
|
||||
*> \verbatim
|
||||
*> Y is REAL array of DIMENSION at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
*> Before entry, the incremented array Y must contain the
|
||||
*> vector y. On exit, Y is overwritten by the updated vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup single_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE SSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL ALPHA,BETA
|
||||
INTEGER INCX,INCY,K,LDA,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ONE,ZERO
|
||||
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
REAL TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,KPLUS1,KX,KY,L
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX,MIN
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (LDA.LT. (K+1)) THEN
|
||||
INFO = 6
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 8
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 11
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('SSBMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* Set up the start points in X and Y.
|
||||
*
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (N-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of the array A
|
||||
* are accessed sequentially with one pass through A.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,N
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,N
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,N
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,N
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form y when upper triangle of A is stored.
|
||||
*
|
||||
KPLUS1 = K + 1
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 60 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
L = KPLUS1 - J
|
||||
DO 50 I = MAX(1,J-K),J - 1
|
||||
Y(I) = Y(I) + TEMP1*A(L+I,J)
|
||||
TEMP2 = TEMP2 + A(L+I,J)*X(I)
|
||||
50 CONTINUE
|
||||
Y(J) = Y(J) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 80 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
IX = KX
|
||||
IY = KY
|
||||
L = KPLUS1 - J
|
||||
DO 70 I = MAX(1,J-K),J - 1
|
||||
Y(IY) = Y(IY) + TEMP1*A(L+I,J)
|
||||
TEMP2 = TEMP2 + A(L+I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
Y(JY) = Y(JY) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
IF (J.GT.K) THEN
|
||||
KX = KX + INCX
|
||||
KY = KY + INCY
|
||||
END IF
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y when lower triangle of A is stored.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
Y(J) = Y(J) + TEMP1*A(1,J)
|
||||
L = 1 - J
|
||||
DO 90 I = J + 1,MIN(N,J+K)
|
||||
Y(I) = Y(I) + TEMP1*A(L+I,J)
|
||||
TEMP2 = TEMP2 + A(L+I,J)*X(I)
|
||||
90 CONTINUE
|
||||
Y(J) = Y(J) + ALPHA*TEMP2
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 120 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
Y(JY) = Y(JY) + TEMP1*A(1,J)
|
||||
L = 1 - J
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 110 I = J + 1,MIN(N,J+K)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
Y(IY) = Y(IY) + TEMP1*A(L+I,J)
|
||||
TEMP2 = TEMP2 + A(L+I,J)*X(IX)
|
||||
110 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of SSBMV .
|
||||
*
|
||||
END
|
||||
|
|
@ -1,110 +0,0 @@
|
|||
*> \brief \b SSCAL
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SSCAL(N,SA,SX,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* REAL SA
|
||||
* INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL SX(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> scales a vector by a constant.
|
||||
*> uses unrolled loops for increment equal to 1.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup single_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 3/11/78.
|
||||
*> modified 3/93 to return if incx .le. 0.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE SSCAL(N,SA,SX,INCX)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL SA
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL SX(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I,M,MP1,NINCX
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD
|
||||
* ..
|
||||
IF (N.LE.0 .OR. INCX.LE.0) RETURN
|
||||
IF (INCX.EQ.1) THEN
|
||||
*
|
||||
* code for increment equal to 1
|
||||
*
|
||||
*
|
||||
* clean-up loop
|
||||
*
|
||||
M = MOD(N,5)
|
||||
IF (M.NE.0) THEN
|
||||
DO I = 1,M
|
||||
SX(I) = SA*SX(I)
|
||||
END DO
|
||||
IF (N.LT.5) RETURN
|
||||
END IF
|
||||
MP1 = M + 1
|
||||
DO I = MP1,N,5
|
||||
SX(I) = SA*SX(I)
|
||||
SX(I+1) = SA*SX(I+1)
|
||||
SX(I+2) = SA*SX(I+2)
|
||||
SX(I+3) = SA*SX(I+3)
|
||||
SX(I+4) = SA*SX(I+4)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for increment not equal to 1
|
||||
*
|
||||
NINCX = N*INCX
|
||||
DO I = 1,NINCX,INCX
|
||||
SX(I) = SA*SX(I)
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -1,331 +0,0 @@
|
|||
*> \brief \b SSPMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* REAL ALPHA,BETA
|
||||
* INTEGER INCX,INCY,N
|
||||
* CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL AP(*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SSPMV performs the matrix-vector operation
|
||||
*>
|
||||
*> y := alpha*A*x + beta*y,
|
||||
*>
|
||||
*> where alpha and beta are scalars, x and y are n element vectors and
|
||||
*> A is an n by n symmetric matrix, supplied in packed form.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the matrix A is supplied in the packed
|
||||
*> array AP as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' The upper triangular part of A is
|
||||
*> supplied in AP.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' The lower triangular part of A is
|
||||
*> supplied in AP.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is REAL
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] AP
|
||||
*> \verbatim
|
||||
*> AP is REAL array of DIMENSION at least
|
||||
*> ( ( n*( n + 1 ) )/2 ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the array AP must
|
||||
*> contain the upper triangular part of the symmetric matrix
|
||||
*> packed sequentially, column by column, so that AP( 1 )
|
||||
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
|
||||
*> and a( 2, 2 ) respectively, and so on.
|
||||
*> Before entry with UPLO = 'L' or 'l', the array AP must
|
||||
*> contain the lower triangular part of the symmetric matrix
|
||||
*> packed sequentially, column by column, so that AP( 1 )
|
||||
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
|
||||
*> and a( 3, 1 ) respectively, and so on.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is REAL array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is REAL
|
||||
*> On entry, BETA specifies the scalar beta. When BETA is
|
||||
*> supplied as zero then Y need not be set on input.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] Y
|
||||
*> \verbatim
|
||||
*> Y is REAL array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
*> Before entry, the incremented array Y must contain the n
|
||||
*> element vector y. On exit, Y is overwritten by the updated
|
||||
*> vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup single_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE SSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL ALPHA,BETA
|
||||
INTEGER INCX,INCY,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL AP(*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ONE,ZERO
|
||||
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
REAL TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 6
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('SSPMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* Set up the start points in X and Y.
|
||||
*
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (N-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of the array AP
|
||||
* are accessed sequentially with one pass through AP.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,N
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,N
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,N
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,N
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
KK = 1
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form y when AP contains the upper triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 60 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
K = KK
|
||||
DO 50 I = 1,J - 1
|
||||
Y(I) = Y(I) + TEMP1*AP(K)
|
||||
TEMP2 = TEMP2 + AP(K)*X(I)
|
||||
K = K + 1
|
||||
50 CONTINUE
|
||||
Y(J) = Y(J) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2
|
||||
KK = KK + J
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 80 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
IX = KX
|
||||
IY = KY
|
||||
DO 70 K = KK,KK + J - 2
|
||||
Y(IY) = Y(IY) + TEMP1*AP(K)
|
||||
TEMP2 = TEMP2 + AP(K)*X(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
Y(JY) = Y(JY) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
KK = KK + J
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y when AP contains the lower triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
Y(J) = Y(J) + TEMP1*AP(KK)
|
||||
K = KK + 1
|
||||
DO 90 I = J + 1,N
|
||||
Y(I) = Y(I) + TEMP1*AP(K)
|
||||
TEMP2 = TEMP2 + AP(K)*X(I)
|
||||
K = K + 1
|
||||
90 CONTINUE
|
||||
Y(J) = Y(J) + ALPHA*TEMP2
|
||||
KK = KK + (N-J+1)
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 120 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
Y(JY) = Y(JY) + TEMP1*AP(KK)
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 110 K = KK + 1,KK + N - J
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
Y(IY) = Y(IY) + TEMP1*AP(K)
|
||||
TEMP2 = TEMP2 + AP(K)*X(IX)
|
||||
110 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
KK = KK + (N-J+1)
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of SSPMV .
|
||||
*
|
||||
END
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue