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