commit
1ea0e7ad7b
6601 changed files with 1873459 additions and 0 deletions
@ -0,0 +1,36 @@ |
||||
image: |
||||
- Visual Studio 2017 |
||||
|
||||
configuration: Release |
||||
clone_depth: 3 |
||||
|
||||
matrix: |
||||
fast_finish: false |
||||
|
||||
skip_commits: |
||||
# Add [av skip] to commit messages |
||||
message: /\[av skip\]/ |
||||
|
||||
environment: |
||||
global: |
||||
CONDA_INSTALL_LOCN: C:\\Miniconda37-x64 |
||||
CTEST_OUTPUT_ON_FAILURE: 1 |
||||
|
||||
install: |
||||
- call %CONDA_INSTALL_LOCN%\Scripts\activate.bat |
||||
# - conda config --set auto_update_conda false |
||||
- conda install -c conda-forge --yes --quiet flang jom |
||||
- call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\vcvarsall.bat" amd64 |
||||
- set "LIB=%CONDA_INSTALL_LOCN%\Library\lib;%LIB%" |
||||
- set "CPATH=%CONDA_INSTALL_LOCN%\Library\include;%CPATH%" |
||||
|
||||
before_build: |
||||
- ps: if (-Not (Test-Path .\build)) { mkdir build } |
||||
- cd build |
||||
- cmake -G "NMake Makefiles JOM" -DCMAKE_Fortran_COMPILER=flang -DCMAKE_BUILD_TYPE=Release -DBUILD_TESTING=ON .. |
||||
|
||||
build_script: |
||||
- cmake --build . |
||||
|
||||
test_script: |
||||
- ctest -j2 |
||||
@ -0,0 +1,77 @@ |
||||
language: c |
||||
dist: xenial |
||||
group: travis_latest |
||||
|
||||
git: |
||||
depth: 3 |
||||
quiet: true |
||||
|
||||
addons: |
||||
apt: |
||||
packages: |
||||
- gfortran |
||||
|
||||
matrix: |
||||
include: |
||||
- os: linux |
||||
name: "CMake Release Test on Linux" |
||||
env: CMAKE_BUILD_TYPE=Release |
||||
- os: linux |
||||
name: "Makefile Test on Linux" |
||||
script: |
||||
- rm -f make.inc |
||||
- cp make.inc.example make.inc |
||||
- make FFLAGS="-fimplicit-none -frecursive -fcheck=all" -s -j2 all |
||||
- make -j2 lapack_install |
||||
- os: linux |
||||
name: "CMake Coverage Test on Linux" |
||||
env: CMAKE_BUILD_TYPE=Coverage |
||||
- os: osx |
||||
name: "CMake Release Test on macOS Big Sur" |
||||
osx_image: xcode12.3 |
||||
env: CMAKE_BUILD_TYPE=Release |
||||
- os: osx |
||||
osx_image: xcode12.3 |
||||
name: "Makefile Test on on macOS Big Sur" |
||||
script: |
||||
- rm -f make.inc |
||||
- cp make.inc.example make.inc |
||||
- make FFLAGS="-fimplicit-none -frecursive -fcheck=all" -s -j2 all |
||||
- make -j2 lapack_install |
||||
|
||||
before_script: |
||||
- export PR=https://api.github.com/repos/$TRAVIS_REPO_SLUG/pulls/$TRAVIS_PULL_REQUEST |
||||
- export BRANCH=$(if [ "$TRAVIS_PULL_REQUEST" == "false" ]; then echo $TRAVIS_BRANCH; else echo `curl -s $PR | jq -r .head.ref`; fi) |
||||
- echo "TRAVIS_BRANCH=$TRAVIS_BRANCH, PR=$PR, BRANCH=$BRANCH" |
||||
|
||||
script: |
||||
- export SRC_DIR=$(pwd) |
||||
- export BLD_DIR=${SRC_DIR}/lapack-travis-bld |
||||
- export INST_DIR=${SRC_DIR}/../lapack-travis-install |
||||
- mkdir -p ${BLD_DIR} |
||||
- cd ${BLD_DIR} |
||||
# See issue #17 on github dashboard. Once resolved, use -DCBLAS=ON |
||||
# - cmake -DCMAKE_INSTALL_PREFIX=${INST_DIR} -DLAPACKE=ON ${SRC_DIR} |
||||
- cmake -DBUILDNAME:STRING="travis-${TRAVIS_OS_NAME}-${BRANCH}" |
||||
-DCMAKE_BUILD_TYPE=${CMAKE_BUILD_TYPE} |
||||
-DCMAKE_INSTALL_PREFIX=${INST_DIR} |
||||
-DCBLAS:BOOL=ON |
||||
-DLAPACKE:BOOL=ON |
||||
-DBUILD_TESTING=ON |
||||
-DLAPACKE_WITH_TMG:BOOL=ON |
||||
-DBUILD_SHARED_LIBS:BOOL=ON |
||||
-DCMAKE_Fortran_FLAGS:STRING="-fimplicit-none -frecursive -fcheck=all" |
||||
-DCMAKE_C_FLAGS=${CMAKE_C_FLAGS} |
||||
${SRC_DIR} |
||||
- ctest -D ExperimentalStart |
||||
- ctest -D ExperimentalConfigure |
||||
- ctest -D ExperimentalBuild -j2 |
||||
- ctest -D ExperimentalTest --schedule-random -j2 --output-on-failure --timeout 100 |
||||
- ctest -D ExperimentalSubmit |
||||
- make install -j2 |
||||
- if [[ "$CMAKE_BUILD_TYPE" == "Coverage" ]]; |
||||
then |
||||
echo "Coverage"; |
||||
make coverage; |
||||
bash <(curl -s https://codecov.io/bash) -X gcov; |
||||
fi |
||||
@ -0,0 +1,10 @@ |
||||
add_subdirectory(SRC) |
||||
if(BUILD_TESTING) |
||||
add_subdirectory(TESTING) |
||||
endif() |
||||
configure_file(${CMAKE_CURRENT_SOURCE_DIR}/blas.pc.in ${CMAKE_CURRENT_BINARY_DIR}/${BLASLIB}.pc @ONLY) |
||||
install(FILES |
||||
${CMAKE_CURRENT_BINARY_DIR}/${BLASLIB}.pc |
||||
DESTINATION ${PKG_CONFIG_DIR} |
||||
COMPONENT Development |
||||
) |
||||
@ -0,0 +1,27 @@ |
||||
TOPSRCDIR = ..
|
||||
include $(TOPSRCDIR)/make.inc |
||||
|
||||
.PHONY: all |
||||
all: blas |
||||
|
||||
.PHONY: blas |
||||
blas: |
||||
$(MAKE) -C SRC
|
||||
|
||||
.PHONY: blas_testing |
||||
blas_testing: blas |
||||
$(MAKE) -C TESTING run
|
||||
|
||||
.PHONY: clean cleanobj cleanlib cleanexe cleantest |
||||
clean: |
||||
$(MAKE) -C SRC clean
|
||||
$(MAKE) -C TESTING clean
|
||||
cleanobj: |
||||
$(MAKE) -C SRC cleanobj
|
||||
$(MAKE) -C TESTING cleanobj
|
||||
cleanlib: |
||||
$(MAKE) -C SRC cleanlib
|
||||
cleanexe: |
||||
$(MAKE) -C TESTING cleanexe
|
||||
cleantest: |
||||
$(MAKE) -C TESTING cleantest
|
||||
@ -0,0 +1,122 @@ |
||||
####################################################################### |
||||
# 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 |
||||
# |
||||
####################################################################### |
||||
|
||||
#--------------------------------------------------------- |
||||
# Level 1 BLAS |
||||
#--------------------------------------------------------- |
||||
|
||||
set(SBLAS1 isamax.f sasum.f saxpy.f scopy.f sdot.f snrm2.f90 |
||||
srot.f srotg.f90 sscal.f sswap.f sdsdot.f srotmg.f srotm.f) |
||||
|
||||
set(CBLAS1 scabs1.f scasum.f scnrm2.f90 icamax.f caxpy.f ccopy.f |
||||
cdotc.f cdotu.f csscal.f crotg.f90 cscal.f cswap.f csrot.f) |
||||
|
||||
set(DBLAS1 idamax.f dasum.f daxpy.f dcopy.f ddot.f dnrm2.f90 |
||||
drot.f drotg.f90 dscal.f dsdot.f dswap.f drotmg.f drotm.f) |
||||
|
||||
set(DB1AUX sscal.f isamax.f) |
||||
|
||||
set(ZBLAS1 dcabs1.f dzasum.f dznrm2.f90 izamax.f zaxpy.f zcopy.f |
||||
zdotc.f zdotu.f zdscal.f zrotg.f90 zscal.f zswap.f zdrot.f) |
||||
|
||||
set(CB1AUX |
||||
isamax.f idamax.f |
||||
sasum.f saxpy.f scopy.f sdot.f sgemm.f sgemv.f snrm2.f90 srot.f sscal.f |
||||
sswap.f) |
||||
|
||||
set(ZB1AUX |
||||
icamax.f idamax.f |
||||
cgemm.f cherk.f cscal.f ctrsm.f |
||||
dasum.f daxpy.f dcopy.f ddot.f dgemm.f dgemv.f dnrm2.f90 drot.f dscal.f |
||||
dswap.f |
||||
scabs1.f) |
||||
|
||||
#--------------------------------------------------------------------- |
||||
# Auxiliary routines needed by both the Level 2 and Level 3 BLAS |
||||
#--------------------------------------------------------------------- |
||||
set(ALLBLAS lsame.f xerbla.f xerbla_array.f) |
||||
|
||||
#--------------------------------------------------------- |
||||
# 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) |
||||
|
||||
#--------------------------------------------------------- |
||||
# 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) |
||||
|
||||
|
||||
set(SOURCES) |
||||
if(BUILD_SINGLE) |
||||
list(APPEND SOURCES ${SBLAS1} ${ALLBLAS} ${SBLAS2} ${SBLAS3}) |
||||
endif() |
||||
if(BUILD_DOUBLE) |
||||
list(APPEND SOURCES |
||||
${DBLAS1} ${DB1AUX} ${ALLBLAS} ${DBLAS2} ${DBLAS3} ${SBLAS3}) |
||||
endif() |
||||
if(BUILD_COMPLEX) |
||||
list(APPEND SOURCES ${CBLAS1} ${CB1AUX} ${ALLBLAS} ${CBLAS2} ${CBLAS3}) |
||||
endif() |
||||
if(BUILD_COMPLEX16) |
||||
list(APPEND SOURCES ${ZBLAS1} ${ZB1AUX} ${ALLBLAS} ${ZBLAS2} ${ZBLAS3}) |
||||
endif() |
||||
list(REMOVE_DUPLICATES SOURCES) |
||||
|
||||
add_library(${BLASLIB} ${SOURCES}) |
||||
set_target_properties( |
||||
${BLASLIB} PROPERTIES |
||||
VERSION ${LAPACK_VERSION} |
||||
SOVERSION ${LAPACK_MAJOR_VERSION} |
||||
) |
||||
lapack_install_library(${BLASLIB}) |
||||
|
||||
if( TEST_FORTRAN_COMPILER ) |
||||
add_dependencies( ${BLASLIB} run_test_zcomplexabs run_test_zcomplexdiv run_test_zcomplexmult run_test_zminMax ) |
||||
endif() |
||||
@ -0,0 +1,177 @@ |
||||
#######################################################################
|
||||
# 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 cleanobj
|
||||
# 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.
|
||||
#
|
||||
#######################################################################
|
||||
|
||||
TOPSRCDIR = ../..
|
||||
include $(TOPSRCDIR)/make.inc |
||||
|
||||
.SUFFIXES: .F .f90 .o |
||||
.F.o: |
||||
$(FC) $(FFLAGS) -c -o $@ $<
|
||||
.f90.o: |
||||
$(FC) $(FFLAGS) -c -o $@ $<
|
||||
|
||||
.PHONY: all |
||||
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) |
||||
$(AR) $(ARFLAGS) $@ $^
|
||||
$(RANLIB) $@
|
||||
|
||||
.PHONY: single double complex complex16 |
||||
single: $(SBLAS1) $(ALLBLAS) $(SBLAS2) $(SBLAS3) |
||||
$(AR) $(ARFLAGS) $(BLASLIB) $^
|
||||
$(RANLIB) $(BLASLIB)
|
||||
|
||||
double: $(DBLAS1) $(ALLBLAS) $(DBLAS2) $(DBLAS3) |
||||
$(AR) $(ARFLAGS) $(BLASLIB) $^
|
||||
$(RANLIB) $(BLASLIB)
|
||||
|
||||
complex: $(CBLAS1) $(CB1AUX) $(ALLBLAS) $(CBLAS2) $(CBLAS3) |
||||
$(AR) $(ARFLAGS) $(BLASLIB) $^
|
||||
$(RANLIB) $(BLASLIB)
|
||||
|
||||
complex16: $(ZBLAS1) $(ZB1AUX) $(ALLBLAS) $(ZBLAS2) $(ZBLAS3) |
||||
$(AR) $(ARFLAGS) $(BLASLIB) $^
|
||||
$(RANLIB) $(BLASLIB)
|
||||
|
||||
FRC: |
||||
@FRC=$(FRC)
|
||||
|
||||
.PHONY: clean cleanobj cleanlib |
||||
clean: cleanobj cleanlib |
||||
cleanobj: |
||||
rm -f *.o
|
||||
cleanlib: |
||||
#rm -f $(BLASLIB) # May point to a system lib, e.g. -lblas
|
||||
@ -0,0 +1,139 @@ |
||||
*> \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 |
||||
* |
||||
* Arguments: |
||||
* ========== |
||||
* |
||||
*> \param[in] N |
||||
*> \verbatim |
||||
*> N is INTEGER |
||||
*> number of elements in input vector(s) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] CA |
||||
*> \verbatim |
||||
*> CA is COMPLEX |
||||
*> On entry, CA specifies the scalar alpha. |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] CX |
||||
*> \verbatim |
||||
*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCX |
||||
*> \verbatim |
||||
*> INCX is INTEGER |
||||
*> storage spacing between elements of CX |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in,out] CY |
||||
*> \verbatim |
||||
*> CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCY |
||||
*> \verbatim |
||||
*> INCY is INTEGER |
||||
*> storage spacing between elements of CY |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of CAXPY |
||||
* |
||||
END |
||||
@ -0,0 +1,125 @@ |
||||
*> \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 |
||||
* |
||||
* Arguments: |
||||
* ========== |
||||
* |
||||
*> \param[in] N |
||||
*> \verbatim |
||||
*> N is INTEGER |
||||
*> number of elements in input vector(s) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] CX |
||||
*> \verbatim |
||||
*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCX |
||||
*> \verbatim |
||||
*> INCX is INTEGER |
||||
*> storage spacing between elements of CX |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[out] CY |
||||
*> \verbatim |
||||
*> CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCY |
||||
*> \verbatim |
||||
*> INCY is INTEGER |
||||
*> storage spacing between elements of CY |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of CCOPY |
||||
* |
||||
END |
||||
@ -0,0 +1,134 @@ |
||||
*> \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 |
||||
*> |
||||
*> CDOTC forms the dot product of two complex vectors |
||||
*> CDOTC = X^H * Y |
||||
*> |
||||
*> \endverbatim |
||||
* |
||||
* Arguments: |
||||
* ========== |
||||
* |
||||
*> \param[in] N |
||||
*> \verbatim |
||||
*> N is INTEGER |
||||
*> number of elements in input vector(s) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] CX |
||||
*> \verbatim |
||||
*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCX |
||||
*> \verbatim |
||||
*> INCX is INTEGER |
||||
*> storage spacing between elements of CX |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] CY |
||||
*> \verbatim |
||||
*> CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCY |
||||
*> \verbatim |
||||
*> INCY is INTEGER |
||||
*> storage spacing between elements of CY |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of CDOTC |
||||
* |
||||
END |
||||
@ -0,0 +1,131 @@ |
||||
*> \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 complex vectors |
||||
*> CDOTU = X^T * Y |
||||
*> |
||||
*> \endverbatim |
||||
* |
||||
* Arguments: |
||||
* ========== |
||||
* |
||||
*> \param[in] N |
||||
*> \verbatim |
||||
*> N is INTEGER |
||||
*> number of elements in input vector(s) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] CX |
||||
*> \verbatim |
||||
*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCX |
||||
*> \verbatim |
||||
*> INCX is INTEGER |
||||
*> storage spacing between elements of CX |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] CY |
||||
*> \verbatim |
||||
*> CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCY |
||||
*> \verbatim |
||||
*> INCY is INTEGER |
||||
*> storage spacing between elements of CY |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of CDOTU |
||||
* |
||||
END |
||||
@ -0,0 +1,387 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
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 |
||||
JX = JX + INCX |
||||
60 CONTINUE |
||||
ELSE |
||||
DO 80 J = 1,N |
||||
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 |
||||
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 |
||||
@ -0,0 +1,477 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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,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 and NROWB as the number of rows of A and B respectively. |
||||
* |
||||
NOTA = LSAME(TRANSA,'N') |
||||
NOTB = LSAME(TRANSB,'N') |
||||
CONJA = LSAME(TRANSA,'C') |
||||
CONJB = LSAME(TRANSB,'C') |
||||
IF (NOTA) THEN |
||||
NROWA = M |
||||
ELSE |
||||
NROWA = K |
||||
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 |
||||
TEMP = ALPHA*B(L,J) |
||||
DO 70 I = 1,M |
||||
C(I,J) = C(I,J) + TEMP*A(I,L) |
||||
70 CONTINUE |
||||
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 |
||||
TEMP = ALPHA*CONJG(B(J,L)) |
||||
DO 180 I = 1,M |
||||
C(I,J) = C(I,J) + TEMP*A(I,L) |
||||
180 CONTINUE |
||||
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 |
||||
TEMP = ALPHA*B(J,L) |
||||
DO 230 I = 1,M |
||||
C(I,J) = C(I,J) + TEMP*A(I,L) |
||||
230 CONTINUE |
||||
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 |
||||
@ -0,0 +1,347 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
TEMP = ALPHA*X(JX) |
||||
DO 50 I = 1,M |
||||
Y(I) = Y(I) + TEMP*A(I,J) |
||||
50 CONTINUE |
||||
JX = JX + INCX |
||||
60 CONTINUE |
||||
ELSE |
||||
DO 80 J = 1,N |
||||
TEMP = ALPHA*X(JX) |
||||
IY = KY |
||||
DO 70 I = 1,M |
||||
Y(IY) = Y(IY) + TEMP*A(I,J) |
||||
IY = IY + INCY |
||||
70 CONTINUE |
||||
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 |
||||
@ -0,0 +1,224 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,224 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,377 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,368 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,334 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,275 @@ |
||||
*> \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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,314 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,439 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,393 @@ |
||||
*> \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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 + REAL(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 + REAL(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 |
||||
@ -0,0 +1,335 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,276 @@ |
||||
*> \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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,315 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,277 @@ |
||||
!> \brief \b CROTG generates a Givens rotation with real cosine and complex sine. |
||||
! |
||||
! =========== DOCUMENTATION =========== |
||||
! |
||||
! Online html documentation available at |
||||
! http://www.netlib.org/lapack/explore-html/ |
||||
! |
||||
! Definition: |
||||
! =========== |
||||
! |
||||
! CROTG constructs a plane rotation |
||||
! [ c s ] [ a ] = [ r ] |
||||
! [ -conjg(s) c ] [ b ] [ 0 ] |
||||
! where c is real, s is complex, and c**2 + conjg(s)*s = 1. |
||||
! |
||||
!> \par Purpose: |
||||
! ============= |
||||
!> |
||||
!> \verbatim |
||||
!> |
||||
!> The computation uses the formulas |
||||
!> |x| = sqrt( Re(x)**2 + Im(x)**2 ) |
||||
!> sgn(x) = x / |x| if x /= 0 |
||||
!> = 1 if x = 0 |
||||
!> c = |a| / sqrt(|a|**2 + |b|**2) |
||||
!> s = sgn(a) * conjg(b) / sqrt(|a|**2 + |b|**2) |
||||
!> r = sgn(a)*sqrt(|a|**2 + |b|**2) |
||||
!> When a and b are real and r /= 0, the formulas simplify to |
||||
!> c = a / r |
||||
!> s = b / r |
||||
!> the same as in SROTG when |a| > |b|. When |b| >= |a|, the |
||||
!> sign of c and s will be different from those computed by SROTG |
||||
!> if the signs of a and b are not the same. |
||||
!> |
||||
!> \endverbatim |
||||
! |
||||
! Arguments: |
||||
! ========== |
||||
! |
||||
!> \param[in,out] A |
||||
!> \verbatim |
||||
!> A is COMPLEX |
||||
!> On entry, the scalar a. |
||||
!> On exit, the scalar r. |
||||
!> \endverbatim |
||||
!> |
||||
!> \param[in] B |
||||
!> \verbatim |
||||
!> B is COMPLEX |
||||
!> The scalar b. |
||||
!> \endverbatim |
||||
!> |
||||
!> \param[out] C |
||||
!> \verbatim |
||||
!> C is REAL |
||||
!> The scalar c. |
||||
!> \endverbatim |
||||
!> |
||||
!> \param[out] S |
||||
!> \verbatim |
||||
!> S is COMPLEX |
||||
!> The scalar s. |
||||
!> \endverbatim |
||||
! |
||||
! Authors: |
||||
! ======== |
||||
! |
||||
!> \author Weslley Pereira, University of Colorado Denver, USA |
||||
! |
||||
!> \date December 2021 |
||||
! |
||||
!> \ingroup single_blas_level1 |
||||
! |
||||
!> \par Further Details: |
||||
! ===================== |
||||
!> |
||||
!> \verbatim |
||||
!> |
||||
!> Based on the algorithm from |
||||
!> |
||||
!> Anderson E. (2017) |
||||
!> Algorithm 978: Safe Scaling in the Level 1 BLAS |
||||
!> ACM Trans Math Softw 44:1--28 |
||||
!> https://doi.org/10.1145/3061665 |
||||
!> |
||||
!> \endverbatim |
||||
! |
||||
! ===================================================================== |
||||
subroutine CROTG( a, b, c, s ) |
||||
integer, parameter :: wp = kind(1.e0) |
||||
! |
||||
! -- Reference BLAS level1 routine -- |
||||
! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
! |
||||
! .. Constants .. |
||||
real(wp), parameter :: zero = 0.0_wp |
||||
real(wp), parameter :: one = 1.0_wp |
||||
complex(wp), parameter :: czero = 0.0_wp |
||||
! .. |
||||
! .. Scaling constants .. |
||||
real(wp), parameter :: safmin = real(radix(0._wp),wp)**max( & |
||||
minexponent(0._wp)-1, & |
||||
1-maxexponent(0._wp) & |
||||
) |
||||
real(wp), parameter :: safmax = real(radix(0._wp),wp)**max( & |
||||
1-minexponent(0._wp), & |
||||
maxexponent(0._wp)-1 & |
||||
) |
||||
real(wp), parameter :: rtmin = sqrt( safmin ) |
||||
! .. |
||||
! .. Scalar Arguments .. |
||||
real(wp) :: c |
||||
complex(wp) :: a, b, s |
||||
! .. |
||||
! .. Local Scalars .. |
||||
real(wp) :: d, f1, f2, g1, g2, h2, u, v, w, rtmax |
||||
complex(wp) :: f, fs, g, gs, r, t |
||||
! .. |
||||
! .. Intrinsic Functions .. |
||||
intrinsic :: abs, aimag, conjg, max, min, real, sqrt |
||||
! .. |
||||
! .. Statement Functions .. |
||||
real(wp) :: ABSSQ |
||||
! .. |
||||
! .. Statement Function definitions .. |
||||
ABSSQ( t ) = real( t )**2 + aimag( t )**2 |
||||
! .. |
||||
! .. Executable Statements .. |
||||
! |
||||
f = a |
||||
g = b |
||||
if( g == czero ) then |
||||
c = one |
||||
s = czero |
||||
r = f |
||||
else if( f == czero ) then |
||||
c = zero |
||||
if( real(g) == zero ) then |
||||
r = abs(aimag(g)) |
||||
s = conjg( g ) / r |
||||
elseif( aimag(g) == zero ) then |
||||
r = abs(real(g)) |
||||
s = conjg( g ) / r |
||||
else |
||||
g1 = max( abs(real(g)), abs(aimag(g)) ) |
||||
rtmax = sqrt( safmax/2 ) |
||||
if( g1 > rtmin .and. g1 < rtmax ) then |
||||
! |
||||
! Use unscaled algorithm |
||||
! |
||||
! The following two lines can be replaced by `d = abs( g )`. |
||||
! This algorithm do not use the intrinsic complex abs. |
||||
g2 = ABSSQ( g ) |
||||
d = sqrt( g2 ) |
||||
s = conjg( g ) / d |
||||
r = d |
||||
else |
||||
! |
||||
! Use scaled algorithm |
||||
! |
||||
u = min( safmax, max( safmin, g1 ) ) |
||||
gs = g / u |
||||
! The following two lines can be replaced by `d = abs( gs )`. |
||||
! This algorithm do not use the intrinsic complex abs. |
||||
g2 = ABSSQ( gs ) |
||||
d = sqrt( g2 ) |
||||
s = conjg( gs ) / d |
||||
r = d*u |
||||
end if |
||||
end if |
||||
else |
||||
f1 = max( abs(real(f)), abs(aimag(f)) ) |
||||
g1 = max( abs(real(g)), abs(aimag(g)) ) |
||||
rtmax = sqrt( safmax/4 ) |
||||
if( f1 > rtmin .and. f1 < rtmax .and. & |
||||
g1 > rtmin .and. g1 < rtmax ) then |
||||
! |
||||
! Use unscaled algorithm |
||||
! |
||||
f2 = ABSSQ( f ) |
||||
g2 = ABSSQ( g ) |
||||
h2 = f2 + g2 |
||||
! safmin <= f2 <= h2 <= safmax |
||||
if( f2 >= h2 * safmin ) then |
||||
! safmin <= f2/h2 <= 1, and h2/f2 is finite |
||||
c = sqrt( f2 / h2 ) |
||||
r = f / c |
||||
rtmax = rtmax * 2 |
||||
if( f2 > rtmin .and. h2 < rtmax ) then |
||||
! safmin <= sqrt( f2*h2 ) <= safmax |
||||
s = conjg( g ) * ( f / sqrt( f2*h2 ) ) |
||||
else |
||||
s = conjg( g ) * ( r / h2 ) |
||||
end if |
||||
else |
||||
! f2/h2 <= safmin may be subnormal, and h2/f2 may overflow. |
||||
! Moreover, |
||||
! safmin <= f2*f2 * safmax < f2 * h2 < h2*h2 * safmin <= safmax, |
||||
! sqrt(safmin) <= sqrt(f2 * h2) <= sqrt(safmax). |
||||
! Also, |
||||
! g2 >> f2, which means that h2 = g2. |
||||
d = sqrt( f2 * h2 ) |
||||
c = f2 / d |
||||
if( c >= safmin ) then |
||||
r = f / c |
||||
else |
||||
! f2 / sqrt(f2 * h2) < safmin, then |
||||
! sqrt(safmin) <= f2 * sqrt(safmax) <= h2 / sqrt(f2 * h2) <= h2 * (safmin / f2) <= h2 <= safmax |
||||
r = f * ( h2 / d ) |
||||
end if |
||||
s = conjg( g ) * ( f / d ) |
||||
end if |
||||
else |
||||
! |
||||
! Use scaled algorithm |
||||
! |
||||
u = min( safmax, max( safmin, f1, g1 ) ) |
||||
gs = g / u |
||||
g2 = ABSSQ( gs ) |
||||
if( f1 / u < rtmin ) then |
||||
! |
||||
! f is not well-scaled when scaled by g1. |
||||
! Use a different scaling for f. |
||||
! |
||||
v = min( safmax, max( safmin, f1 ) ) |
||||
w = v / u |
||||
fs = f / v |
||||
f2 = ABSSQ( fs ) |
||||
h2 = f2*w**2 + g2 |
||||
else |
||||
! |
||||
! Otherwise use the same scaling for f and g. |
||||
! |
||||
w = one |
||||
fs = f / u |
||||
f2 = ABSSQ( fs ) |
||||
h2 = f2 + g2 |
||||
end if |
||||
! safmin <= f2 <= h2 <= safmax |
||||
if( f2 >= h2 * safmin ) then |
||||
! safmin <= f2/h2 <= 1, and h2/f2 is finite |
||||
c = sqrt( f2 / h2 ) |
||||
r = fs / c |
||||
rtmax = rtmax * 2 |
||||
if( f2 > rtmin .and. h2 < rtmax ) then |
||||
! safmin <= sqrt( f2*h2 ) <= safmax |
||||
s = conjg( gs ) * ( fs / sqrt( f2*h2 ) ) |
||||
else |
||||
s = conjg( gs ) * ( r / h2 ) |
||||
end if |
||||
else |
||||
! f2/h2 <= safmin may be subnormal, and h2/f2 may overflow. |
||||
! Moreover, |
||||
! safmin <= f2*f2 * safmax < f2 * h2 < h2*h2 * safmin <= safmax, |
||||
! sqrt(safmin) <= sqrt(f2 * h2) <= sqrt(safmax). |
||||
! Also, |
||||
! g2 >> f2, which means that h2 = g2. |
||||
d = sqrt( f2 * h2 ) |
||||
c = f2 / d |
||||
if( c >= safmin ) then |
||||
r = fs / c |
||||
else |
||||
! f2 / sqrt(f2 * h2) < safmin, then |
||||
! sqrt(safmin) <= f2 * sqrt(safmax) <= h2 / sqrt(f2 * h2) <= h2 * (safmin / f2) <= h2 <= safmax |
||||
r = fs * ( h2 / d ) |
||||
end if |
||||
s = conjg( gs ) * ( fs / d ) |
||||
end if |
||||
! Rescale c and r |
||||
c = c * w |
||||
r = r * u |
||||
end if |
||||
end if |
||||
a = r |
||||
return |
||||
end subroutine |
||||
@ -0,0 +1,121 @@ |
||||
*> \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 |
||||
* |
||||
* Arguments: |
||||
* ========== |
||||
* |
||||
*> \param[in] N |
||||
*> \verbatim |
||||
*> N is INTEGER |
||||
*> number of elements in input vector(s) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] CA |
||||
*> \verbatim |
||||
*> CA is COMPLEX |
||||
*> On entry, CA specifies the scalar alpha. |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in,out] CX |
||||
*> \verbatim |
||||
*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCX |
||||
*> \verbatim |
||||
*> INCX is INTEGER |
||||
*> storage spacing between elements of CX |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. Scalar Arguments .. |
||||
COMPLEX CA |
||||
INTEGER INCX,N |
||||
* .. |
||||
* .. Array Arguments .. |
||||
COMPLEX CX(*) |
||||
* .. |
||||
* |
||||
* ===================================================================== |
||||
* |
||||
* .. Local Scalars .. |
||||
INTEGER I,NINCX |
||||
* .. |
||||
* .. Parameters .. |
||||
COMPLEX ONE |
||||
PARAMETER (ONE= (1.0E+0,0.0E+0)) |
||||
* .. |
||||
IF (N.LE.0 .OR. INCX.LE.0 .OR. CA.EQ.ONE) 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 of CSCAL |
||||
* |
||||
END |
||||
@ -0,0 +1,153 @@ |
||||
*> \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. |
||||
* |
||||
*> \ingroup complex_blas_level1 |
||||
* |
||||
* ===================================================================== |
||||
SUBROUTINE CSROT( N, CX, INCX, CY, INCY, C, S ) |
||||
* |
||||
* -- Reference BLAS level1 routine -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of CSROT |
||||
* |
||||
END |
||||
@ -0,0 +1,124 @@ |
||||
*> \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 |
||||
* |
||||
* Arguments: |
||||
* ========== |
||||
* |
||||
*> \param[in] N |
||||
*> \verbatim |
||||
*> N is INTEGER |
||||
*> number of elements in input vector(s) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] SA |
||||
*> \verbatim |
||||
*> SA is REAL |
||||
*> On entry, SA specifies the scalar alpha. |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in,out] CX |
||||
*> \verbatim |
||||
*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCX |
||||
*> \verbatim |
||||
*> INCX is INTEGER |
||||
*> storage spacing between elements of CX |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. Scalar Arguments .. |
||||
REAL SA |
||||
INTEGER INCX,N |
||||
* .. |
||||
* .. Array Arguments .. |
||||
COMPLEX CX(*) |
||||
* .. |
||||
* |
||||
* ===================================================================== |
||||
* |
||||
* .. Local Scalars .. |
||||
INTEGER I,NINCX |
||||
* .. |
||||
* .. Parameters .. |
||||
REAL ONE |
||||
PARAMETER (ONE=1.0E+0) |
||||
* .. |
||||
* .. Intrinsic Functions .. |
||||
INTRINSIC AIMAG,CMPLX,REAL |
||||
* .. |
||||
IF (N.LE.0 .OR. INCX.LE.0 .OR. SA.EQ.ONE) 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 of CSSCAL |
||||
* |
||||
END |
||||
@ -0,0 +1,129 @@ |
||||
*> \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 |
||||
* |
||||
* Arguments: |
||||
* ========== |
||||
* |
||||
*> \param[in] N |
||||
*> \verbatim |
||||
*> N is INTEGER |
||||
*> number of elements in input vector(s) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in,out] CX |
||||
*> \verbatim |
||||
*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCX |
||||
*> \verbatim |
||||
*> INCX is INTEGER |
||||
*> storage spacing between elements of CX |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in,out] CY |
||||
*> \verbatim |
||||
*> CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCY |
||||
*> \verbatim |
||||
*> INCY is INTEGER |
||||
*> storage spacing between elements of CY |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of CSWAP |
||||
* |
||||
END |
||||
@ -0,0 +1,366 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,393 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,360 @@ |
||||
*> \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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,426 @@ |
||||
*> \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, 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, 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 |
||||
*> transformed 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,429 @@ |
||||
*> \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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,385 @@ |
||||
*> \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, 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, 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 |
||||
*> transformed 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,387 @@ |
||||
*> \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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,449 @@ |
||||
*> \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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,370 @@ |
||||
*> \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, 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, 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 |
||||
*> transformed 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,474 @@ |
||||
*> \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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,372 @@ |
||||
*> \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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,131 @@ |
||||
*> \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 |
||||
* |
||||
* Arguments: |
||||
* ========== |
||||
* |
||||
*> \param[in] N |
||||
*> \verbatim |
||||
*> N is INTEGER |
||||
*> number of elements in input vector(s) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] DX |
||||
*> \verbatim |
||||
*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCX |
||||
*> \verbatim |
||||
*> INCX is INTEGER |
||||
*> storage spacing between elements of DX |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of DASUM |
||||
* |
||||
END |
||||
@ -0,0 +1,152 @@ |
||||
*> \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 |
||||
* |
||||
* Arguments: |
||||
* ========== |
||||
* |
||||
*> \param[in] N |
||||
*> \verbatim |
||||
*> N is INTEGER |
||||
*> number of elements in input vector(s) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] DA |
||||
*> \verbatim |
||||
*> DA is DOUBLE PRECISION |
||||
*> On entry, DA specifies the scalar alpha. |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] DX |
||||
*> \verbatim |
||||
*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \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 ( 1 + ( N - 1 )*abs( INCY ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCY |
||||
*> \verbatim |
||||
*> INCY is INTEGER |
||||
*> storage spacing between elements of DY |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of DAXPY |
||||
* |
||||
END |
||||
@ -0,0 +1,66 @@ |
||||
*> \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 |Re(.)| + |Im(.)| of a double complex number |
||||
*> \endverbatim |
||||
* |
||||
* Arguments: |
||||
* ========== |
||||
* |
||||
*> \param[in] Z |
||||
*> \verbatim |
||||
*> Z is COMPLEX*16 |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \ingroup double_blas_level1 |
||||
* |
||||
* ===================================================================== |
||||
DOUBLE PRECISION FUNCTION DCABS1(Z) |
||||
* |
||||
* -- Reference BLAS level1 routine -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. Scalar Arguments .. |
||||
COMPLEX*16 Z |
||||
* .. |
||||
* .. |
||||
* ===================================================================== |
||||
* |
||||
* .. Intrinsic Functions .. |
||||
INTRINSIC ABS,DBLE,DIMAG |
||||
* |
||||
DCABS1 = ABS(DBLE(Z)) + ABS(DIMAG(Z)) |
||||
RETURN |
||||
* |
||||
* End of DCABS1 |
||||
* |
||||
END |
||||
@ -0,0 +1,146 @@ |
||||
*> \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 1. |
||||
*> \endverbatim |
||||
* |
||||
* Arguments: |
||||
* ========== |
||||
* |
||||
*> \param[in] N |
||||
*> \verbatim |
||||
*> N is INTEGER |
||||
*> number of elements in input vector(s) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] DX |
||||
*> \verbatim |
||||
*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCX |
||||
*> \verbatim |
||||
*> INCX is INTEGER |
||||
*> storage spacing between elements of DX |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[out] DY |
||||
*> \verbatim |
||||
*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCY |
||||
*> \verbatim |
||||
*> INCY is INTEGER |
||||
*> storage spacing between elements of DY |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of DCOPY |
||||
* |
||||
END |
||||
@ -0,0 +1,148 @@ |
||||
*> \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 |
||||
* |
||||
* Arguments: |
||||
* ========== |
||||
* |
||||
*> \param[in] N |
||||
*> \verbatim |
||||
*> N is INTEGER |
||||
*> number of elements in input vector(s) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] DX |
||||
*> \verbatim |
||||
*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCX |
||||
*> \verbatim |
||||
*> INCX is INTEGER |
||||
*> storage spacing between elements of DX |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] DY |
||||
*> \verbatim |
||||
*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCY |
||||
*> \verbatim |
||||
*> INCY is INTEGER |
||||
*> storage spacing between elements of DY |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of DDOT |
||||
* |
||||
END |
||||
@ -0,0 +1,367 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
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 |
||||
JX = JX + INCX |
||||
60 CONTINUE |
||||
ELSE |
||||
DO 80 J = 1,N |
||||
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 |
||||
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 |
||||
@ -0,0 +1,379 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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,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 and NROWB as the number of rows of A |
||||
* and B respectively. |
||||
* |
||||
NOTA = LSAME(TRANSA,'N') |
||||
NOTB = LSAME(TRANSB,'N') |
||||
IF (NOTA) THEN |
||||
NROWA = M |
||||
ELSE |
||||
NROWA = K |
||||
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 |
||||
TEMP = ALPHA*B(L,J) |
||||
DO 70 I = 1,M |
||||
C(I,J) = C(I,J) + TEMP*A(I,L) |
||||
70 CONTINUE |
||||
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 |
||||
TEMP = ALPHA*B(J,L) |
||||
DO 150 I = 1,M |
||||
C(I,J) = C(I,J) + TEMP*A(I,L) |
||||
150 CONTINUE |
||||
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 |
||||
@ -0,0 +1,327 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
TEMP = ALPHA*X(JX) |
||||
DO 50 I = 1,M |
||||
Y(I) = Y(I) + TEMP*A(I,J) |
||||
50 CONTINUE |
||||
JX = JX + INCX |
||||
60 CONTINUE |
||||
ELSE |
||||
DO 80 J = 1,N |
||||
TEMP = ALPHA*X(JX) |
||||
IY = KY |
||||
DO 70 I = 1,M |
||||
Y(IY) = Y(IY) + TEMP*A(I,J) |
||||
IY = IY + INCY |
||||
70 CONTINUE |
||||
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 |
||||
@ -0,0 +1,224 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,199 @@ |
||||
!> \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 |
||||
! |
||||
! Arguments: |
||||
! ========== |
||||
! |
||||
!> \param[in] N |
||||
!> \verbatim |
||||
!> N is INTEGER |
||||
!> number of elements in input vector(s) |
||||
!> \endverbatim |
||||
!> |
||||
!> \param[in] X |
||||
!> \verbatim |
||||
!> X is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
!> \endverbatim |
||||
!> |
||||
!> \param[in] INCX |
||||
!> \verbatim |
||||
!> INCX is INTEGER, storage spacing between elements of X |
||||
!> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n |
||||
!> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n |
||||
!> If INCX = 0, x isn't a vector so there is no need to call |
||||
!> this subroutine. If you call it anyway, it will count x(1) |
||||
!> in the vector norm N times. |
||||
!> \endverbatim |
||||
! |
||||
! Authors: |
||||
! ======== |
||||
! |
||||
!> \author Edward Anderson, Lockheed Martin |
||||
! |
||||
!> \date August 2016 |
||||
! |
||||
!> \ingroup single_blas_level1 |
||||
! |
||||
!> \par Contributors: |
||||
! ================== |
||||
!> |
||||
!> Weslley Pereira, University of Colorado Denver, USA |
||||
! |
||||
!> \par Further Details: |
||||
! ===================== |
||||
!> |
||||
!> \verbatim |
||||
!> |
||||
!> Anderson E. (2017) |
||||
!> Algorithm 978: Safe Scaling in the Level 1 BLAS |
||||
!> ACM Trans Math Softw 44:1--28 |
||||
!> https://doi.org/10.1145/3061665 |
||||
!> |
||||
!> Blue, James L. (1978) |
||||
!> A Portable Fortran Program to Find the Euclidean Norm of a Vector |
||||
!> ACM Trans Math Softw 4:15--23 |
||||
!> https://doi.org/10.1145/355769.355771 |
||||
!> |
||||
!> \endverbatim |
||||
!> |
||||
! ===================================================================== |
||||
function DNRM2( n, x, incx ) |
||||
integer, parameter :: wp = kind(1.d0) |
||||
real(wp) :: DNRM2 |
||||
! |
||||
! -- Reference BLAS level1 routine (version 3.9.1) -- |
||||
! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
! March 2021 |
||||
! |
||||
! .. Constants .. |
||||
real(wp), parameter :: zero = 0.0_wp |
||||
real(wp), parameter :: one = 1.0_wp |
||||
real(wp), parameter :: maxN = huge(0.0_wp) |
||||
! .. |
||||
! .. Blue's scaling constants .. |
||||
real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( & |
||||
(minexponent(0._wp) - 1) * 0.5_wp) |
||||
real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( & |
||||
(maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp) |
||||
real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( & |
||||
(minexponent(0._wp) - digits(0._wp)) * 0.5_wp)) |
||||
real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( & |
||||
(maxexponent(0._wp) + digits(0._wp) - 1) * 0.5_wp)) |
||||
! .. |
||||
! .. Scalar Arguments .. |
||||
integer :: incx, n |
||||
! .. |
||||
! .. Array Arguments .. |
||||
real(wp) :: x(*) |
||||
! .. |
||||
! .. Local Scalars .. |
||||
integer :: i, ix |
||||
logical :: notbig |
||||
real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin |
||||
! |
||||
! Quick return if possible |
||||
! |
||||
DNRM2 = zero |
||||
if( n <= 0 ) return |
||||
! |
||||
scl = one |
||||
sumsq = zero |
||||
! |
||||
! Compute the sum of squares in 3 accumulators: |
||||
! abig -- sums of squares scaled down to avoid overflow |
||||
! asml -- sums of squares scaled up to avoid underflow |
||||
! amed -- sums of squares that do not require scaling |
||||
! The thresholds and multipliers are |
||||
! tbig -- values bigger than this are scaled down by sbig |
||||
! tsml -- values smaller than this are scaled up by ssml |
||||
! |
||||
notbig = .true. |
||||
asml = zero |
||||
amed = zero |
||||
abig = zero |
||||
ix = 1 |
||||
if( incx < 0 ) ix = 1 - (n-1)*incx |
||||
do i = 1, n |
||||
ax = abs(x(ix)) |
||||
if (ax > tbig) then |
||||
abig = abig + (ax*sbig)**2 |
||||
notbig = .false. |
||||
else if (ax < tsml) then |
||||
if (notbig) asml = asml + (ax*ssml)**2 |
||||
else |
||||
amed = amed + ax**2 |
||||
end if |
||||
ix = ix + incx |
||||
end do |
||||
! |
||||
! Combine abig and amed or amed and asml if more than one |
||||
! accumulator was used. |
||||
! |
||||
if (abig > zero) then |
||||
! |
||||
! Combine abig and amed if abig > 0. |
||||
! |
||||
if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then |
||||
abig = abig + (amed*sbig)*sbig |
||||
end if |
||||
scl = one / sbig |
||||
sumsq = abig |
||||
else if (asml > zero) then |
||||
! |
||||
! Combine amed and asml if asml > 0. |
||||
! |
||||
if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then |
||||
amed = sqrt(amed) |
||||
asml = sqrt(asml) / ssml |
||||
if (asml > amed) then |
||||
ymin = amed |
||||
ymax = asml |
||||
else |
||||
ymin = asml |
||||
ymax = amed |
||||
end if |
||||
scl = one |
||||
sumsq = ymax**2*( one + (ymin/ymax)**2 ) |
||||
else |
||||
scl = one / ssml |
||||
sumsq = asml |
||||
end if |
||||
else |
||||
! |
||||
! Otherwise all values are mid-range |
||||
! |
||||
scl = one |
||||
sumsq = amed |
||||
end if |
||||
DNRM2 = scl*sqrt( sumsq ) |
||||
return |
||||
end function |
||||
@ -0,0 +1,142 @@ |
||||
*> \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 |
||||
* |
||||
* 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 ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \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 ( 1 + ( N - 1 )*abs( INCY ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCY |
||||
*> \verbatim |
||||
*> INCY is INTEGER |
||||
*> storage spacing between elements of DY |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] C |
||||
*> \verbatim |
||||
*> C is DOUBLE PRECISION |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] S |
||||
*> \verbatim |
||||
*> S is DOUBLE PRECISION |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of DROT |
||||
* |
||||
END |
||||
@ -0,0 +1,151 @@ |
||||
!> \brief \b DROTG |
||||
! |
||||
! =========== DOCUMENTATION =========== |
||||
! |
||||
! Online html documentation available at |
||||
! http://www.netlib.org/lapack/explore-html/ |
||||
! |
||||
! Definition: |
||||
! =========== |
||||
! |
||||
! DROTG constructs a plane rotation |
||||
! [ c s ] [ a ] = [ r ] |
||||
! [ -s c ] [ b ] [ 0 ] |
||||
! satisfying c**2 + s**2 = 1. |
||||
! |
||||
!> \par Purpose: |
||||
! ============= |
||||
!> |
||||
!> \verbatim |
||||
!> |
||||
!> The computation uses the formulas |
||||
!> sigma = sgn(a) if |a| > |b| |
||||
!> = sgn(b) if |b| >= |a| |
||||
!> r = sigma*sqrt( a**2 + b**2 ) |
||||
!> c = 1; s = 0 if r = 0 |
||||
!> c = a/r; s = b/r if r != 0 |
||||
!> The subroutine also computes |
||||
!> z = s if |a| > |b|, |
||||
!> = 1/c if |b| >= |a| and c != 0 |
||||
!> = 1 if c = 0 |
||||
!> This allows c and s to be reconstructed from z as follows: |
||||
!> If z = 1, set c = 0, s = 1. |
||||
!> If |z| < 1, set c = sqrt(1 - z**2) and s = z. |
||||
!> If |z| > 1, set c = 1/z and s = sqrt( 1 - c**2). |
||||
!> |
||||
!> \endverbatim |
||||
! |
||||
! Arguments: |
||||
! ========== |
||||
! |
||||
!> \param[in,out] A |
||||
!> \verbatim |
||||
!> A is DOUBLE PRECISION |
||||
!> On entry, the scalar a. |
||||
!> On exit, the scalar r. |
||||
!> \endverbatim |
||||
!> |
||||
!> \param[in,out] B |
||||
!> \verbatim |
||||
!> B is DOUBLE PRECISION |
||||
!> On entry, the scalar b. |
||||
!> On exit, the scalar z. |
||||
!> \endverbatim |
||||
!> |
||||
!> \param[out] C |
||||
!> \verbatim |
||||
!> C is DOUBLE PRECISION |
||||
!> The scalar c. |
||||
!> \endverbatim |
||||
!> |
||||
!> \param[out] S |
||||
!> \verbatim |
||||
!> S is DOUBLE PRECISION |
||||
!> The scalar s. |
||||
!> \endverbatim |
||||
! |
||||
! Authors: |
||||
! ======== |
||||
! |
||||
!> \author Edward Anderson, Lockheed Martin |
||||
! |
||||
!> \par Contributors: |
||||
! ================== |
||||
!> |
||||
!> Weslley Pereira, University of Colorado Denver, USA |
||||
! |
||||
!> \ingroup single_blas_level1 |
||||
! |
||||
!> \par Further Details: |
||||
! ===================== |
||||
!> |
||||
!> \verbatim |
||||
!> |
||||
!> Anderson E. (2017) |
||||
!> Algorithm 978: Safe Scaling in the Level 1 BLAS |
||||
!> ACM Trans Math Softw 44:1--28 |
||||
!> https://doi.org/10.1145/3061665 |
||||
!> |
||||
!> \endverbatim |
||||
! |
||||
! ===================================================================== |
||||
subroutine DROTG( a, b, c, s ) |
||||
integer, parameter :: wp = kind(1.d0) |
||||
! |
||||
! -- Reference BLAS level1 routine -- |
||||
! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
! |
||||
! .. Constants .. |
||||
real(wp), parameter :: zero = 0.0_wp |
||||
real(wp), parameter :: one = 1.0_wp |
||||
! .. |
||||
! .. Scaling constants .. |
||||
real(wp), parameter :: safmin = real(radix(0._wp),wp)**max( & |
||||
minexponent(0._wp)-1, & |
||||
1-maxexponent(0._wp) & |
||||
) |
||||
real(wp), parameter :: safmax = real(radix(0._wp),wp)**max( & |
||||
1-minexponent(0._wp), & |
||||
maxexponent(0._wp)-1 & |
||||
) |
||||
! .. |
||||
! .. Scalar Arguments .. |
||||
real(wp) :: a, b, c, s |
||||
! .. |
||||
! .. Local Scalars .. |
||||
real(wp) :: anorm, bnorm, scl, sigma, r, z |
||||
! .. |
||||
anorm = abs(a) |
||||
bnorm = abs(b) |
||||
if( bnorm == zero ) then |
||||
c = one |
||||
s = zero |
||||
b = zero |
||||
else if( anorm == zero ) then |
||||
c = zero |
||||
s = one |
||||
a = b |
||||
b = one |
||||
else |
||||
scl = min( safmax, max( safmin, anorm, bnorm ) ) |
||||
if( anorm > bnorm ) then |
||||
sigma = sign(one,a) |
||||
else |
||||
sigma = sign(one,b) |
||||
end if |
||||
r = sigma*( scl*sqrt((a/scl)**2 + (b/scl)**2) ) |
||||
c = a/r |
||||
s = b/r |
||||
if( anorm > bnorm ) then |
||||
z = s |
||||
else if( c /= zero ) then |
||||
z = one/c |
||||
else |
||||
z = one |
||||
end if |
||||
a = r |
||||
b = z |
||||
end if |
||||
return |
||||
end subroutine |
||||
@ -0,0 +1,200 @@ |
||||
*> \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 ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \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 ( 1 + ( N - 1 )*abs( INCY ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCY |
||||
*> \verbatim |
||||
*> INCY is INTEGER |
||||
*> storage spacing between elements of DY |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] 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. |
||||
* |
||||
*> \ingroup double_blas_level1 |
||||
* |
||||
* ===================================================================== |
||||
SUBROUTINE DROTM(N,DX,INCX,DY,INCY,DPARAM) |
||||
* |
||||
* -- Reference BLAS level1 routine -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of DROTM |
||||
* |
||||
END |
||||
@ -0,0 +1,260 @@ |
||||
*> \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[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. |
||||
* |
||||
*> \ingroup double_blas_level1 |
||||
* |
||||
* ===================================================================== |
||||
SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM) |
||||
* |
||||
* -- Reference BLAS level1 routine -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
ELSE |
||||
* This code path if here for safety. We do not expect this |
||||
* condition to ever hold except in edge cases with rounding |
||||
* errors. See DOI: 10.1145/355841.355847 |
||||
DFLAG = -ONE |
||||
DH11 = ZERO |
||||
DH12 = ZERO |
||||
DH21 = ZERO |
||||
DH22 = ZERO |
||||
* |
||||
DD1 = ZERO |
||||
DD2 = ZERO |
||||
DX1 = ZERO |
||||
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 of DROTMG |
||||
* |
||||
END |
||||
@ -0,0 +1,372 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,139 @@ |
||||
*> \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 1. |
||||
*> \endverbatim |
||||
* |
||||
* Arguments: |
||||
* ========== |
||||
* |
||||
*> \param[in] N |
||||
*> \verbatim |
||||
*> N is INTEGER |
||||
*> number of elements in input vector(s) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] DA |
||||
*> \verbatim |
||||
*> DA is DOUBLE PRECISION |
||||
*> On entry, DA specifies the scalar alpha. |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in,out] DX |
||||
*> \verbatim |
||||
*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCX |
||||
*> \verbatim |
||||
*> INCX is INTEGER |
||||
*> storage spacing between elements of DX |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. Scalar Arguments .. |
||||
DOUBLE PRECISION DA |
||||
INTEGER INCX,N |
||||
* .. |
||||
* .. Array Arguments .. |
||||
DOUBLE PRECISION DX(*) |
||||
* .. |
||||
* |
||||
* ===================================================================== |
||||
* |
||||
* .. Local Scalars .. |
||||
INTEGER I,M,MP1,NINCX |
||||
* .. Parameters .. |
||||
DOUBLE PRECISION ONE |
||||
PARAMETER (ONE=1.0D+0) |
||||
* .. |
||||
* .. Intrinsic Functions .. |
||||
INTRINSIC MOD |
||||
* .. |
||||
IF (N.LE.0 .OR. INCX.LE.0 .OR. DA.EQ.ONE) 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 of DSCAL |
||||
* |
||||
END |
||||
@ -0,0 +1,172 @@ |
||||
*> \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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of DSDOT |
||||
* |
||||
END |
||||
@ -0,0 +1,328 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,258 @@ |
||||
*> \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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,293 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,153 @@ |
||||
*> \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 |
||||
*> |
||||
*> DSWAP interchanges two vectors. |
||||
*> uses unrolled loops for increments equal to 1. |
||||
*> \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 ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \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 ( 1 + ( N - 1 )*abs( INCY ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCY |
||||
*> \verbatim |
||||
*> INCY is INTEGER |
||||
*> storage spacing between elements of DY |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of DSWAP |
||||
* |
||||
END |
||||
@ -0,0 +1,364 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,330 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,260 @@ |
||||
*> \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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,295 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,396 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,361 @@ |
||||
*> \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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,395 @@ |
||||
*> \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, 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, 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 |
||||
*> transformed 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,398 @@ |
||||
*> \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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,349 @@ |
||||
*> \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, 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, 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 |
||||
*> transformed 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,351 @@ |
||||
*> \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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,412 @@ |
||||
*> \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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,339 @@ |
||||
*> \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, 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, 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 |
||||
*> transformed 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,440 @@ |
||||
*> \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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,335 @@ |
||||
*> \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, 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, 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. |
||||
* |
||||
*> \ingroup double_blas_level1 |
||||
* |
||||
* ===================================================================== |
||||
SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) |
||||
* |
||||
* -- Reference BLAS level1 routine -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,118 @@ |
||||
*> \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 (|Re(.)| + |Im(.)|)'s of a complex vector and |
||||
*> returns a double precision result. |
||||
*> \endverbatim |
||||
* |
||||
* Arguments: |
||||
* ========== |
||||
* |
||||
*> \param[in] N |
||||
*> \verbatim |
||||
*> N is INTEGER |
||||
*> number of elements in input vector(s) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in,out] ZX |
||||
*> \verbatim |
||||
*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCX |
||||
*> \verbatim |
||||
*> INCX is INTEGER |
||||
*> storage spacing between elements of ZX |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of DZASUM |
||||
* |
||||
END |
||||
@ -0,0 +1,209 @@ |
||||
!> \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 .. |
||||
! DOUBLE COMPLEX X(*) |
||||
! .. |
||||
! |
||||
! |
||||
!> \par Purpose: |
||||
! ============= |
||||
!> |
||||
!> \verbatim |
||||
!> |
||||
!> DZNRM2 returns the euclidean norm of a vector via the function |
||||
!> name, so that |
||||
!> |
||||
!> DZNRM2 := sqrt( x**H*x ) |
||||
!> \endverbatim |
||||
! |
||||
! Arguments: |
||||
! ========== |
||||
! |
||||
!> \param[in] N |
||||
!> \verbatim |
||||
!> N is INTEGER |
||||
!> number of elements in input vector(s) |
||||
!> \endverbatim |
||||
!> |
||||
!> \param[in] X |
||||
!> \verbatim |
||||
!> X is COMPLEX*16 array, dimension (N) |
||||
!> complex vector with N elements |
||||
!> \endverbatim |
||||
!> |
||||
!> \param[in] INCX |
||||
!> \verbatim |
||||
!> INCX is INTEGER, storage spacing between elements of X |
||||
!> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n |
||||
!> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n |
||||
!> If INCX = 0, x isn't a vector so there is no need to call |
||||
!> this subroutine. If you call it anyway, it will count x(1) |
||||
!> in the vector norm N times. |
||||
!> \endverbatim |
||||
! |
||||
! Authors: |
||||
! ======== |
||||
! |
||||
!> \author Edward Anderson, Lockheed Martin |
||||
! |
||||
!> \date August 2016 |
||||
! |
||||
!> \ingroup single_blas_level1 |
||||
! |
||||
!> \par Contributors: |
||||
! ================== |
||||
!> |
||||
!> Weslley Pereira, University of Colorado Denver, USA |
||||
! |
||||
!> \par Further Details: |
||||
! ===================== |
||||
!> |
||||
!> \verbatim |
||||
!> |
||||
!> Anderson E. (2017) |
||||
!> Algorithm 978: Safe Scaling in the Level 1 BLAS |
||||
!> ACM Trans Math Softw 44:1--28 |
||||
!> https://doi.org/10.1145/3061665 |
||||
!> |
||||
!> Blue, James L. (1978) |
||||
!> A Portable Fortran Program to Find the Euclidean Norm of a Vector |
||||
!> ACM Trans Math Softw 4:15--23 |
||||
!> https://doi.org/10.1145/355769.355771 |
||||
!> |
||||
!> \endverbatim |
||||
!> |
||||
! ===================================================================== |
||||
function DZNRM2( n, x, incx ) |
||||
integer, parameter :: wp = kind(1.d0) |
||||
real(wp) :: DZNRM2 |
||||
! |
||||
! -- Reference BLAS level1 routine (version 3.9.1) -- |
||||
! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
! March 2021 |
||||
! |
||||
! .. Constants .. |
||||
real(wp), parameter :: zero = 0.0_wp |
||||
real(wp), parameter :: one = 1.0_wp |
||||
real(wp), parameter :: maxN = huge(0.0_wp) |
||||
! .. |
||||
! .. Blue's scaling constants .. |
||||
real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( & |
||||
(minexponent(0._wp) - 1) * 0.5_wp) |
||||
real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( & |
||||
(maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp) |
||||
real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( & |
||||
(minexponent(0._wp) - digits(0._wp)) * 0.5_wp)) |
||||
real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( & |
||||
(maxexponent(0._wp) + digits(0._wp) - 1) * 0.5_wp)) |
||||
! .. |
||||
! .. Scalar Arguments .. |
||||
integer :: incx, n |
||||
! .. |
||||
! .. Array Arguments .. |
||||
complex(wp) :: x(*) |
||||
! .. |
||||
! .. Local Scalars .. |
||||
integer :: i, ix |
||||
logical :: notbig |
||||
real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin |
||||
! |
||||
! Quick return if possible |
||||
! |
||||
DZNRM2 = zero |
||||
if( n <= 0 ) return |
||||
! |
||||
scl = one |
||||
sumsq = zero |
||||
! |
||||
! Compute the sum of squares in 3 accumulators: |
||||
! abig -- sums of squares scaled down to avoid overflow |
||||
! asml -- sums of squares scaled up to avoid underflow |
||||
! amed -- sums of squares that do not require scaling |
||||
! The thresholds and multipliers are |
||||
! tbig -- values bigger than this are scaled down by sbig |
||||
! tsml -- values smaller than this are scaled up by ssml |
||||
! |
||||
notbig = .true. |
||||
asml = zero |
||||
amed = zero |
||||
abig = zero |
||||
ix = 1 |
||||
if( incx < 0 ) ix = 1 - (n-1)*incx |
||||
do i = 1, n |
||||
ax = abs(real(x(ix))) |
||||
if (ax > tbig) then |
||||
abig = abig + (ax*sbig)**2 |
||||
notbig = .false. |
||||
else if (ax < tsml) then |
||||
if (notbig) asml = asml + (ax*ssml)**2 |
||||
else |
||||
amed = amed + ax**2 |
||||
end if |
||||
ax = abs(aimag(x(ix))) |
||||
if (ax > tbig) then |
||||
abig = abig + (ax*sbig)**2 |
||||
notbig = .false. |
||||
else if (ax < tsml) then |
||||
if (notbig) asml = asml + (ax*ssml)**2 |
||||
else |
||||
amed = amed + ax**2 |
||||
end if |
||||
ix = ix + incx |
||||
end do |
||||
! |
||||
! Combine abig and amed or amed and asml if more than one |
||||
! accumulator was used. |
||||
! |
||||
if (abig > zero) then |
||||
! |
||||
! Combine abig and amed if abig > 0. |
||||
! |
||||
if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then |
||||
abig = abig + (amed*sbig)*sbig |
||||
end if |
||||
scl = one / sbig |
||||
sumsq = abig |
||||
else if (asml > zero) then |
||||
! |
||||
! Combine amed and asml if asml > 0. |
||||
! |
||||
if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then |
||||
amed = sqrt(amed) |
||||
asml = sqrt(asml) / ssml |
||||
if (asml > amed) then |
||||
ymin = amed |
||||
ymax = asml |
||||
else |
||||
ymin = asml |
||||
ymax = amed |
||||
end if |
||||
scl = one |
||||
sumsq = ymax**2*( one + (ymin/ymax)**2 ) |
||||
else |
||||
scl = one / ssml |
||||
sumsq = asml |
||||
end if |
||||
else |
||||
! |
||||
! Otherwise all values are mid-range |
||||
! |
||||
scl = one |
||||
sumsq = amed |
||||
end if |
||||
DZNRM2 = scl*sqrt( sumsq ) |
||||
return |
||||
end function |
||||
@ -0,0 +1,127 @@ |
||||
*> \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 the first element having maximum |Re(.)| + |Im(.)| |
||||
*> \endverbatim |
||||
* |
||||
* Arguments: |
||||
* ========== |
||||
* |
||||
*> \param[in] N |
||||
*> \verbatim |
||||
*> N is INTEGER |
||||
*> number of elements in input vector(s) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] CX |
||||
*> \verbatim |
||||
*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCX |
||||
*> \verbatim |
||||
*> INCX is INTEGER |
||||
*> storage spacing between elements of CX |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of ICAMAX |
||||
* |
||||
END |
||||
@ -0,0 +1,126 @@ |
||||
*> \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 the first element having maximum absolute value. |
||||
*> \endverbatim |
||||
* |
||||
* Arguments: |
||||
* ========== |
||||
* |
||||
*> \param[in] N |
||||
*> \verbatim |
||||
*> N is INTEGER |
||||
*> number of elements in input vector(s) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] DX |
||||
*> \verbatim |
||||
*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCX |
||||
*> \verbatim |
||||
*> INCX is INTEGER |
||||
*> storage spacing between elements of DX |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of IDAMAX |
||||
* |
||||
END |
||||
@ -0,0 +1,126 @@ |
||||
*> \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 the first element having maximum absolute value. |
||||
*> \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 ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCX |
||||
*> \verbatim |
||||
*> INCX is INTEGER |
||||
*> storage spacing between elements of SX |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of ISAMAX |
||||
* |
||||
END |
||||
@ -0,0 +1,127 @@ |
||||
*> \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 the first element having maximum |Re(.)| + |Im(.)| |
||||
*> \endverbatim |
||||
* |
||||
* Arguments: |
||||
* ========== |
||||
* |
||||
*> \param[in] N |
||||
*> \verbatim |
||||
*> N is INTEGER |
||||
*> number of elements in input vector(s) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] ZX |
||||
*> \verbatim |
||||
*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCX |
||||
*> \verbatim |
||||
*> INCX is INTEGER |
||||
*> storage spacing between elements of ZX |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of IZAMAX |
||||
* |
||||
END |
||||
@ -0,0 +1,122 @@ |
||||
*> \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. |
||||
* |
||||
*> \ingroup aux_blas |
||||
* |
||||
* ===================================================================== |
||||
LOGICAL FUNCTION LSAME(CA,CB) |
||||
* |
||||
* -- Reference BLAS level1 routine -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,132 @@ |
||||
*> \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 |
||||
* |
||||
* 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 ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCX |
||||
*> \verbatim |
||||
*> INCX is INTEGER |
||||
*> storage spacing between elements of SX |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of SASUM |
||||
* |
||||
END |
||||
@ -0,0 +1,152 @@ |
||||
*> \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 |
||||
* |
||||
* Arguments: |
||||
* ========== |
||||
* |
||||
*> \param[in] N |
||||
*> \verbatim |
||||
*> N is INTEGER |
||||
*> number of elements in input vector(s) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] SA |
||||
*> \verbatim |
||||
*> SA is REAL |
||||
*> On entry, SA specifies the scalar alpha. |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] SX |
||||
*> \verbatim |
||||
*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \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 ( 1 + ( N - 1 )*abs( INCY ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCY |
||||
*> \verbatim |
||||
*> INCY is INTEGER |
||||
*> storage spacing between elements of SY |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of SAXPY |
||||
* |
||||
END |
||||
@ -0,0 +1,65 @@ |
||||
*> \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 |Re(.)| + |Im(.)| of a complex number |
||||
*> \endverbatim |
||||
* |
||||
* Arguments: |
||||
* ========== |
||||
* |
||||
*> \param[in] Z |
||||
*> \verbatim |
||||
*> Z is COMPLEX |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \ingroup single_blas_level1 |
||||
* |
||||
* ===================================================================== |
||||
REAL FUNCTION SCABS1(Z) |
||||
* |
||||
* -- Reference BLAS level1 routine -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. Scalar Arguments .. |
||||
COMPLEX Z |
||||
* .. |
||||
* |
||||
* ===================================================================== |
||||
* |
||||
* .. Intrinsic Functions .. |
||||
INTRINSIC ABS,AIMAG,REAL |
||||
* .. |
||||
SCABS1 = ABS(REAL(Z)) + ABS(AIMAG(Z)) |
||||
RETURN |
||||
* |
||||
* End of SCABS1 |
||||
* |
||||
END |
||||
@ -0,0 +1,117 @@ |
||||
*> \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 (|Re(.)| + |Im(.)|)'s of a complex vector and |
||||
*> returns a single precision result. |
||||
*> \endverbatim |
||||
* |
||||
* Arguments: |
||||
* ========== |
||||
* |
||||
*> \param[in] N |
||||
*> \verbatim |
||||
*> N is INTEGER |
||||
*> number of elements in input vector(s) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in,out] CX |
||||
*> \verbatim |
||||
*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCX |
||||
*> \verbatim |
||||
*> INCX is INTEGER |
||||
*> storage spacing between elements of SX |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of SCASUM |
||||
* |
||||
END |
||||
@ -0,0 +1,209 @@ |
||||
!> \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 |
||||
! |
||||
! Arguments: |
||||
! ========== |
||||
! |
||||
!> \param[in] N |
||||
!> \verbatim |
||||
!> N is INTEGER |
||||
!> number of elements in input vector(s) |
||||
!> \endverbatim |
||||
!> |
||||
!> \param[in] X |
||||
!> \verbatim |
||||
!> X is COMPLEX array, dimension (N) |
||||
!> complex vector with N elements |
||||
!> \endverbatim |
||||
!> |
||||
!> \param[in] INCX |
||||
!> \verbatim |
||||
!> INCX is INTEGER, storage spacing between elements of X |
||||
!> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n |
||||
!> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n |
||||
!> If INCX = 0, x isn't a vector so there is no need to call |
||||
!> this subroutine. If you call it anyway, it will count x(1) |
||||
!> in the vector norm N times. |
||||
!> \endverbatim |
||||
! |
||||
! Authors: |
||||
! ======== |
||||
! |
||||
!> \author Edward Anderson, Lockheed Martin |
||||
! |
||||
!> \date August 2016 |
||||
! |
||||
!> \ingroup single_blas_level1 |
||||
! |
||||
!> \par Contributors: |
||||
! ================== |
||||
!> |
||||
!> Weslley Pereira, University of Colorado Denver, USA |
||||
! |
||||
!> \par Further Details: |
||||
! ===================== |
||||
!> |
||||
!> \verbatim |
||||
!> |
||||
!> Anderson E. (2017) |
||||
!> Algorithm 978: Safe Scaling in the Level 1 BLAS |
||||
!> ACM Trans Math Softw 44:1--28 |
||||
!> https://doi.org/10.1145/3061665 |
||||
!> |
||||
!> Blue, James L. (1978) |
||||
!> A Portable Fortran Program to Find the Euclidean Norm of a Vector |
||||
!> ACM Trans Math Softw 4:15--23 |
||||
!> https://doi.org/10.1145/355769.355771 |
||||
!> |
||||
!> \endverbatim |
||||
!> |
||||
! ===================================================================== |
||||
function SCNRM2( n, x, incx ) |
||||
integer, parameter :: wp = kind(1.e0) |
||||
real(wp) :: SCNRM2 |
||||
! |
||||
! -- Reference BLAS level1 routine (version 3.9.1) -- |
||||
! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
! March 2021 |
||||
! |
||||
! .. Constants .. |
||||
real(wp), parameter :: zero = 0.0_wp |
||||
real(wp), parameter :: one = 1.0_wp |
||||
real(wp), parameter :: maxN = huge(0.0_wp) |
||||
! .. |
||||
! .. Blue's scaling constants .. |
||||
real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( & |
||||
(minexponent(0._wp) - 1) * 0.5_wp) |
||||
real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( & |
||||
(maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp) |
||||
real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( & |
||||
(minexponent(0._wp) - digits(0._wp)) * 0.5_wp)) |
||||
real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( & |
||||
(maxexponent(0._wp) + digits(0._wp) - 1) * 0.5_wp)) |
||||
! .. |
||||
! .. Scalar Arguments .. |
||||
integer :: incx, n |
||||
! .. |
||||
! .. Array Arguments .. |
||||
complex(wp) :: x(*) |
||||
! .. |
||||
! .. Local Scalars .. |
||||
integer :: i, ix |
||||
logical :: notbig |
||||
real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin |
||||
! |
||||
! Quick return if possible |
||||
! |
||||
SCNRM2 = zero |
||||
if( n <= 0 ) return |
||||
! |
||||
scl = one |
||||
sumsq = zero |
||||
! |
||||
! Compute the sum of squares in 3 accumulators: |
||||
! abig -- sums of squares scaled down to avoid overflow |
||||
! asml -- sums of squares scaled up to avoid underflow |
||||
! amed -- sums of squares that do not require scaling |
||||
! The thresholds and multipliers are |
||||
! tbig -- values bigger than this are scaled down by sbig |
||||
! tsml -- values smaller than this are scaled up by ssml |
||||
! |
||||
notbig = .true. |
||||
asml = zero |
||||
amed = zero |
||||
abig = zero |
||||
ix = 1 |
||||
if( incx < 0 ) ix = 1 - (n-1)*incx |
||||
do i = 1, n |
||||
ax = abs(real(x(ix))) |
||||
if (ax > tbig) then |
||||
abig = abig + (ax*sbig)**2 |
||||
notbig = .false. |
||||
else if (ax < tsml) then |
||||
if (notbig) asml = asml + (ax*ssml)**2 |
||||
else |
||||
amed = amed + ax**2 |
||||
end if |
||||
ax = abs(aimag(x(ix))) |
||||
if (ax > tbig) then |
||||
abig = abig + (ax*sbig)**2 |
||||
notbig = .false. |
||||
else if (ax < tsml) then |
||||
if (notbig) asml = asml + (ax*ssml)**2 |
||||
else |
||||
amed = amed + ax**2 |
||||
end if |
||||
ix = ix + incx |
||||
end do |
||||
! |
||||
! Combine abig and amed or amed and asml if more than one |
||||
! accumulator was used. |
||||
! |
||||
if (abig > zero) then |
||||
! |
||||
! Combine abig and amed if abig > 0. |
||||
! |
||||
if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then |
||||
abig = abig + (amed*sbig)*sbig |
||||
end if |
||||
scl = one / sbig |
||||
sumsq = abig |
||||
else if (asml > zero) then |
||||
! |
||||
! Combine amed and asml if asml > 0. |
||||
! |
||||
if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then |
||||
amed = sqrt(amed) |
||||
asml = sqrt(asml) / ssml |
||||
if (asml > amed) then |
||||
ymin = amed |
||||
ymax = asml |
||||
else |
||||
ymin = asml |
||||
ymax = amed |
||||
end if |
||||
scl = one |
||||
sumsq = ymax**2*( one + (ymin/ymax)**2 ) |
||||
else |
||||
scl = one / ssml |
||||
sumsq = asml |
||||
end if |
||||
else |
||||
! |
||||
! Otherwise all values are mid-range |
||||
! |
||||
scl = one |
||||
sumsq = amed |
||||
end if |
||||
SCNRM2 = scl*sqrt( sumsq ) |
||||
return |
||||
end function |
||||
@ -0,0 +1,146 @@ |
||||
*> \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 |
||||
* |
||||
* 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 ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCX |
||||
*> \verbatim |
||||
*> INCX is INTEGER |
||||
*> storage spacing between elements of SX |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[out] SY |
||||
*> \verbatim |
||||
*> SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCY |
||||
*> \verbatim |
||||
*> INCY is INTEGER |
||||
*> storage spacing between elements of SY |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of SCOPY |
||||
* |
||||
END |
||||
@ -0,0 +1,148 @@ |
||||
*> \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 |
||||
* |
||||
* 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 ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCX |
||||
*> \verbatim |
||||
*> INCX is INTEGER |
||||
*> storage spacing between elements of SX |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] SY |
||||
*> \verbatim |
||||
*> SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCY |
||||
*> \verbatim |
||||
*> INCY is INTEGER |
||||
*> storage spacing between elements of SY |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of SDOT |
||||
* |
||||
END |
||||
@ -0,0 +1,163 @@ |
||||
*> \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(*) |
||||
* .. |
||||
* |
||||
*> \par Purpose: |
||||
* ============= |
||||
*> |
||||
*> \verbatim |
||||
*> |
||||
*> 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. |
||||
*> \endverbatim |
||||
* |
||||
* Arguments: |
||||
* ========== |
||||
* |
||||
*> \param[in] N |
||||
*> \verbatim |
||||
*> N is INTEGER |
||||
*> number of elements in input vector(s) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] SB |
||||
*> \verbatim |
||||
*> SB is REAL |
||||
*> single precision scalar to be added to inner product |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] SX |
||||
*> \verbatim |
||||
*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> 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 ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> single precision vector with N elements |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCY |
||||
*> \verbatim |
||||
*> INCY is INTEGER |
||||
*> storage spacing between elements of SY |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Lawson, C. L., (JPL), Hanson, R. J., (SNLA), |
||||
*> \author Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \ingroup single_blas_level1 |
||||
* |
||||
*> \par Further Details: |
||||
* ===================== |
||||
*> |
||||
*> \verbatim |
||||
*> |
||||
*> 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 |
||||
*> \endverbatim |
||||
*> |
||||
* ===================================================================== |
||||
REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY) |
||||
* |
||||
* -- Reference BLAS level1 routine -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. Scalar Arguments .. |
||||
REAL SB |
||||
INTEGER INCX,INCY,N |
||||
* .. |
||||
* .. Array Arguments .. |
||||
REAL SX(*),SY(*) |
||||
* .. Local Scalars .. |
||||
DOUBLE PRECISION DSDOT |
||||
INTEGER I,KX,KY,NS |
||||
* .. |
||||
* .. Intrinsic Functions .. |
||||
INTRINSIC DBLE |
||||
* .. |
||||
DSDOT = SB |
||||
IF (N.LE.0) THEN |
||||
SDSDOT = REAL(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 = REAL(DSDOT) |
||||
RETURN |
||||
* |
||||
* End of SDSDOT |
||||
* |
||||
END |
||||
@ -0,0 +1,367 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
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 |
||||
JX = JX + INCX |
||||
60 CONTINUE |
||||
ELSE |
||||
DO 80 J = 1,N |
||||
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 |
||||
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 |
||||
@ -0,0 +1,379 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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,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 and NROWB as the number of rows of A |
||||
* and B respectively. |
||||
* |
||||
NOTA = LSAME(TRANSA,'N') |
||||
NOTB = LSAME(TRANSB,'N') |
||||
IF (NOTA) THEN |
||||
NROWA = M |
||||
ELSE |
||||
NROWA = K |
||||
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 |
||||
TEMP = ALPHA*B(L,J) |
||||
DO 70 I = 1,M |
||||
C(I,J) = C(I,J) + TEMP*A(I,L) |
||||
70 CONTINUE |
||||
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 |
||||
TEMP = ALPHA*B(J,L) |
||||
DO 150 I = 1,M |
||||
C(I,J) = C(I,J) + TEMP*A(I,L) |
||||
150 CONTINUE |
||||
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 |
||||
@ -0,0 +1,327 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
TEMP = ALPHA*X(JX) |
||||
DO 50 I = 1,M |
||||
Y(I) = Y(I) + TEMP*A(I,J) |
||||
50 CONTINUE |
||||
JX = JX + INCX |
||||
60 CONTINUE |
||||
ELSE |
||||
DO 80 J = 1,N |
||||
TEMP = ALPHA*X(JX) |
||||
IY = KY |
||||
DO 70 I = 1,M |
||||
Y(IY) = Y(IY) + TEMP*A(I,J) |
||||
IY = IY + INCY |
||||
70 CONTINUE |
||||
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 |
||||
@ -0,0 +1,224 @@ |
||||
*> \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, 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, 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, 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. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
@ -0,0 +1,199 @@ |
||||
!> \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 |
||||
! |
||||
! Arguments: |
||||
! ========== |
||||
! |
||||
!> \param[in] N |
||||
!> \verbatim |
||||
!> N is INTEGER |
||||
!> number of elements in input vector(s) |
||||
!> \endverbatim |
||||
!> |
||||
!> \param[in] X |
||||
!> \verbatim |
||||
!> X is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
!> \endverbatim |
||||
!> |
||||
!> \param[in] INCX |
||||
!> \verbatim |
||||
!> INCX is INTEGER, storage spacing between elements of X |
||||
!> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n |
||||
!> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n |
||||
!> If INCX = 0, x isn't a vector so there is no need to call |
||||
!> this subroutine. If you call it anyway, it will count x(1) |
||||
!> in the vector norm N times. |
||||
!> \endverbatim |
||||
! |
||||
! Authors: |
||||
! ======== |
||||
! |
||||
!> \author Edward Anderson, Lockheed Martin |
||||
! |
||||
!> \date August 2016 |
||||
! |
||||
!> \ingroup single_blas_level1 |
||||
! |
||||
!> \par Contributors: |
||||
! ================== |
||||
!> |
||||
!> Weslley Pereira, University of Colorado Denver, USA |
||||
! |
||||
!> \par Further Details: |
||||
! ===================== |
||||
!> |
||||
!> \verbatim |
||||
!> |
||||
!> Anderson E. (2017) |
||||
!> Algorithm 978: Safe Scaling in the Level 1 BLAS |
||||
!> ACM Trans Math Softw 44:1--28 |
||||
!> https://doi.org/10.1145/3061665 |
||||
!> |
||||
!> Blue, James L. (1978) |
||||
!> A Portable Fortran Program to Find the Euclidean Norm of a Vector |
||||
!> ACM Trans Math Softw 4:15--23 |
||||
!> https://doi.org/10.1145/355769.355771 |
||||
!> |
||||
!> \endverbatim |
||||
!> |
||||
! ===================================================================== |
||||
function SNRM2( n, x, incx ) |
||||
integer, parameter :: wp = kind(1.e0) |
||||
real(wp) :: SNRM2 |
||||
! |
||||
! -- Reference BLAS level1 routine (version 3.9.1) -- |
||||
! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
! March 2021 |
||||
! |
||||
! .. Constants .. |
||||
real(wp), parameter :: zero = 0.0_wp |
||||
real(wp), parameter :: one = 1.0_wp |
||||
real(wp), parameter :: maxN = huge(0.0_wp) |
||||
! .. |
||||
! .. Blue's scaling constants .. |
||||
real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( & |
||||
(minexponent(0._wp) - 1) * 0.5_wp) |
||||
real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( & |
||||
(maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp) |
||||
real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( & |
||||
(minexponent(0._wp) - digits(0._wp)) * 0.5_wp)) |
||||
real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( & |
||||
(maxexponent(0._wp) + digits(0._wp) - 1) * 0.5_wp)) |
||||
! .. |
||||
! .. Scalar Arguments .. |
||||
integer :: incx, n |
||||
! .. |
||||
! .. Array Arguments .. |
||||
real(wp) :: x(*) |
||||
! .. |
||||
! .. Local Scalars .. |
||||
integer :: i, ix |
||||
logical :: notbig |
||||
real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin |
||||
! |
||||
! Quick return if possible |
||||
! |
||||
SNRM2 = zero |
||||
if( n <= 0 ) return |
||||
! |
||||
scl = one |
||||
sumsq = zero |
||||
! |
||||
! Compute the sum of squares in 3 accumulators: |
||||
! abig -- sums of squares scaled down to avoid overflow |
||||
! asml -- sums of squares scaled up to avoid underflow |
||||
! amed -- sums of squares that do not require scaling |
||||
! The thresholds and multipliers are |
||||
! tbig -- values bigger than this are scaled down by sbig |
||||
! tsml -- values smaller than this are scaled up by ssml |
||||
! |
||||
notbig = .true. |
||||
asml = zero |
||||
amed = zero |
||||
abig = zero |
||||
ix = 1 |
||||
if( incx < 0 ) ix = 1 - (n-1)*incx |
||||
do i = 1, n |
||||
ax = abs(x(ix)) |
||||
if (ax > tbig) then |
||||
abig = abig + (ax*sbig)**2 |
||||
notbig = .false. |
||||
else if (ax < tsml) then |
||||
if (notbig) asml = asml + (ax*ssml)**2 |
||||
else |
||||
amed = amed + ax**2 |
||||
end if |
||||
ix = ix + incx |
||||
end do |
||||
! |
||||
! Combine abig and amed or amed and asml if more than one |
||||
! accumulator was used. |
||||
! |
||||
if (abig > zero) then |
||||
! |
||||
! Combine abig and amed if abig > 0. |
||||
! |
||||
if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then |
||||
abig = abig + (amed*sbig)*sbig |
||||
end if |
||||
scl = one / sbig |
||||
sumsq = abig |
||||
else if (asml > zero) then |
||||
! |
||||
! Combine amed and asml if asml > 0. |
||||
! |
||||
if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then |
||||
amed = sqrt(amed) |
||||
asml = sqrt(asml) / ssml |
||||
if (asml > amed) then |
||||
ymin = amed |
||||
ymax = asml |
||||
else |
||||
ymin = asml |
||||
ymax = amed |
||||
end if |
||||
scl = one |
||||
sumsq = ymax**2*( one + (ymin/ymax)**2 ) |
||||
else |
||||
scl = one / ssml |
||||
sumsq = asml |
||||
end if |
||||
else |
||||
! |
||||
! Otherwise all values are mid-range |
||||
! |
||||
scl = one |
||||
sumsq = amed |
||||
end if |
||||
SNRM2 = scl*sqrt( sumsq ) |
||||
return |
||||
end function |
||||
@ -0,0 +1,142 @@ |
||||
*> \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 |
||||
* |
||||
* 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 ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \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 ( 1 + ( N - 1 )*abs( INCY ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCY |
||||
*> \verbatim |
||||
*> INCY is INTEGER |
||||
*> storage spacing between elements of SY |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] C |
||||
*> \verbatim |
||||
*> C is REAL |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] S |
||||
*> \verbatim |
||||
*> S is REAL |
||||
*> \endverbatim |
||||
* |
||||
* Authors: |
||||
* ======== |
||||
* |
||||
*> \author Univ. of Tennessee |
||||
*> \author Univ. of California Berkeley |
||||
*> \author Univ. of Colorado Denver |
||||
*> \author NAG Ltd. |
||||
* |
||||
*> \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 -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of SROT |
||||
* |
||||
END |
||||
@ -0,0 +1,151 @@ |
||||
!> \brief \b SROTG |
||||
! |
||||
! =========== DOCUMENTATION =========== |
||||
! |
||||
! Online html documentation available at |
||||
! http://www.netlib.org/lapack/explore-html/ |
||||
! |
||||
! Definition: |
||||
! =========== |
||||
! |
||||
! SROTG constructs a plane rotation |
||||
! [ c s ] [ a ] = [ r ] |
||||
! [ -s c ] [ b ] [ 0 ] |
||||
! satisfying c**2 + s**2 = 1. |
||||
! |
||||
!> \par Purpose: |
||||
! ============= |
||||
!> |
||||
!> \verbatim |
||||
!> |
||||
!> The computation uses the formulas |
||||
!> sigma = sgn(a) if |a| > |b| |
||||
!> = sgn(b) if |b| >= |a| |
||||
!> r = sigma*sqrt( a**2 + b**2 ) |
||||
!> c = 1; s = 0 if r = 0 |
||||
!> c = a/r; s = b/r if r != 0 |
||||
!> The subroutine also computes |
||||
!> z = s if |a| > |b|, |
||||
!> = 1/c if |b| >= |a| and c != 0 |
||||
!> = 1 if c = 0 |
||||
!> This allows c and s to be reconstructed from z as follows: |
||||
!> If z = 1, set c = 0, s = 1. |
||||
!> If |z| < 1, set c = sqrt(1 - z**2) and s = z. |
||||
!> If |z| > 1, set c = 1/z and s = sqrt( 1 - c**2). |
||||
!> |
||||
!> \endverbatim |
||||
! |
||||
! Arguments: |
||||
! ========== |
||||
! |
||||
!> \param[in,out] A |
||||
!> \verbatim |
||||
!> A is REAL |
||||
!> On entry, the scalar a. |
||||
!> On exit, the scalar r. |
||||
!> \endverbatim |
||||
!> |
||||
!> \param[in,out] B |
||||
!> \verbatim |
||||
!> B is REAL |
||||
!> On entry, the scalar b. |
||||
!> On exit, the scalar z. |
||||
!> \endverbatim |
||||
!> |
||||
!> \param[out] C |
||||
!> \verbatim |
||||
!> C is REAL |
||||
!> The scalar c. |
||||
!> \endverbatim |
||||
!> |
||||
!> \param[out] S |
||||
!> \verbatim |
||||
!> S is REAL |
||||
!> The scalar s. |
||||
!> \endverbatim |
||||
! |
||||
! Authors: |
||||
! ======== |
||||
! |
||||
!> \author Edward Anderson, Lockheed Martin |
||||
! |
||||
!> \par Contributors: |
||||
! ================== |
||||
!> |
||||
!> Weslley Pereira, University of Colorado Denver, USA |
||||
! |
||||
!> \ingroup single_blas_level1 |
||||
! |
||||
!> \par Further Details: |
||||
! ===================== |
||||
!> |
||||
!> \verbatim |
||||
!> |
||||
!> Anderson E. (2017) |
||||
!> Algorithm 978: Safe Scaling in the Level 1 BLAS |
||||
!> ACM Trans Math Softw 44:1--28 |
||||
!> https://doi.org/10.1145/3061665 |
||||
!> |
||||
!> \endverbatim |
||||
! |
||||
! ===================================================================== |
||||
subroutine SROTG( a, b, c, s ) |
||||
integer, parameter :: wp = kind(1.e0) |
||||
! |
||||
! -- Reference BLAS level1 routine -- |
||||
! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
! |
||||
! .. Constants .. |
||||
real(wp), parameter :: zero = 0.0_wp |
||||
real(wp), parameter :: one = 1.0_wp |
||||
! .. |
||||
! .. Scaling constants .. |
||||
real(wp), parameter :: safmin = real(radix(0._wp),wp)**max( & |
||||
minexponent(0._wp)-1, & |
||||
1-maxexponent(0._wp) & |
||||
) |
||||
real(wp), parameter :: safmax = real(radix(0._wp),wp)**max( & |
||||
1-minexponent(0._wp), & |
||||
maxexponent(0._wp)-1 & |
||||
) |
||||
! .. |
||||
! .. Scalar Arguments .. |
||||
real(wp) :: a, b, c, s |
||||
! .. |
||||
! .. Local Scalars .. |
||||
real(wp) :: anorm, bnorm, scl, sigma, r, z |
||||
! .. |
||||
anorm = abs(a) |
||||
bnorm = abs(b) |
||||
if( bnorm == zero ) then |
||||
c = one |
||||
s = zero |
||||
b = zero |
||||
else if( anorm == zero ) then |
||||
c = zero |
||||
s = one |
||||
a = b |
||||
b = one |
||||
else |
||||
scl = min( safmax, max( safmin, anorm, bnorm ) ) |
||||
if( anorm > bnorm ) then |
||||
sigma = sign(one,a) |
||||
else |
||||
sigma = sign(one,b) |
||||
end if |
||||
r = sigma*( scl*sqrt((a/scl)**2 + (b/scl)**2) ) |
||||
c = a/r |
||||
s = b/r |
||||
if( anorm > bnorm ) then |
||||
z = s |
||||
else if( c /= zero ) then |
||||
z = one/c |
||||
else |
||||
z = one |
||||
end if |
||||
a = r |
||||
b = z |
||||
end if |
||||
return |
||||
end subroutine |
||||
@ -0,0 +1,201 @@ |
||||
*> \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 ( 1 + ( N - 1 )*abs( INCX ) ) |
||||
*> \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 ( 1 + ( N - 1 )*abs( INCY ) ) |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] INCY |
||||
*> \verbatim |
||||
*> INCY is INTEGER |
||||
*> storage spacing between elements of SY |
||||
*> \endverbatim |
||||
*> |
||||
*> \param[in] 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. |
||||
* |
||||
*> \ingroup single_blas_level1 |
||||
* |
||||
* ===================================================================== |
||||
SUBROUTINE SROTM(N,SX,INCX,SY,INCY,SPARAM) |
||||
* |
||||
* -- Reference BLAS level1 routine -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 of SROTM |
||||
* |
||||
END |
||||
@ -0,0 +1,260 @@ |
||||
*> \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[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. |
||||
* |
||||
*> \ingroup single_blas_level1 |
||||
* |
||||
* ===================================================================== |
||||
SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM) |
||||
* |
||||
* -- Reference BLAS level1 routine -- |
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- |
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
||||
* |
||||
* .. 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 |
||||
ELSE |
||||
* This code path if here for safety. We do not expect this |
||||
* condition to ever hold except in edge cases with rounding |
||||
* errors. See DOI: 10.1145/355841.355847 |
||||
SFLAG = -ONE |
||||
SH11 = ZERO |
||||
SH12 = ZERO |
||||
SH21 = ZERO |
||||
SH22 = ZERO |
||||
* |
||||
SD1 = ZERO |
||||
SD2 = ZERO |
||||
SX1 = ZERO |
||||
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 |
||||
|
||||
* PROCEDURE..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 of SROTMG |
||||
* |
||||
END |
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue