Disabled external gits
This commit is contained in:
451
cs440-acg/ext/eigen/lapack/CMakeLists.txt
Normal file
451
cs440-acg/ext/eigen/lapack/CMakeLists.txt
Normal file
@@ -0,0 +1,451 @@
|
||||
|
||||
project(EigenLapack CXX)
|
||||
|
||||
include("../cmake/language_support.cmake")
|
||||
|
||||
workaround_9220(Fortran EIGEN_Fortran_COMPILER_WORKS)
|
||||
|
||||
if(EIGEN_Fortran_COMPILER_WORKS)
|
||||
enable_language(Fortran OPTIONAL)
|
||||
if(NOT CMAKE_Fortran_COMPILER)
|
||||
set(EIGEN_Fortran_COMPILER_WORKS OFF)
|
||||
endif()
|
||||
endif()
|
||||
|
||||
add_custom_target(lapack)
|
||||
include_directories(../blas)
|
||||
|
||||
set(EigenLapack_SRCS
|
||||
single.cpp double.cpp complex_single.cpp complex_double.cpp ../blas/xerbla.cpp
|
||||
)
|
||||
|
||||
if(EIGEN_Fortran_COMPILER_WORKS)
|
||||
|
||||
set(EigenLapack_SRCS ${EigenLapack_SRCS}
|
||||
slarft.f dlarft.f clarft.f zlarft.f
|
||||
slarfb.f dlarfb.f clarfb.f zlarfb.f
|
||||
slarfg.f dlarfg.f clarfg.f zlarfg.f
|
||||
slarf.f dlarf.f clarf.f zlarf.f
|
||||
sladiv.f dladiv.f cladiv.f zladiv.f
|
||||
ilaslr.f iladlr.f ilaclr.f ilazlr.f
|
||||
ilaslc.f iladlc.f ilaclc.f ilazlc.f
|
||||
dlapy2.f dlapy3.f slapy2.f slapy3.f
|
||||
clacgv.f zlacgv.f
|
||||
slamch.f dlamch.f
|
||||
second_NONE.f dsecnd_NONE.f
|
||||
)
|
||||
|
||||
option(EIGEN_ENABLE_LAPACK_TESTS OFF "Enbale the Lapack unit tests")
|
||||
|
||||
if(EIGEN_ENABLE_LAPACK_TESTS)
|
||||
|
||||
get_filename_component(eigen_full_path_to_reference_lapack "./reference/" ABSOLUTE)
|
||||
if(NOT EXISTS ${eigen_full_path_to_reference_lapack})
|
||||
# Download lapack and install sources and testing at the right place
|
||||
message(STATUS "Download lapack_addons_3.4.1.tgz...")
|
||||
|
||||
file(DOWNLOAD "http://downloads.tuxfamily.org/eigen/lapack_addons_3.4.1.tgz"
|
||||
"${CMAKE_CURRENT_SOURCE_DIR}/lapack_addons_3.4.1.tgz"
|
||||
INACTIVITY_TIMEOUT 15
|
||||
TIMEOUT 240
|
||||
STATUS download_status
|
||||
EXPECTED_MD5 ab5742640617e3221a873aba44bbdc93
|
||||
SHOW_PROGRESS)
|
||||
|
||||
message(STATUS ${download_status})
|
||||
list(GET download_status 0 download_status_num)
|
||||
set(download_status_num 0)
|
||||
if(download_status_num EQUAL 0)
|
||||
message(STATUS "Setup lapack reference and lapack unit tests")
|
||||
execute_process(COMMAND tar xzf "lapack_addons_3.4.1.tgz" WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
|
||||
else()
|
||||
message(STATUS "Download of lapack_addons_3.4.1.tgz failed, LAPACK unit tests wont be enabled")
|
||||
set(EIGEN_ENABLE_LAPACK_TESTS false)
|
||||
endif()
|
||||
|
||||
endif()
|
||||
|
||||
get_filename_component(eigen_full_path_to_reference_lapack "./reference/" ABSOLUTE)
|
||||
if(EXISTS ${eigen_full_path_to_reference_lapack})
|
||||
set(EigenLapack_funcfilenames
|
||||
ssyev.f dsyev.f csyev.f zsyev.f
|
||||
spotrf.f dpotrf.f cpotrf.f zpotrf.f
|
||||
spotrs.f dpotrs.f cpotrs.f zpotrs.f
|
||||
sgetrf.f dgetrf.f cgetrf.f zgetrf.f
|
||||
sgetrs.f dgetrs.f cgetrs.f zgetrs.f)
|
||||
|
||||
FILE(GLOB ReferenceLapack_SRCS0 RELATIVE ${CMAKE_CURRENT_SOURCE_DIR} "reference/*.f")
|
||||
foreach(filename1 IN LISTS ReferenceLapack_SRCS0)
|
||||
string(REPLACE "reference/" "" filename ${filename1})
|
||||
list(FIND EigenLapack_SRCS ${filename} id1)
|
||||
list(FIND EigenLapack_funcfilenames ${filename} id2)
|
||||
if((id1 EQUAL -1) AND (id2 EQUAL -1))
|
||||
set(ReferenceLapack_SRCS ${ReferenceLapack_SRCS} reference/${filename})
|
||||
endif()
|
||||
endforeach()
|
||||
endif()
|
||||
|
||||
|
||||
endif(EIGEN_ENABLE_LAPACK_TESTS)
|
||||
|
||||
endif(EIGEN_Fortran_COMPILER_WORKS)
|
||||
|
||||
add_library(eigen_lapack_static ${EigenLapack_SRCS} ${ReferenceLapack_SRCS})
|
||||
add_library(eigen_lapack SHARED ${EigenLapack_SRCS})
|
||||
|
||||
target_link_libraries(eigen_lapack eigen_blas)
|
||||
|
||||
if(EIGEN_STANDARD_LIBRARIES_TO_LINK_TO)
|
||||
target_link_libraries(eigen_lapack_static ${EIGEN_STANDARD_LIBRARIES_TO_LINK_TO})
|
||||
target_link_libraries(eigen_lapack ${EIGEN_STANDARD_LIBRARIES_TO_LINK_TO})
|
||||
endif()
|
||||
|
||||
add_dependencies(lapack eigen_lapack eigen_lapack_static)
|
||||
|
||||
install(TARGETS eigen_lapack eigen_lapack_static
|
||||
RUNTIME DESTINATION bin
|
||||
LIBRARY DESTINATION lib
|
||||
ARCHIVE DESTINATION lib)
|
||||
|
||||
|
||||
|
||||
get_filename_component(eigen_full_path_to_testing_lapack "./testing/" ABSOLUTE)
|
||||
if(EXISTS ${eigen_full_path_to_testing_lapack})
|
||||
|
||||
# The following comes from lapack/TESTING/CMakeLists.txt
|
||||
# Get Python
|
||||
find_package(PythonInterp)
|
||||
message(STATUS "Looking for Python found - ${PYTHONINTERP_FOUND}")
|
||||
if (PYTHONINTERP_FOUND)
|
||||
message(STATUS "Using Python version ${PYTHON_VERSION_STRING}")
|
||||
endif()
|
||||
|
||||
set(LAPACK_SOURCE_DIR ${CMAKE_CURRENT_SOURCE_DIR})
|
||||
set(LAPACK_BINARY_DIR ${CMAKE_CURRENT_BINARY_DIR})
|
||||
set(BUILD_SINGLE true)
|
||||
set(BUILD_DOUBLE true)
|
||||
set(BUILD_COMPLEX true)
|
||||
set(BUILD_COMPLEX16E true)
|
||||
|
||||
if(MSVC_VERSION)
|
||||
# string(REPLACE "/STACK:10000000" "/STACK:900000000000000000"
|
||||
# CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS}")
|
||||
string(REGEX REPLACE "(.*)/STACK:(.*) (.*)" "\\1/STACK:900000000000000000 \\3"
|
||||
CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS}")
|
||||
endif()
|
||||
file(MAKE_DIRECTORY "${LAPACK_BINARY_DIR}/TESTING")
|
||||
add_subdirectory(testing/MATGEN)
|
||||
add_subdirectory(testing/LIN)
|
||||
add_subdirectory(testing/EIG)
|
||||
cmake_policy(SET CMP0026 OLD)
|
||||
macro(add_lapack_test output input target)
|
||||
set(TEST_INPUT "${LAPACK_SOURCE_DIR}/testing/${input}")
|
||||
set(TEST_OUTPUT "${LAPACK_BINARY_DIR}/TESTING/${output}")
|
||||
get_target_property(TEST_LOC ${target} LOCATION)
|
||||
string(REPLACE "." "_" input_name ${input})
|
||||
set(testName "${target}_${input_name}")
|
||||
if(EXISTS "${TEST_INPUT}")
|
||||
add_test(LAPACK-${testName} "${CMAKE_COMMAND}"
|
||||
-DTEST=${TEST_LOC}
|
||||
-DINPUT=${TEST_INPUT}
|
||||
-DOUTPUT=${TEST_OUTPUT}
|
||||
-DINTDIR=${CMAKE_CFG_INTDIR}
|
||||
-P "${LAPACK_SOURCE_DIR}/testing/runtest.cmake")
|
||||
endif()
|
||||
endmacro(add_lapack_test)
|
||||
|
||||
if (BUILD_SINGLE)
|
||||
add_lapack_test(stest.out stest.in xlintsts)
|
||||
#
|
||||
# ======== SINGLE RFP LIN TESTS ========================
|
||||
add_lapack_test(stest_rfp.out stest_rfp.in xlintstrfs)
|
||||
#
|
||||
#
|
||||
# ======== SINGLE EIG TESTS ===========================
|
||||
#
|
||||
|
||||
add_lapack_test(snep.out nep.in xeigtsts)
|
||||
|
||||
|
||||
add_lapack_test(ssep.out sep.in xeigtsts)
|
||||
|
||||
|
||||
add_lapack_test(ssvd.out svd.in xeigtsts)
|
||||
|
||||
|
||||
add_lapack_test(sec.out sec.in xeigtsts)
|
||||
|
||||
|
||||
add_lapack_test(sed.out sed.in xeigtsts)
|
||||
|
||||
|
||||
add_lapack_test(sgg.out sgg.in xeigtsts)
|
||||
|
||||
|
||||
add_lapack_test(sgd.out sgd.in xeigtsts)
|
||||
|
||||
|
||||
add_lapack_test(ssb.out ssb.in xeigtsts)
|
||||
|
||||
|
||||
add_lapack_test(ssg.out ssg.in xeigtsts)
|
||||
|
||||
|
||||
add_lapack_test(sbal.out sbal.in xeigtsts)
|
||||
|
||||
|
||||
add_lapack_test(sbak.out sbak.in xeigtsts)
|
||||
|
||||
|
||||
add_lapack_test(sgbal.out sgbal.in xeigtsts)
|
||||
|
||||
|
||||
add_lapack_test(sgbak.out sgbak.in xeigtsts)
|
||||
|
||||
|
||||
add_lapack_test(sbb.out sbb.in xeigtsts)
|
||||
|
||||
|
||||
add_lapack_test(sglm.out glm.in xeigtsts)
|
||||
|
||||
|
||||
add_lapack_test(sgqr.out gqr.in xeigtsts)
|
||||
|
||||
|
||||
add_lapack_test(sgsv.out gsv.in xeigtsts)
|
||||
|
||||
|
||||
add_lapack_test(scsd.out csd.in xeigtsts)
|
||||
|
||||
|
||||
add_lapack_test(slse.out lse.in xeigtsts)
|
||||
endif()
|
||||
|
||||
if (BUILD_DOUBLE)
|
||||
#
|
||||
# ======== DOUBLE LIN TESTS ===========================
|
||||
add_lapack_test(dtest.out dtest.in xlintstd)
|
||||
#
|
||||
# ======== DOUBLE RFP LIN TESTS ========================
|
||||
add_lapack_test(dtest_rfp.out dtest_rfp.in xlintstrfd)
|
||||
#
|
||||
# ======== DOUBLE EIG TESTS ===========================
|
||||
|
||||
add_lapack_test(dnep.out nep.in xeigtstd)
|
||||
|
||||
|
||||
add_lapack_test(dsep.out sep.in xeigtstd)
|
||||
|
||||
|
||||
add_lapack_test(dsvd.out svd.in xeigtstd)
|
||||
|
||||
|
||||
add_lapack_test(dec.out dec.in xeigtstd)
|
||||
|
||||
|
||||
add_lapack_test(ded.out ded.in xeigtstd)
|
||||
|
||||
|
||||
add_lapack_test(dgg.out dgg.in xeigtstd)
|
||||
|
||||
|
||||
add_lapack_test(dgd.out dgd.in xeigtstd)
|
||||
|
||||
|
||||
add_lapack_test(dsb.out dsb.in xeigtstd)
|
||||
|
||||
|
||||
add_lapack_test(dsg.out dsg.in xeigtstd)
|
||||
|
||||
|
||||
add_lapack_test(dbal.out dbal.in xeigtstd)
|
||||
|
||||
|
||||
add_lapack_test(dbak.out dbak.in xeigtstd)
|
||||
|
||||
|
||||
add_lapack_test(dgbal.out dgbal.in xeigtstd)
|
||||
|
||||
|
||||
add_lapack_test(dgbak.out dgbak.in xeigtstd)
|
||||
|
||||
|
||||
add_lapack_test(dbb.out dbb.in xeigtstd)
|
||||
|
||||
|
||||
add_lapack_test(dglm.out glm.in xeigtstd)
|
||||
|
||||
|
||||
add_lapack_test(dgqr.out gqr.in xeigtstd)
|
||||
|
||||
|
||||
add_lapack_test(dgsv.out gsv.in xeigtstd)
|
||||
|
||||
|
||||
add_lapack_test(dcsd.out csd.in xeigtstd)
|
||||
|
||||
|
||||
add_lapack_test(dlse.out lse.in xeigtstd)
|
||||
endif()
|
||||
|
||||
if (BUILD_COMPLEX)
|
||||
add_lapack_test(ctest.out ctest.in xlintstc)
|
||||
#
|
||||
# ======== COMPLEX RFP LIN TESTS ========================
|
||||
add_lapack_test(ctest_rfp.out ctest_rfp.in xlintstrfc)
|
||||
#
|
||||
# ======== COMPLEX EIG TESTS ===========================
|
||||
|
||||
add_lapack_test(cnep.out nep.in xeigtstc)
|
||||
|
||||
|
||||
add_lapack_test(csep.out sep.in xeigtstc)
|
||||
|
||||
|
||||
add_lapack_test(csvd.out svd.in xeigtstc)
|
||||
|
||||
|
||||
add_lapack_test(cec.out cec.in xeigtstc)
|
||||
|
||||
|
||||
add_lapack_test(ced.out ced.in xeigtstc)
|
||||
|
||||
|
||||
add_lapack_test(cgg.out cgg.in xeigtstc)
|
||||
|
||||
|
||||
add_lapack_test(cgd.out cgd.in xeigtstc)
|
||||
|
||||
|
||||
add_lapack_test(csb.out csb.in xeigtstc)
|
||||
|
||||
|
||||
add_lapack_test(csg.out csg.in xeigtstc)
|
||||
|
||||
|
||||
add_lapack_test(cbal.out cbal.in xeigtstc)
|
||||
|
||||
|
||||
add_lapack_test(cbak.out cbak.in xeigtstc)
|
||||
|
||||
|
||||
add_lapack_test(cgbal.out cgbal.in xeigtstc)
|
||||
|
||||
|
||||
add_lapack_test(cgbak.out cgbak.in xeigtstc)
|
||||
|
||||
|
||||
add_lapack_test(cbb.out cbb.in xeigtstc)
|
||||
|
||||
|
||||
add_lapack_test(cglm.out glm.in xeigtstc)
|
||||
|
||||
|
||||
add_lapack_test(cgqr.out gqr.in xeigtstc)
|
||||
|
||||
|
||||
add_lapack_test(cgsv.out gsv.in xeigtstc)
|
||||
|
||||
|
||||
add_lapack_test(ccsd.out csd.in xeigtstc)
|
||||
|
||||
|
||||
add_lapack_test(clse.out lse.in xeigtstc)
|
||||
endif()
|
||||
|
||||
if (BUILD_COMPLEX16)
|
||||
#
|
||||
# ======== COMPLEX16 LIN TESTS ========================
|
||||
add_lapack_test(ztest.out ztest.in xlintstz)
|
||||
#
|
||||
# ======== COMPLEX16 RFP LIN TESTS ========================
|
||||
add_lapack_test(ztest_rfp.out ztest_rfp.in xlintstrfz)
|
||||
#
|
||||
# ======== COMPLEX16 EIG TESTS ===========================
|
||||
|
||||
add_lapack_test(znep.out nep.in xeigtstz)
|
||||
|
||||
|
||||
add_lapack_test(zsep.out sep.in xeigtstz)
|
||||
|
||||
|
||||
add_lapack_test(zsvd.out svd.in xeigtstz)
|
||||
|
||||
|
||||
add_lapack_test(zec.out zec.in xeigtstz)
|
||||
|
||||
|
||||
add_lapack_test(zed.out zed.in xeigtstz)
|
||||
|
||||
|
||||
add_lapack_test(zgg.out zgg.in xeigtstz)
|
||||
|
||||
|
||||
add_lapack_test(zgd.out zgd.in xeigtstz)
|
||||
|
||||
|
||||
add_lapack_test(zsb.out zsb.in xeigtstz)
|
||||
|
||||
|
||||
add_lapack_test(zsg.out zsg.in xeigtstz)
|
||||
|
||||
|
||||
add_lapack_test(zbal.out zbal.in xeigtstz)
|
||||
|
||||
|
||||
add_lapack_test(zbak.out zbak.in xeigtstz)
|
||||
|
||||
|
||||
add_lapack_test(zgbal.out zgbal.in xeigtstz)
|
||||
|
||||
|
||||
add_lapack_test(zgbak.out zgbak.in xeigtstz)
|
||||
|
||||
|
||||
add_lapack_test(zbb.out zbb.in xeigtstz)
|
||||
|
||||
|
||||
add_lapack_test(zglm.out glm.in xeigtstz)
|
||||
|
||||
|
||||
add_lapack_test(zgqr.out gqr.in xeigtstz)
|
||||
|
||||
|
||||
add_lapack_test(zgsv.out gsv.in xeigtstz)
|
||||
|
||||
|
||||
add_lapack_test(zcsd.out csd.in xeigtstz)
|
||||
|
||||
|
||||
add_lapack_test(zlse.out lse.in xeigtstz)
|
||||
endif()
|
||||
|
||||
|
||||
if (BUILD_SIMPLE)
|
||||
if (BUILD_DOUBLE)
|
||||
#
|
||||
# ======== SINGLE-DOUBLE PROTO LIN TESTS ==============
|
||||
add_lapack_test(dstest.out dstest.in xlintstds)
|
||||
endif()
|
||||
endif()
|
||||
|
||||
|
||||
if (BUILD_COMPLEX)
|
||||
if (BUILD_COMPLEX16)
|
||||
#
|
||||
# ======== COMPLEX-COMPLEX16 LIN TESTS ========================
|
||||
add_lapack_test(zctest.out zctest.in xlintstzc)
|
||||
endif()
|
||||
endif()
|
||||
|
||||
# ==============================================================================
|
||||
|
||||
execute_process(COMMAND ${CMAKE_COMMAND} -E copy ${LAPACK_SOURCE_DIR}/testing/lapack_testing.py ${LAPACK_BINARY_DIR})
|
||||
add_test(
|
||||
NAME LAPACK_Test_Summary
|
||||
WORKING_DIRECTORY ${LAPACK_BINARY_DIR}
|
||||
COMMAND ${PYTHON_EXECUTABLE} "lapack_testing.py"
|
||||
)
|
||||
|
||||
endif()
|
||||
|
||||
72
cs440-acg/ext/eigen/lapack/cholesky.cpp
Normal file
72
cs440-acg/ext/eigen/lapack/cholesky.cpp
Normal file
@@ -0,0 +1,72 @@
|
||||
// This file is part of Eigen, a lightweight C++ template library
|
||||
// for linear algebra.
|
||||
//
|
||||
// Copyright (C) 2010-2011 Gael Guennebaud <gael.guennebaud@inria.fr>
|
||||
//
|
||||
// This Source Code Form is subject to the terms of the Mozilla
|
||||
// Public License v. 2.0. If a copy of the MPL was not distributed
|
||||
// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
#include "lapack_common.h"
|
||||
#include <Eigen/Cholesky>
|
||||
|
||||
// POTRF computes the Cholesky factorization of a real symmetric positive definite matrix A.
|
||||
EIGEN_LAPACK_FUNC(potrf,(char* uplo, int *n, RealScalar *pa, int *lda, int *info))
|
||||
{
|
||||
*info = 0;
|
||||
if(UPLO(*uplo)==INVALID) *info = -1;
|
||||
else if(*n<0) *info = -2;
|
||||
else if(*lda<std::max(1,*n)) *info = -4;
|
||||
if(*info!=0)
|
||||
{
|
||||
int e = -*info;
|
||||
return xerbla_(SCALAR_SUFFIX_UP"POTRF", &e, 6);
|
||||
}
|
||||
|
||||
Scalar* a = reinterpret_cast<Scalar*>(pa);
|
||||
MatrixType A(a,*n,*n,*lda);
|
||||
int ret;
|
||||
if(UPLO(*uplo)==UP) ret = int(internal::llt_inplace<Scalar, Upper>::blocked(A));
|
||||
else ret = int(internal::llt_inplace<Scalar, Lower>::blocked(A));
|
||||
|
||||
if(ret>=0)
|
||||
*info = ret+1;
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
// POTRS solves a system of linear equations A*X = B with a symmetric
|
||||
// positive definite matrix A using the Cholesky factorization
|
||||
// A = U**T*U or A = L*L**T computed by DPOTRF.
|
||||
EIGEN_LAPACK_FUNC(potrs,(char* uplo, int *n, int *nrhs, RealScalar *pa, int *lda, RealScalar *pb, int *ldb, int *info))
|
||||
{
|
||||
*info = 0;
|
||||
if(UPLO(*uplo)==INVALID) *info = -1;
|
||||
else if(*n<0) *info = -2;
|
||||
else if(*nrhs<0) *info = -3;
|
||||
else if(*lda<std::max(1,*n)) *info = -5;
|
||||
else if(*ldb<std::max(1,*n)) *info = -7;
|
||||
if(*info!=0)
|
||||
{
|
||||
int e = -*info;
|
||||
return xerbla_(SCALAR_SUFFIX_UP"POTRS", &e, 6);
|
||||
}
|
||||
|
||||
Scalar* a = reinterpret_cast<Scalar*>(pa);
|
||||
Scalar* b = reinterpret_cast<Scalar*>(pb);
|
||||
MatrixType A(a,*n,*n,*lda);
|
||||
MatrixType B(b,*n,*nrhs,*ldb);
|
||||
|
||||
if(UPLO(*uplo)==UP)
|
||||
{
|
||||
A.triangularView<Upper>().adjoint().solveInPlace(B);
|
||||
A.triangularView<Upper>().solveInPlace(B);
|
||||
}
|
||||
else
|
||||
{
|
||||
A.triangularView<Lower>().solveInPlace(B);
|
||||
A.triangularView<Lower>().adjoint().solveInPlace(B);
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
116
cs440-acg/ext/eigen/lapack/clacgv.f
Normal file
116
cs440-acg/ext/eigen/lapack/clacgv.f
Normal file
@@ -0,0 +1,116 @@
|
||||
*> \brief \b CLACGV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download CLACGV + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clacgv.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clacgv.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clacgv.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CLACGV( N, X, INCX )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX X( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CLACGV conjugates a complex vector of length N.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The length of the vector X. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array, dimension
|
||||
*> (1+(N-1)*abs(INCX))
|
||||
*> On entry, the vector of length N to be conjugated.
|
||||
*> On exit, X is overwritten with conjg(X).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> The spacing between successive elements of X.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complexOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE CLACGV( N, X, INCX )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX X( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, IOFF
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( INCX.EQ.1 ) THEN
|
||||
DO 10 I = 1, N
|
||||
X( I ) = CONJG( X( I ) )
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
IOFF = 1
|
||||
IF( INCX.LT.0 )
|
||||
$ IOFF = 1 - ( N-1 )*INCX
|
||||
DO 20 I = 1, N
|
||||
X( IOFF ) = CONJG( X( IOFF ) )
|
||||
IOFF = IOFF + INCX
|
||||
20 CONTINUE
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of CLACGV
|
||||
*
|
||||
END
|
||||
97
cs440-acg/ext/eigen/lapack/cladiv.f
Normal file
97
cs440-acg/ext/eigen/lapack/cladiv.f
Normal file
@@ -0,0 +1,97 @@
|
||||
*> \brief \b CLADIV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download CLADIV + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cladiv.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cladiv.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cladiv.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* COMPLEX FUNCTION CLADIV( X, Y )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX X, Y
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CLADIV := X / Y, where X and Y are complex. The computation of X / Y
|
||||
*> will not overflow on an intermediary step unless the results
|
||||
*> overflows.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] Y
|
||||
*> \verbatim
|
||||
*> Y is COMPLEX
|
||||
*> The complex scalars X and Y.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complexOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
COMPLEX FUNCTION CLADIV( X, Y )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX X, Y
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
REAL ZI, ZR
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL SLADIV
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC AIMAG, CMPLX, REAL
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
CALL SLADIV( REAL( X ), AIMAG( X ), REAL( Y ), AIMAG( Y ), ZR,
|
||||
$ ZI )
|
||||
CLADIV = CMPLX( ZR, ZI )
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CLADIV
|
||||
*
|
||||
END
|
||||
232
cs440-acg/ext/eigen/lapack/clarf.f
Normal file
232
cs440-acg/ext/eigen/lapack/clarf.f
Normal file
@@ -0,0 +1,232 @@
|
||||
*> \brief \b CLARF
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download CLARF + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clarf.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clarf.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clarf.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER SIDE
|
||||
* INTEGER INCV, LDC, M, N
|
||||
* COMPLEX TAU
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX C( LDC, * ), V( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CLARF applies a complex elementary reflector H to a complex M-by-N
|
||||
*> matrix C, from either the left or the right. H is represented in the
|
||||
*> form
|
||||
*>
|
||||
*> H = I - tau * v * v**H
|
||||
*>
|
||||
*> where tau is a complex scalar and v is a complex vector.
|
||||
*>
|
||||
*> If tau = 0, then H is taken to be the unit matrix.
|
||||
*>
|
||||
*> To apply H**H (the conjugate transpose of H), supply conjg(tau) instead
|
||||
*> tau.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> = 'L': form H * C
|
||||
*> = 'R': form C * H
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] V
|
||||
*> \verbatim
|
||||
*> V is COMPLEX array, dimension
|
||||
*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
|
||||
*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
|
||||
*> The vector v in the representation of H. V is not used if
|
||||
*> TAU = 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCV
|
||||
*> \verbatim
|
||||
*> INCV is INTEGER
|
||||
*> The increment between elements of v. INCV <> 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TAU
|
||||
*> \verbatim
|
||||
*> TAU is COMPLEX
|
||||
*> The value tau in the representation of H.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is COMPLEX array, dimension (LDC,N)
|
||||
*> On entry, the M-by-N matrix C.
|
||||
*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
|
||||
*> or C * H if SIDE = 'R'.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> The leading dimension of the array C. LDC >= max(1,M).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX array, dimension
|
||||
*> (N) if SIDE = 'L'
|
||||
*> or (M) if SIDE = 'R'
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complexOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE CLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER SIDE
|
||||
INTEGER INCV, LDC, M, N
|
||||
COMPLEX TAU
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX C( LDC, * ), V( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ONE, ZERO
|
||||
PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ),
|
||||
$ ZERO = ( 0.0E+0, 0.0E+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
LOGICAL APPLYLEFT
|
||||
INTEGER I, LASTV, LASTC
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL CGEMV, CGERC
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
INTEGER ILACLR, ILACLC
|
||||
EXTERNAL LSAME, ILACLR, ILACLC
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
APPLYLEFT = LSAME( SIDE, 'L' )
|
||||
LASTV = 0
|
||||
LASTC = 0
|
||||
IF( TAU.NE.ZERO ) THEN
|
||||
! Set up variables for scanning V. LASTV begins pointing to the end
|
||||
! of V.
|
||||
IF( APPLYLEFT ) THEN
|
||||
LASTV = M
|
||||
ELSE
|
||||
LASTV = N
|
||||
END IF
|
||||
IF( INCV.GT.0 ) THEN
|
||||
I = 1 + (LASTV-1) * INCV
|
||||
ELSE
|
||||
I = 1
|
||||
END IF
|
||||
! Look for the last non-zero row in V.
|
||||
DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
|
||||
LASTV = LASTV - 1
|
||||
I = I - INCV
|
||||
END DO
|
||||
IF( APPLYLEFT ) THEN
|
||||
! Scan for the last non-zero column in C(1:lastv,:).
|
||||
LASTC = ILACLC(LASTV, N, C, LDC)
|
||||
ELSE
|
||||
! Scan for the last non-zero row in C(:,1:lastv).
|
||||
LASTC = ILACLR(M, LASTV, C, LDC)
|
||||
END IF
|
||||
END IF
|
||||
! Note that lastc.eq.0 renders the BLAS operations null; no special
|
||||
! case is needed at this level.
|
||||
IF( APPLYLEFT ) THEN
|
||||
*
|
||||
* Form H * C
|
||||
*
|
||||
IF( LASTV.GT.0 ) THEN
|
||||
*
|
||||
* w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1)
|
||||
*
|
||||
CALL CGEMV( 'Conjugate transpose', LASTV, LASTC, ONE,
|
||||
$ C, LDC, V, INCV, ZERO, WORK, 1 )
|
||||
*
|
||||
* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**H
|
||||
*
|
||||
CALL CGERC( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form C * H
|
||||
*
|
||||
IF( LASTV.GT.0 ) THEN
|
||||
*
|
||||
* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
|
||||
*
|
||||
CALL CGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
|
||||
$ V, INCV, ZERO, WORK, 1 )
|
||||
*
|
||||
* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**H
|
||||
*
|
||||
CALL CGERC( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
|
||||
END IF
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of CLARF
|
||||
*
|
||||
END
|
||||
771
cs440-acg/ext/eigen/lapack/clarfb.f
Normal file
771
cs440-acg/ext/eigen/lapack/clarfb.f
Normal file
@@ -0,0 +1,771 @@
|
||||
*> \brief \b CLARFB
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download CLARFB + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clarfb.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clarfb.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clarfb.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
|
||||
* T, LDT, C, LDC, WORK, LDWORK )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER DIRECT, SIDE, STOREV, TRANS
|
||||
* INTEGER K, LDC, LDT, LDV, LDWORK, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX C( LDC, * ), T( LDT, * ), V( LDV, * ),
|
||||
* $ WORK( LDWORK, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CLARFB applies a complex block reflector H or its transpose H**H to a
|
||||
*> complex M-by-N matrix C, from either the left or the right.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> = 'L': apply H or H**H from the Left
|
||||
*> = 'R': apply H or H**H from the Right
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> = 'N': apply H (No transpose)
|
||||
*> = 'C': apply H**H (Conjugate transpose)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIRECT
|
||||
*> \verbatim
|
||||
*> DIRECT is CHARACTER*1
|
||||
*> Indicates how H is formed from a product of elementary
|
||||
*> reflectors
|
||||
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
|
||||
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] STOREV
|
||||
*> \verbatim
|
||||
*> STOREV is CHARACTER*1
|
||||
*> Indicates how the vectors which define the elementary
|
||||
*> reflectors are stored:
|
||||
*> = 'C': Columnwise
|
||||
*> = 'R': Rowwise
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The order of the matrix T (= the number of elementary
|
||||
*> reflectors whose product defines the block reflector).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] V
|
||||
*> \verbatim
|
||||
*> V is COMPLEX array, dimension
|
||||
*> (LDV,K) if STOREV = 'C'
|
||||
*> (LDV,M) if STOREV = 'R' and SIDE = 'L'
|
||||
*> (LDV,N) if STOREV = 'R' and SIDE = 'R'
|
||||
*> The matrix V. See Further Details.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDV
|
||||
*> \verbatim
|
||||
*> LDV is INTEGER
|
||||
*> The leading dimension of the array V.
|
||||
*> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
|
||||
*> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
|
||||
*> if STOREV = 'R', LDV >= K.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] T
|
||||
*> \verbatim
|
||||
*> T is COMPLEX array, dimension (LDT,K)
|
||||
*> The triangular K-by-K matrix T in the representation of the
|
||||
*> block reflector.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDT
|
||||
*> \verbatim
|
||||
*> LDT is INTEGER
|
||||
*> The leading dimension of the array T. LDT >= K.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is COMPLEX array, dimension (LDC,N)
|
||||
*> On entry, the M-by-N matrix C.
|
||||
*> On exit, C is overwritten by H*C or H**H*C or C*H or C*H**H.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> The leading dimension of the array C. LDC >= max(1,M).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX array, dimension (LDWORK,K)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDWORK
|
||||
*> \verbatim
|
||||
*> LDWORK is INTEGER
|
||||
*> The leading dimension of the array WORK.
|
||||
*> If SIDE = 'L', LDWORK >= max(1,N);
|
||||
*> if SIDE = 'R', LDWORK >= max(1,M).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complexOTHERauxiliary
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> The shape of the matrix V and the storage of the vectors which define
|
||||
*> the H(i) is best illustrated by the following example with n = 5 and
|
||||
*> k = 3. The elements equal to 1 are not stored; the corresponding
|
||||
*> array elements are modified but restored on exit. The rest of the
|
||||
*> array is not used.
|
||||
*>
|
||||
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
|
||||
*>
|
||||
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
|
||||
*> ( v1 1 ) ( 1 v2 v2 v2 )
|
||||
*> ( v1 v2 1 ) ( 1 v3 v3 )
|
||||
*> ( v1 v2 v3 )
|
||||
*> ( v1 v2 v3 )
|
||||
*>
|
||||
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
|
||||
*>
|
||||
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
|
||||
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
|
||||
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
|
||||
*> ( 1 v3 )
|
||||
*> ( 1 )
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
|
||||
$ T, LDT, C, LDC, WORK, LDWORK )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER DIRECT, SIDE, STOREV, TRANS
|
||||
INTEGER K, LDC, LDT, LDV, LDWORK, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX C( LDC, * ), T( LDT, * ), V( LDV, * ),
|
||||
$ WORK( LDWORK, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ONE
|
||||
PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
CHARACTER TRANST
|
||||
INTEGER I, J, LASTV, LASTC
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
INTEGER ILACLR, ILACLC
|
||||
EXTERNAL LSAME, ILACLR, ILACLC
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL CCOPY, CGEMM, CLACGV, CTRMM
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( M.LE.0 .OR. N.LE.0 )
|
||||
$ RETURN
|
||||
*
|
||||
IF( LSAME( TRANS, 'N' ) ) THEN
|
||||
TRANST = 'C'
|
||||
ELSE
|
||||
TRANST = 'N'
|
||||
END IF
|
||||
*
|
||||
IF( LSAME( STOREV, 'C' ) ) THEN
|
||||
*
|
||||
IF( LSAME( DIRECT, 'F' ) ) THEN
|
||||
*
|
||||
* Let V = ( V1 ) (first K rows)
|
||||
* ( V2 )
|
||||
* where V1 is unit lower triangular.
|
||||
*
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
*
|
||||
* Form H * C or H**H * C where C = ( C1 )
|
||||
* ( C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILACLR( M, K, V, LDV ) )
|
||||
LASTC = ILACLC( LASTV, N, C, LDC )
|
||||
*
|
||||
* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK)
|
||||
*
|
||||
* W := C1**H
|
||||
*
|
||||
DO 10 J = 1, K
|
||||
CALL CCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
|
||||
CALL CLACGV( LASTC, WORK( 1, J ), 1 )
|
||||
10 CONTINUE
|
||||
*
|
||||
* W := W * V1
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C2**H *V2
|
||||
*
|
||||
CALL CGEMM( 'Conjugate transpose', 'No transpose',
|
||||
$ LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC,
|
||||
$ V( K+1, 1 ), LDV, ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T**H or W * T
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - V * W**H
|
||||
*
|
||||
IF( M.GT.K ) THEN
|
||||
*
|
||||
* C2 := C2 - V2 * W**H
|
||||
*
|
||||
CALL CGEMM( 'No transpose', 'Conjugate transpose',
|
||||
$ LASTV-K, LASTC, K, -ONE, V( K+1, 1 ), LDV,
|
||||
$ WORK, LDWORK, ONE, C( K+1, 1 ), LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V1**H
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W**H
|
||||
*
|
||||
DO 30 J = 1, K
|
||||
DO 20 I = 1, LASTC
|
||||
C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) )
|
||||
20 CONTINUE
|
||||
30 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
*
|
||||
* Form C * H or C * H**H where C = ( C1 C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILACLR( N, K, V, LDV ) )
|
||||
LASTC = ILACLR( M, LASTV, C, LDC )
|
||||
*
|
||||
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
|
||||
*
|
||||
* W := C1
|
||||
*
|
||||
DO 40 J = 1, K
|
||||
CALL CCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
|
||||
40 CONTINUE
|
||||
*
|
||||
* W := W * V1
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C2 * V2
|
||||
*
|
||||
CALL CGEMM( 'No transpose', 'No transpose',
|
||||
$ LASTC, K, LASTV-K,
|
||||
$ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T or W * T**H
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - W * V**H
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C2 := C2 - W * V2**H
|
||||
*
|
||||
CALL CGEMM( 'No transpose', 'Conjugate transpose',
|
||||
$ LASTC, LASTV-K, K,
|
||||
$ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV,
|
||||
$ ONE, C( 1, K+1 ), LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V1**H
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W
|
||||
*
|
||||
DO 60 J = 1, K
|
||||
DO 50 I = 1, LASTC
|
||||
C( I, J ) = C( I, J ) - WORK( I, J )
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
END IF
|
||||
*
|
||||
ELSE
|
||||
*
|
||||
* Let V = ( V1 )
|
||||
* ( V2 ) (last K rows)
|
||||
* where V2 is unit upper triangular.
|
||||
*
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
*
|
||||
* Form H * C or H**H * C where C = ( C1 )
|
||||
* ( C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILACLR( M, K, V, LDV ) )
|
||||
LASTC = ILACLC( LASTV, N, C, LDC )
|
||||
*
|
||||
* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK)
|
||||
*
|
||||
* W := C2**H
|
||||
*
|
||||
DO 70 J = 1, K
|
||||
CALL CCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
|
||||
$ WORK( 1, J ), 1 )
|
||||
CALL CLACGV( LASTC, WORK( 1, J ), 1 )
|
||||
70 CONTINUE
|
||||
*
|
||||
* W := W * V2
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C1**H*V1
|
||||
*
|
||||
CALL CGEMM( 'Conjugate transpose', 'No transpose',
|
||||
$ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T**H or W * T
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - V * W**H
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C1 := C1 - V1 * W**H
|
||||
*
|
||||
CALL CGEMM( 'No transpose', 'Conjugate transpose',
|
||||
$ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
|
||||
$ ONE, C, LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V2**H
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
*
|
||||
* C2 := C2 - W**H
|
||||
*
|
||||
DO 90 J = 1, K
|
||||
DO 80 I = 1, LASTC
|
||||
C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
|
||||
$ CONJG( WORK( I, J ) )
|
||||
80 CONTINUE
|
||||
90 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
*
|
||||
* Form C * H or C * H**H where C = ( C1 C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILACLR( N, K, V, LDV ) )
|
||||
LASTC = ILACLR( M, LASTV, C, LDC )
|
||||
*
|
||||
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
|
||||
*
|
||||
* W := C2
|
||||
*
|
||||
DO 100 J = 1, K
|
||||
CALL CCOPY( LASTC, C( 1, LASTV-K+J ), 1,
|
||||
$ WORK( 1, J ), 1 )
|
||||
100 CONTINUE
|
||||
*
|
||||
* W := W * V2
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C1 * V1
|
||||
*
|
||||
CALL CGEMM( 'No transpose', 'No transpose',
|
||||
$ LASTC, K, LASTV-K,
|
||||
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T or W * T**H
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - W * V**H
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C1 := C1 - W * V1**H
|
||||
*
|
||||
CALL CGEMM( 'No transpose', 'Conjugate transpose',
|
||||
$ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
|
||||
$ ONE, C, LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V2**H
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
*
|
||||
* C2 := C2 - W
|
||||
*
|
||||
DO 120 J = 1, K
|
||||
DO 110 I = 1, LASTC
|
||||
C( I, LASTV-K+J ) = C( I, LASTV-K+J )
|
||||
$ - WORK( I, J )
|
||||
110 CONTINUE
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
ELSE IF( LSAME( STOREV, 'R' ) ) THEN
|
||||
*
|
||||
IF( LSAME( DIRECT, 'F' ) ) THEN
|
||||
*
|
||||
* Let V = ( V1 V2 ) (V1: first K columns)
|
||||
* where V1 is unit upper triangular.
|
||||
*
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
*
|
||||
* Form H * C or H**H * C where C = ( C1 )
|
||||
* ( C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILACLC( K, M, V, LDV ) )
|
||||
LASTC = ILACLC( LASTV, N, C, LDC )
|
||||
*
|
||||
* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
|
||||
*
|
||||
* W := C1**H
|
||||
*
|
||||
DO 130 J = 1, K
|
||||
CALL CCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
|
||||
CALL CLACGV( LASTC, WORK( 1, J ), 1 )
|
||||
130 CONTINUE
|
||||
*
|
||||
* W := W * V1**H
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C2**H*V2**H
|
||||
*
|
||||
CALL CGEMM( 'Conjugate transpose',
|
||||
$ 'Conjugate transpose', LASTC, K, LASTV-K,
|
||||
$ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T**H or W * T
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - V**H * W**H
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C2 := C2 - V2**H * W**H
|
||||
*
|
||||
CALL CGEMM( 'Conjugate transpose',
|
||||
$ 'Conjugate transpose', LASTV-K, LASTC, K,
|
||||
$ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
|
||||
$ ONE, C( K+1, 1 ), LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V1
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W**H
|
||||
*
|
||||
DO 150 J = 1, K
|
||||
DO 140 I = 1, LASTC
|
||||
C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) )
|
||||
140 CONTINUE
|
||||
150 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
*
|
||||
* Form C * H or C * H**H where C = ( C1 C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILACLC( K, N, V, LDV ) )
|
||||
LASTC = ILACLR( M, LASTV, C, LDC )
|
||||
*
|
||||
* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK)
|
||||
*
|
||||
* W := C1
|
||||
*
|
||||
DO 160 J = 1, K
|
||||
CALL CCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
|
||||
160 CONTINUE
|
||||
*
|
||||
* W := W * V1**H
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C2 * V2**H
|
||||
*
|
||||
CALL CGEMM( 'No transpose', 'Conjugate transpose',
|
||||
$ LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC,
|
||||
$ V( 1, K+1 ), LDV, ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T or W * T**H
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - W * V
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C2 := C2 - W * V2
|
||||
*
|
||||
CALL CGEMM( 'No transpose', 'No transpose',
|
||||
$ LASTC, LASTV-K, K,
|
||||
$ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
|
||||
$ ONE, C( 1, K+1 ), LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V1
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W
|
||||
*
|
||||
DO 180 J = 1, K
|
||||
DO 170 I = 1, LASTC
|
||||
C( I, J ) = C( I, J ) - WORK( I, J )
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
*
|
||||
END IF
|
||||
*
|
||||
ELSE
|
||||
*
|
||||
* Let V = ( V1 V2 ) (V2: last K columns)
|
||||
* where V2 is unit lower triangular.
|
||||
*
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
*
|
||||
* Form H * C or H**H * C where C = ( C1 )
|
||||
* ( C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILACLC( K, M, V, LDV ) )
|
||||
LASTC = ILACLC( LASTV, N, C, LDC )
|
||||
*
|
||||
* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
|
||||
*
|
||||
* W := C2**H
|
||||
*
|
||||
DO 190 J = 1, K
|
||||
CALL CCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
|
||||
$ WORK( 1, J ), 1 )
|
||||
CALL CLACGV( LASTC, WORK( 1, J ), 1 )
|
||||
190 CONTINUE
|
||||
*
|
||||
* W := W * V2**H
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C1**H * V1**H
|
||||
*
|
||||
CALL CGEMM( 'Conjugate transpose',
|
||||
$ 'Conjugate transpose', LASTC, K, LASTV-K,
|
||||
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T**H or W * T
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - V**H * W**H
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C1 := C1 - V1**H * W**H
|
||||
*
|
||||
CALL CGEMM( 'Conjugate transpose',
|
||||
$ 'Conjugate transpose', LASTV-K, LASTC, K,
|
||||
$ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V2
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
*
|
||||
* C2 := C2 - W**H
|
||||
*
|
||||
DO 210 J = 1, K
|
||||
DO 200 I = 1, LASTC
|
||||
C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
|
||||
$ CONJG( WORK( I, J ) )
|
||||
200 CONTINUE
|
||||
210 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
*
|
||||
* Form C * H or C * H**H where C = ( C1 C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILACLC( K, N, V, LDV ) )
|
||||
LASTC = ILACLR( M, LASTV, C, LDC )
|
||||
*
|
||||
* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK)
|
||||
*
|
||||
* W := C2
|
||||
*
|
||||
DO 220 J = 1, K
|
||||
CALL CCOPY( LASTC, C( 1, LASTV-K+J ), 1,
|
||||
$ WORK( 1, J ), 1 )
|
||||
220 CONTINUE
|
||||
*
|
||||
* W := W * V2**H
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C1 * V1**H
|
||||
*
|
||||
CALL CGEMM( 'No transpose', 'Conjugate transpose',
|
||||
$ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, ONE,
|
||||
$ WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T or W * T**H
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - W * V
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C1 := C1 - W * V1
|
||||
*
|
||||
CALL CGEMM( 'No transpose', 'No transpose',
|
||||
$ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
|
||||
$ ONE, C, LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V2
|
||||
*
|
||||
CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W
|
||||
*
|
||||
DO 240 J = 1, K
|
||||
DO 230 I = 1, LASTC
|
||||
C( I, LASTV-K+J ) = C( I, LASTV-K+J )
|
||||
$ - WORK( I, J )
|
||||
230 CONTINUE
|
||||
240 CONTINUE
|
||||
*
|
||||
END IF
|
||||
*
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CLARFB
|
||||
*
|
||||
END
|
||||
203
cs440-acg/ext/eigen/lapack/clarfg.f
Normal file
203
cs440-acg/ext/eigen/lapack/clarfg.f
Normal file
@@ -0,0 +1,203 @@
|
||||
*> \brief \b CLARFG
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download CLARFG + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clarfg.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clarfg.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clarfg.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CLARFG( N, ALPHA, X, INCX, TAU )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX, N
|
||||
* COMPLEX ALPHA, TAU
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX X( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CLARFG generates a complex elementary reflector H of order n, such
|
||||
*> that
|
||||
*>
|
||||
*> H**H * ( alpha ) = ( beta ), H**H * H = I.
|
||||
*> ( x ) ( 0 )
|
||||
*>
|
||||
*> where alpha and beta are scalars, with beta real, and x is an
|
||||
*> (n-1)-element complex vector. H is represented in the form
|
||||
*>
|
||||
*> H = I - tau * ( 1 ) * ( 1 v**H ) ,
|
||||
*> ( v )
|
||||
*>
|
||||
*> where tau is a complex scalar and v is a complex (n-1)-element
|
||||
*> vector. Note that H is not hermitian.
|
||||
*>
|
||||
*> If the elements of x are all zero and alpha is real, then tau = 0
|
||||
*> and H is taken to be the unit matrix.
|
||||
*>
|
||||
*> Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the elementary reflector.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX
|
||||
*> On entry, the value alpha.
|
||||
*> On exit, it is overwritten with the value beta.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX array, dimension
|
||||
*> (1+(N-2)*abs(INCX))
|
||||
*> On entry, the vector x.
|
||||
*> On exit, it is overwritten with the vector v.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> The increment between elements of X. INCX > 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] TAU
|
||||
*> \verbatim
|
||||
*> TAU is COMPLEX
|
||||
*> The value tau.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complexOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE CLARFG( N, ALPHA, X, INCX, TAU )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX, N
|
||||
COMPLEX ALPHA, TAU
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX X( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ONE, ZERO
|
||||
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER J, KNT
|
||||
REAL ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
REAL SCNRM2, SLAMCH, SLAPY3
|
||||
COMPLEX CLADIV
|
||||
EXTERNAL SCNRM2, SLAMCH, SLAPY3, CLADIV
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, AIMAG, CMPLX, REAL, SIGN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL CSCAL, CSSCAL
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( N.LE.0 ) THEN
|
||||
TAU = ZERO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
XNORM = SCNRM2( N-1, X, INCX )
|
||||
ALPHR = REAL( ALPHA )
|
||||
ALPHI = AIMAG( ALPHA )
|
||||
*
|
||||
IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
|
||||
*
|
||||
* H = I
|
||||
*
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
*
|
||||
* general case
|
||||
*
|
||||
BETA = -SIGN( SLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
|
||||
SAFMIN = SLAMCH( 'S' ) / SLAMCH( 'E' )
|
||||
RSAFMN = ONE / SAFMIN
|
||||
*
|
||||
KNT = 0
|
||||
IF( ABS( BETA ).LT.SAFMIN ) THEN
|
||||
*
|
||||
* XNORM, BETA may be inaccurate; scale X and recompute them
|
||||
*
|
||||
10 CONTINUE
|
||||
KNT = KNT + 1
|
||||
CALL CSSCAL( N-1, RSAFMN, X, INCX )
|
||||
BETA = BETA*RSAFMN
|
||||
ALPHI = ALPHI*RSAFMN
|
||||
ALPHR = ALPHR*RSAFMN
|
||||
IF( ABS( BETA ).LT.SAFMIN )
|
||||
$ GO TO 10
|
||||
*
|
||||
* New BETA is at most 1, at least SAFMIN
|
||||
*
|
||||
XNORM = SCNRM2( N-1, X, INCX )
|
||||
ALPHA = CMPLX( ALPHR, ALPHI )
|
||||
BETA = -SIGN( SLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
|
||||
END IF
|
||||
TAU = CMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
|
||||
ALPHA = CLADIV( CMPLX( ONE ), ALPHA-BETA )
|
||||
CALL CSCAL( N-1, ALPHA, X, INCX )
|
||||
*
|
||||
* If ALPHA is subnormal, it may lose relative accuracy
|
||||
*
|
||||
DO 20 J = 1, KNT
|
||||
BETA = BETA*SAFMIN
|
||||
20 CONTINUE
|
||||
ALPHA = BETA
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CLARFG
|
||||
*
|
||||
END
|
||||
328
cs440-acg/ext/eigen/lapack/clarft.f
Normal file
328
cs440-acg/ext/eigen/lapack/clarft.f
Normal file
@@ -0,0 +1,328 @@
|
||||
*> \brief \b CLARFT
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download CLARFT + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clarft.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clarft.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clarft.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER DIRECT, STOREV
|
||||
* INTEGER K, LDT, LDV, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX T( LDT, * ), TAU( * ), V( LDV, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CLARFT forms the triangular factor T of a complex block reflector H
|
||||
*> of order n, which is defined as a product of k elementary reflectors.
|
||||
*>
|
||||
*> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
|
||||
*>
|
||||
*> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
|
||||
*>
|
||||
*> If STOREV = 'C', the vector which defines the elementary reflector
|
||||
*> H(i) is stored in the i-th column of the array V, and
|
||||
*>
|
||||
*> H = I - V * T * V**H
|
||||
*>
|
||||
*> If STOREV = 'R', the vector which defines the elementary reflector
|
||||
*> H(i) is stored in the i-th row of the array V, and
|
||||
*>
|
||||
*> H = I - V**H * T * V
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] DIRECT
|
||||
*> \verbatim
|
||||
*> DIRECT is CHARACTER*1
|
||||
*> Specifies the order in which the elementary reflectors are
|
||||
*> multiplied to form the block reflector:
|
||||
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
|
||||
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] STOREV
|
||||
*> \verbatim
|
||||
*> STOREV is CHARACTER*1
|
||||
*> Specifies how the vectors which define the elementary
|
||||
*> reflectors are stored (see also Further Details):
|
||||
*> = 'C': columnwise
|
||||
*> = 'R': rowwise
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the block reflector H. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The order of the triangular factor T (= the number of
|
||||
*> elementary reflectors). K >= 1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] V
|
||||
*> \verbatim
|
||||
*> V is COMPLEX array, dimension
|
||||
*> (LDV,K) if STOREV = 'C'
|
||||
*> (LDV,N) if STOREV = 'R'
|
||||
*> The matrix V. See further details.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDV
|
||||
*> \verbatim
|
||||
*> LDV is INTEGER
|
||||
*> The leading dimension of the array V.
|
||||
*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TAU
|
||||
*> \verbatim
|
||||
*> TAU is COMPLEX array, dimension (K)
|
||||
*> TAU(i) must contain the scalar factor of the elementary
|
||||
*> reflector H(i).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] T
|
||||
*> \verbatim
|
||||
*> T is COMPLEX array, dimension (LDT,K)
|
||||
*> The k by k triangular factor T of the block reflector.
|
||||
*> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
|
||||
*> lower triangular. The rest of the array is not used.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDT
|
||||
*> \verbatim
|
||||
*> LDT is INTEGER
|
||||
*> The leading dimension of the array T. LDT >= K.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date April 2012
|
||||
*
|
||||
*> \ingroup complexOTHERauxiliary
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> The shape of the matrix V and the storage of the vectors which define
|
||||
*> the H(i) is best illustrated by the following example with n = 5 and
|
||||
*> k = 3. The elements equal to 1 are not stored.
|
||||
*>
|
||||
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
|
||||
*>
|
||||
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
|
||||
*> ( v1 1 ) ( 1 v2 v2 v2 )
|
||||
*> ( v1 v2 1 ) ( 1 v3 v3 )
|
||||
*> ( v1 v2 v3 )
|
||||
*> ( v1 v2 v3 )
|
||||
*>
|
||||
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
|
||||
*>
|
||||
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
|
||||
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
|
||||
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
|
||||
*> ( 1 v3 )
|
||||
*> ( 1 )
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.1) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* April 2012
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER DIRECT, STOREV
|
||||
INTEGER K, LDT, LDV, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX T( LDT, * ), TAU( * ), V( LDV, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ONE, ZERO
|
||||
PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ),
|
||||
$ ZERO = ( 0.0E+0, 0.0E+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J, PREVLASTV, LASTV
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL CGEMV, CLACGV, CTRMV
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
IF( LSAME( DIRECT, 'F' ) ) THEN
|
||||
PREVLASTV = N
|
||||
DO I = 1, K
|
||||
PREVLASTV = MAX( PREVLASTV, I )
|
||||
IF( TAU( I ).EQ.ZERO ) THEN
|
||||
*
|
||||
* H(i) = I
|
||||
*
|
||||
DO J = 1, I
|
||||
T( J, I ) = ZERO
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* general case
|
||||
*
|
||||
IF( LSAME( STOREV, 'C' ) ) THEN
|
||||
* Skip any trailing zeros.
|
||||
DO LASTV = N, I+1, -1
|
||||
IF( V( LASTV, I ).NE.ZERO ) EXIT
|
||||
END DO
|
||||
DO J = 1, I-1
|
||||
T( J, I ) = -TAU( I ) * CONJG( V( I , J ) )
|
||||
END DO
|
||||
J = MIN( LASTV, PREVLASTV )
|
||||
*
|
||||
* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i)
|
||||
*
|
||||
CALL CGEMV( 'Conjugate transpose', J-I, I-1,
|
||||
$ -TAU( I ), V( I+1, 1 ), LDV,
|
||||
$ V( I+1, I ), 1,
|
||||
$ ONE, T( 1, I ), 1 )
|
||||
ELSE
|
||||
* Skip any trailing zeros.
|
||||
DO LASTV = N, I+1, -1
|
||||
IF( V( I, LASTV ).NE.ZERO ) EXIT
|
||||
END DO
|
||||
DO J = 1, I-1
|
||||
T( J, I ) = -TAU( I ) * V( J , I )
|
||||
END DO
|
||||
J = MIN( LASTV, PREVLASTV )
|
||||
*
|
||||
* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H
|
||||
*
|
||||
CALL CGEMM( 'N', 'C', I-1, 1, J-I, -TAU( I ),
|
||||
$ V( 1, I+1 ), LDV, V( I, I+1 ), LDV,
|
||||
$ ONE, T( 1, I ), LDT )
|
||||
END IF
|
||||
*
|
||||
* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
|
||||
*
|
||||
CALL CTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
|
||||
$ LDT, T( 1, I ), 1 )
|
||||
T( I, I ) = TAU( I )
|
||||
IF( I.GT.1 ) THEN
|
||||
PREVLASTV = MAX( PREVLASTV, LASTV )
|
||||
ELSE
|
||||
PREVLASTV = LASTV
|
||||
END IF
|
||||
END IF
|
||||
END DO
|
||||
ELSE
|
||||
PREVLASTV = 1
|
||||
DO I = K, 1, -1
|
||||
IF( TAU( I ).EQ.ZERO ) THEN
|
||||
*
|
||||
* H(i) = I
|
||||
*
|
||||
DO J = I, K
|
||||
T( J, I ) = ZERO
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* general case
|
||||
*
|
||||
IF( I.LT.K ) THEN
|
||||
IF( LSAME( STOREV, 'C' ) ) THEN
|
||||
* Skip any leading zeros.
|
||||
DO LASTV = 1, I-1
|
||||
IF( V( LASTV, I ).NE.ZERO ) EXIT
|
||||
END DO
|
||||
DO J = I+1, K
|
||||
T( J, I ) = -TAU( I ) * CONJG( V( N-K+I , J ) )
|
||||
END DO
|
||||
J = MAX( LASTV, PREVLASTV )
|
||||
*
|
||||
* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i)
|
||||
*
|
||||
CALL CGEMV( 'Conjugate transpose', N-K+I-J, K-I,
|
||||
$ -TAU( I ), V( J, I+1 ), LDV, V( J, I ),
|
||||
$ 1, ONE, T( I+1, I ), 1 )
|
||||
ELSE
|
||||
* Skip any leading zeros.
|
||||
DO LASTV = 1, I-1
|
||||
IF( V( I, LASTV ).NE.ZERO ) EXIT
|
||||
END DO
|
||||
DO J = I+1, K
|
||||
T( J, I ) = -TAU( I ) * V( J, N-K+I )
|
||||
END DO
|
||||
J = MAX( LASTV, PREVLASTV )
|
||||
*
|
||||
* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H
|
||||
*
|
||||
CALL CGEMM( 'N', 'C', K-I, 1, N-K+I-J, -TAU( I ),
|
||||
$ V( I+1, J ), LDV, V( I, J ), LDV,
|
||||
$ ONE, T( I+1, I ), LDT )
|
||||
END IF
|
||||
*
|
||||
* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
|
||||
*
|
||||
CALL CTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
|
||||
$ T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
|
||||
IF( I.GT.1 ) THEN
|
||||
PREVLASTV = MIN( PREVLASTV, LASTV )
|
||||
ELSE
|
||||
PREVLASTV = LASTV
|
||||
END IF
|
||||
END IF
|
||||
T( I, I ) = TAU( I )
|
||||
END IF
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of CLARFT
|
||||
*
|
||||
END
|
||||
18
cs440-acg/ext/eigen/lapack/complex_double.cpp
Normal file
18
cs440-acg/ext/eigen/lapack/complex_double.cpp
Normal file
@@ -0,0 +1,18 @@
|
||||
// This file is part of Eigen, a lightweight C++ template library
|
||||
// for linear algebra.
|
||||
//
|
||||
// Copyright (C) 2009-2014 Gael Guennebaud <gael.guennebaud@inria.fr>
|
||||
//
|
||||
// This Source Code Form is subject to the terms of the Mozilla
|
||||
// Public License v. 2.0. If a copy of the MPL was not distributed
|
||||
// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
#define SCALAR std::complex<double>
|
||||
#define SCALAR_SUFFIX z
|
||||
#define SCALAR_SUFFIX_UP "Z"
|
||||
#define REAL_SCALAR_SUFFIX d
|
||||
#define ISCOMPLEX 1
|
||||
|
||||
#include "cholesky.cpp"
|
||||
#include "lu.cpp"
|
||||
#include "svd.cpp"
|
||||
18
cs440-acg/ext/eigen/lapack/complex_single.cpp
Normal file
18
cs440-acg/ext/eigen/lapack/complex_single.cpp
Normal file
@@ -0,0 +1,18 @@
|
||||
// This file is part of Eigen, a lightweight C++ template library
|
||||
// for linear algebra.
|
||||
//
|
||||
// Copyright (C) 2009-2014 Gael Guennebaud <gael.guennebaud@inria.fr>
|
||||
//
|
||||
// This Source Code Form is subject to the terms of the Mozilla
|
||||
// Public License v. 2.0. If a copy of the MPL was not distributed
|
||||
// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
#define SCALAR std::complex<float>
|
||||
#define SCALAR_SUFFIX c
|
||||
#define SCALAR_SUFFIX_UP "C"
|
||||
#define REAL_SCALAR_SUFFIX s
|
||||
#define ISCOMPLEX 1
|
||||
|
||||
#include "cholesky.cpp"
|
||||
#include "lu.cpp"
|
||||
#include "svd.cpp"
|
||||
128
cs440-acg/ext/eigen/lapack/dladiv.f
Normal file
128
cs440-acg/ext/eigen/lapack/dladiv.f
Normal file
@@ -0,0 +1,128 @@
|
||||
*> \brief \b DLADIV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download DLADIV + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dladiv.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dladiv.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dladiv.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DLADIV( A, B, C, D, P, Q )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION A, B, C, D, P, Q
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLADIV performs complex division in real arithmetic
|
||||
*>
|
||||
*> a + i*b
|
||||
*> p + i*q = ---------
|
||||
*> c + i*d
|
||||
*>
|
||||
*> The algorithm is due to Robert L. Smith and can be found
|
||||
*> in D. Knuth, The art of Computer Programming, Vol.2, p.195
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> B is DOUBLE PRECISION
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] C
|
||||
*> \verbatim
|
||||
*> C is DOUBLE PRECISION
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is DOUBLE PRECISION
|
||||
*> The scalars a, b, c, and d in the above expression.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] P
|
||||
*> \verbatim
|
||||
*> P is DOUBLE PRECISION
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] Q
|
||||
*> \verbatim
|
||||
*> Q is DOUBLE PRECISION
|
||||
*> The scalars p and q in the above expression.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup auxOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DLADIV( A, B, C, D, P, Q )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION A, B, C, D, P, Q
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION E, F
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( ABS( D ).LT.ABS( C ) ) THEN
|
||||
E = D / C
|
||||
F = C + D*E
|
||||
P = ( A+B*E ) / F
|
||||
Q = ( B-A*E ) / F
|
||||
ELSE
|
||||
E = C / D
|
||||
F = D + C*E
|
||||
P = ( B+A*E ) / F
|
||||
Q = ( -A+B*E ) / F
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DLADIV
|
||||
*
|
||||
END
|
||||
189
cs440-acg/ext/eigen/lapack/dlamch.f
Normal file
189
cs440-acg/ext/eigen/lapack/dlamch.f
Normal file
@@ -0,0 +1,189 @@
|
||||
*> \brief \b DLAMCH
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLAMCH determines double precision machine parameters.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] CMACH
|
||||
*> \verbatim
|
||||
*> Specifies the value to be returned by DLAMCH:
|
||||
*> = 'E' or 'e', DLAMCH := eps
|
||||
*> = 'S' or 's , DLAMCH := sfmin
|
||||
*> = 'B' or 'b', DLAMCH := base
|
||||
*> = 'P' or 'p', DLAMCH := eps*base
|
||||
*> = 'N' or 'n', DLAMCH := t
|
||||
*> = 'R' or 'r', DLAMCH := rnd
|
||||
*> = 'M' or 'm', DLAMCH := emin
|
||||
*> = 'U' or 'u', DLAMCH := rmin
|
||||
*> = 'L' or 'l', DLAMCH := emax
|
||||
*> = 'O' or 'o', DLAMCH := rmax
|
||||
*> where
|
||||
*> eps = relative machine precision
|
||||
*> sfmin = safe minimum, such that 1/sfmin does not overflow
|
||||
*> base = base of the machine
|
||||
*> prec = eps*base
|
||||
*> t = number of (base) digits in the mantissa
|
||||
*> rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
|
||||
*> emin = minimum exponent before (gradual) underflow
|
||||
*> rmin = underflow threshold - base**(emin-1)
|
||||
*> emax = largest exponent before overflow
|
||||
*> rmax = overflow threshold - (base**emax)*(1-eps)
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup auxOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER CMACH
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE, ZERO
|
||||
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT,
|
||||
$ MINEXPONENT, RADIX, TINY
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
*
|
||||
* Assume rounding, not chopping. Always.
|
||||
*
|
||||
RND = ONE
|
||||
*
|
||||
IF( ONE.EQ.RND ) THEN
|
||||
EPS = EPSILON(ZERO) * 0.5
|
||||
ELSE
|
||||
EPS = EPSILON(ZERO)
|
||||
END IF
|
||||
*
|
||||
IF( LSAME( CMACH, 'E' ) ) THEN
|
||||
RMACH = EPS
|
||||
ELSE IF( LSAME( CMACH, 'S' ) ) THEN
|
||||
SFMIN = TINY(ZERO)
|
||||
SMALL = ONE / HUGE(ZERO)
|
||||
IF( SMALL.GE.SFMIN ) THEN
|
||||
*
|
||||
* Use SMALL plus a bit, to avoid the possibility of rounding
|
||||
* causing overflow when computing 1/sfmin.
|
||||
*
|
||||
SFMIN = SMALL*( ONE+EPS )
|
||||
END IF
|
||||
RMACH = SFMIN
|
||||
ELSE IF( LSAME( CMACH, 'B' ) ) THEN
|
||||
RMACH = RADIX(ZERO)
|
||||
ELSE IF( LSAME( CMACH, 'P' ) ) THEN
|
||||
RMACH = EPS * RADIX(ZERO)
|
||||
ELSE IF( LSAME( CMACH, 'N' ) ) THEN
|
||||
RMACH = DIGITS(ZERO)
|
||||
ELSE IF( LSAME( CMACH, 'R' ) ) THEN
|
||||
RMACH = RND
|
||||
ELSE IF( LSAME( CMACH, 'M' ) ) THEN
|
||||
RMACH = MINEXPONENT(ZERO)
|
||||
ELSE IF( LSAME( CMACH, 'U' ) ) THEN
|
||||
RMACH = tiny(zero)
|
||||
ELSE IF( LSAME( CMACH, 'L' ) ) THEN
|
||||
RMACH = MAXEXPONENT(ZERO)
|
||||
ELSE IF( LSAME( CMACH, 'O' ) ) THEN
|
||||
RMACH = HUGE(ZERO)
|
||||
ELSE
|
||||
RMACH = ZERO
|
||||
END IF
|
||||
*
|
||||
DLAMCH = RMACH
|
||||
RETURN
|
||||
*
|
||||
* End of DLAMCH
|
||||
*
|
||||
END
|
||||
************************************************************************
|
||||
*> \brief \b DLAMC3
|
||||
*> \details
|
||||
*> \b Purpose:
|
||||
*> \verbatim
|
||||
*> DLAMC3 is intended to force A and B to be stored prior to doing
|
||||
*> the addition of A and B , for use in situations where optimizers
|
||||
*> might hold one of these in a register.
|
||||
*> \endverbatim
|
||||
*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..
|
||||
*> \date November 2011
|
||||
*> \ingroup auxOTHERauxiliary
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is a DOUBLE PRECISION
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> B is a DOUBLE PRECISION
|
||||
*> The values A and B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
DOUBLE PRECISION FUNCTION DLAMC3( A, B )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
|
||||
* November 2010
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION A, B
|
||||
* ..
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
DLAMC3 = A + B
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DLAMC3
|
||||
*
|
||||
END
|
||||
*
|
||||
************************************************************************
|
||||
104
cs440-acg/ext/eigen/lapack/dlapy2.f
Normal file
104
cs440-acg/ext/eigen/lapack/dlapy2.f
Normal file
@@ -0,0 +1,104 @@
|
||||
*> \brief \b DLAPY2
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download DLAPY2 + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlapy2.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlapy2.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlapy2.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION X, Y
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
|
||||
*> overflow.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] Y
|
||||
*> \verbatim
|
||||
*> Y is DOUBLE PRECISION
|
||||
*> X and Y specify the values x and y.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup auxOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION X, Y
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER ( ZERO = 0.0D0 )
|
||||
DOUBLE PRECISION ONE
|
||||
PARAMETER ( ONE = 1.0D0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION W, XABS, YABS, Z
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, MAX, MIN, SQRT
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
XABS = ABS( X )
|
||||
YABS = ABS( Y )
|
||||
W = MAX( XABS, YABS )
|
||||
Z = MIN( XABS, YABS )
|
||||
IF( Z.EQ.ZERO ) THEN
|
||||
DLAPY2 = W
|
||||
ELSE
|
||||
DLAPY2 = W*SQRT( ONE+( Z / W )**2 )
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of DLAPY2
|
||||
*
|
||||
END
|
||||
111
cs440-acg/ext/eigen/lapack/dlapy3.f
Normal file
111
cs440-acg/ext/eigen/lapack/dlapy3.f
Normal file
@@ -0,0 +1,111 @@
|
||||
*> \brief \b DLAPY3
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download DLAPY3 + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlapy3.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlapy3.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlapy3.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION X, Y, Z
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
|
||||
*> unnecessary overflow.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] Y
|
||||
*> \verbatim
|
||||
*> Y is DOUBLE PRECISION
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] Z
|
||||
*> \verbatim
|
||||
*> Z is DOUBLE PRECISION
|
||||
*> X, Y and Z specify the values x, y and z.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup auxOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION X, Y, Z
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER ( ZERO = 0.0D0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION W, XABS, YABS, ZABS
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, MAX, SQRT
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
XABS = ABS( X )
|
||||
YABS = ABS( Y )
|
||||
ZABS = ABS( Z )
|
||||
W = MAX( XABS, YABS, ZABS )
|
||||
IF( W.EQ.ZERO ) THEN
|
||||
* W can be zero for max(0,nan,0)
|
||||
* adding all three entries together will make sure
|
||||
* NaN will not disappear.
|
||||
DLAPY3 = XABS + YABS + ZABS
|
||||
ELSE
|
||||
DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+
|
||||
$ ( ZABS / W )**2 )
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of DLAPY3
|
||||
*
|
||||
END
|
||||
227
cs440-acg/ext/eigen/lapack/dlarf.f
Normal file
227
cs440-acg/ext/eigen/lapack/dlarf.f
Normal file
@@ -0,0 +1,227 @@
|
||||
*> \brief \b DLARF
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download DLARF + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarf.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarf.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarf.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER SIDE
|
||||
* INTEGER INCV, LDC, M, N
|
||||
* DOUBLE PRECISION TAU
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLARF applies a real elementary reflector H to a real m by n matrix
|
||||
*> C, from either the left or the right. H is represented in the form
|
||||
*>
|
||||
*> H = I - tau * v * v**T
|
||||
*>
|
||||
*> where tau is a real scalar and v is a real vector.
|
||||
*>
|
||||
*> If tau = 0, then H is taken to be the unit matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> = 'L': form H * C
|
||||
*> = 'R': form C * H
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] V
|
||||
*> \verbatim
|
||||
*> V is DOUBLE PRECISION array, dimension
|
||||
*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
|
||||
*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
|
||||
*> The vector v in the representation of H. V is not used if
|
||||
*> TAU = 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCV
|
||||
*> \verbatim
|
||||
*> INCV is INTEGER
|
||||
*> The increment between elements of v. INCV <> 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TAU
|
||||
*> \verbatim
|
||||
*> TAU is DOUBLE PRECISION
|
||||
*> The value tau in the representation of H.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is DOUBLE PRECISION array, dimension (LDC,N)
|
||||
*> On entry, the m by n matrix C.
|
||||
*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
|
||||
*> or C * H if SIDE = 'R'.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> The leading dimension of the array C. LDC >= max(1,M).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is DOUBLE PRECISION array, dimension
|
||||
*> (N) if SIDE = 'L'
|
||||
*> or (M) if SIDE = 'R'
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup doubleOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER SIDE
|
||||
INTEGER INCV, LDC, M, N
|
||||
DOUBLE PRECISION TAU
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE, ZERO
|
||||
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
LOGICAL APPLYLEFT
|
||||
INTEGER I, LASTV, LASTC
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DGEMV, DGER
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
INTEGER ILADLR, ILADLC
|
||||
EXTERNAL LSAME, ILADLR, ILADLC
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
APPLYLEFT = LSAME( SIDE, 'L' )
|
||||
LASTV = 0
|
||||
LASTC = 0
|
||||
IF( TAU.NE.ZERO ) THEN
|
||||
! Set up variables for scanning V. LASTV begins pointing to the end
|
||||
! of V.
|
||||
IF( APPLYLEFT ) THEN
|
||||
LASTV = M
|
||||
ELSE
|
||||
LASTV = N
|
||||
END IF
|
||||
IF( INCV.GT.0 ) THEN
|
||||
I = 1 + (LASTV-1) * INCV
|
||||
ELSE
|
||||
I = 1
|
||||
END IF
|
||||
! Look for the last non-zero row in V.
|
||||
DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
|
||||
LASTV = LASTV - 1
|
||||
I = I - INCV
|
||||
END DO
|
||||
IF( APPLYLEFT ) THEN
|
||||
! Scan for the last non-zero column in C(1:lastv,:).
|
||||
LASTC = ILADLC(LASTV, N, C, LDC)
|
||||
ELSE
|
||||
! Scan for the last non-zero row in C(:,1:lastv).
|
||||
LASTC = ILADLR(M, LASTV, C, LDC)
|
||||
END IF
|
||||
END IF
|
||||
! Note that lastc.eq.0 renders the BLAS operations null; no special
|
||||
! case is needed at this level.
|
||||
IF( APPLYLEFT ) THEN
|
||||
*
|
||||
* Form H * C
|
||||
*
|
||||
IF( LASTV.GT.0 ) THEN
|
||||
*
|
||||
* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1)
|
||||
*
|
||||
CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV,
|
||||
$ ZERO, WORK, 1 )
|
||||
*
|
||||
* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T
|
||||
*
|
||||
CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form C * H
|
||||
*
|
||||
IF( LASTV.GT.0 ) THEN
|
||||
*
|
||||
* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
|
||||
*
|
||||
CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
|
||||
$ V, INCV, ZERO, WORK, 1 )
|
||||
*
|
||||
* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T
|
||||
*
|
||||
CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
|
||||
END IF
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of DLARF
|
||||
*
|
||||
END
|
||||
762
cs440-acg/ext/eigen/lapack/dlarfb.f
Normal file
762
cs440-acg/ext/eigen/lapack/dlarfb.f
Normal file
@@ -0,0 +1,762 @@
|
||||
*> \brief \b DLARFB
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download DLARFB + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarfb.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarfb.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarfb.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
|
||||
* T, LDT, C, LDC, WORK, LDWORK )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER DIRECT, SIDE, STOREV, TRANS
|
||||
* INTEGER K, LDC, LDT, LDV, LDWORK, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
|
||||
* $ WORK( LDWORK, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLARFB applies a real block reflector H or its transpose H**T to a
|
||||
*> real m by n matrix C, from either the left or the right.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> = 'L': apply H or H**T from the Left
|
||||
*> = 'R': apply H or H**T from the Right
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> = 'N': apply H (No transpose)
|
||||
*> = 'T': apply H**T (Transpose)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIRECT
|
||||
*> \verbatim
|
||||
*> DIRECT is CHARACTER*1
|
||||
*> Indicates how H is formed from a product of elementary
|
||||
*> reflectors
|
||||
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
|
||||
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] STOREV
|
||||
*> \verbatim
|
||||
*> STOREV is CHARACTER*1
|
||||
*> Indicates how the vectors which define the elementary
|
||||
*> reflectors are stored:
|
||||
*> = 'C': Columnwise
|
||||
*> = 'R': Rowwise
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The order of the matrix T (= the number of elementary
|
||||
*> reflectors whose product defines the block reflector).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] V
|
||||
*> \verbatim
|
||||
*> V is DOUBLE PRECISION array, dimension
|
||||
*> (LDV,K) if STOREV = 'C'
|
||||
*> (LDV,M) if STOREV = 'R' and SIDE = 'L'
|
||||
*> (LDV,N) if STOREV = 'R' and SIDE = 'R'
|
||||
*> The matrix V. See Further Details.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDV
|
||||
*> \verbatim
|
||||
*> LDV is INTEGER
|
||||
*> The leading dimension of the array V.
|
||||
*> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
|
||||
*> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
|
||||
*> if STOREV = 'R', LDV >= K.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] T
|
||||
*> \verbatim
|
||||
*> T is DOUBLE PRECISION array, dimension (LDT,K)
|
||||
*> The triangular k by k matrix T in the representation of the
|
||||
*> block reflector.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDT
|
||||
*> \verbatim
|
||||
*> LDT is INTEGER
|
||||
*> The leading dimension of the array T. LDT >= K.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is DOUBLE PRECISION array, dimension (LDC,N)
|
||||
*> On entry, the m by n matrix C.
|
||||
*> On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> The leading dimension of the array C. LDC >= max(1,M).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is DOUBLE PRECISION array, dimension (LDWORK,K)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDWORK
|
||||
*> \verbatim
|
||||
*> LDWORK is INTEGER
|
||||
*> The leading dimension of the array WORK.
|
||||
*> If SIDE = 'L', LDWORK >= max(1,N);
|
||||
*> if SIDE = 'R', LDWORK >= max(1,M).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup doubleOTHERauxiliary
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> The shape of the matrix V and the storage of the vectors which define
|
||||
*> the H(i) is best illustrated by the following example with n = 5 and
|
||||
*> k = 3. The elements equal to 1 are not stored; the corresponding
|
||||
*> array elements are modified but restored on exit. The rest of the
|
||||
*> array is not used.
|
||||
*>
|
||||
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
|
||||
*>
|
||||
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
|
||||
*> ( v1 1 ) ( 1 v2 v2 v2 )
|
||||
*> ( v1 v2 1 ) ( 1 v3 v3 )
|
||||
*> ( v1 v2 v3 )
|
||||
*> ( v1 v2 v3 )
|
||||
*>
|
||||
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
|
||||
*>
|
||||
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
|
||||
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
|
||||
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
|
||||
*> ( 1 v3 )
|
||||
*> ( 1 )
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
|
||||
$ T, LDT, C, LDC, WORK, LDWORK )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER DIRECT, SIDE, STOREV, TRANS
|
||||
INTEGER K, LDC, LDT, LDV, LDWORK, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
|
||||
$ WORK( LDWORK, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE
|
||||
PARAMETER ( ONE = 1.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
CHARACTER TRANST
|
||||
INTEGER I, J, LASTV, LASTC
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
INTEGER ILADLR, ILADLC
|
||||
EXTERNAL LSAME, ILADLR, ILADLC
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DCOPY, DGEMM, DTRMM
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( M.LE.0 .OR. N.LE.0 )
|
||||
$ RETURN
|
||||
*
|
||||
IF( LSAME( TRANS, 'N' ) ) THEN
|
||||
TRANST = 'T'
|
||||
ELSE
|
||||
TRANST = 'N'
|
||||
END IF
|
||||
*
|
||||
IF( LSAME( STOREV, 'C' ) ) THEN
|
||||
*
|
||||
IF( LSAME( DIRECT, 'F' ) ) THEN
|
||||
*
|
||||
* Let V = ( V1 ) (first K rows)
|
||||
* ( V2 )
|
||||
* where V1 is unit lower triangular.
|
||||
*
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
*
|
||||
* Form H * C or H**T * C where C = ( C1 )
|
||||
* ( C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILADLR( M, K, V, LDV ) )
|
||||
LASTC = ILADLC( LASTV, N, C, LDC )
|
||||
*
|
||||
* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
|
||||
*
|
||||
* W := C1**T
|
||||
*
|
||||
DO 10 J = 1, K
|
||||
CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
|
||||
10 CONTINUE
|
||||
*
|
||||
* W := W * V1
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C2**T *V2
|
||||
*
|
||||
CALL DGEMM( 'Transpose', 'No transpose',
|
||||
$ LASTC, K, LASTV-K,
|
||||
$ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T**T or W * T
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - V * W**T
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C2 := C2 - V2 * W**T
|
||||
*
|
||||
CALL DGEMM( 'No transpose', 'Transpose',
|
||||
$ LASTV-K, LASTC, K,
|
||||
$ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
|
||||
$ C( K+1, 1 ), LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V1**T
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W**T
|
||||
*
|
||||
DO 30 J = 1, K
|
||||
DO 20 I = 1, LASTC
|
||||
C( J, I ) = C( J, I ) - WORK( I, J )
|
||||
20 CONTINUE
|
||||
30 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
*
|
||||
* Form C * H or C * H**T where C = ( C1 C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILADLR( N, K, V, LDV ) )
|
||||
LASTC = ILADLR( M, LASTV, C, LDC )
|
||||
*
|
||||
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
|
||||
*
|
||||
* W := C1
|
||||
*
|
||||
DO 40 J = 1, K
|
||||
CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
|
||||
40 CONTINUE
|
||||
*
|
||||
* W := W * V1
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C2 * V2
|
||||
*
|
||||
CALL DGEMM( 'No transpose', 'No transpose',
|
||||
$ LASTC, K, LASTV-K,
|
||||
$ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T or W * T**T
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - W * V**T
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C2 := C2 - W * V2**T
|
||||
*
|
||||
CALL DGEMM( 'No transpose', 'Transpose',
|
||||
$ LASTC, LASTV-K, K,
|
||||
$ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
|
||||
$ C( 1, K+1 ), LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V1**T
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W
|
||||
*
|
||||
DO 60 J = 1, K
|
||||
DO 50 I = 1, LASTC
|
||||
C( I, J ) = C( I, J ) - WORK( I, J )
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
END IF
|
||||
*
|
||||
ELSE
|
||||
*
|
||||
* Let V = ( V1 )
|
||||
* ( V2 ) (last K rows)
|
||||
* where V2 is unit upper triangular.
|
||||
*
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
*
|
||||
* Form H * C or H**T * C where C = ( C1 )
|
||||
* ( C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILADLR( M, K, V, LDV ) )
|
||||
LASTC = ILADLC( LASTV, N, C, LDC )
|
||||
*
|
||||
* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
|
||||
*
|
||||
* W := C2**T
|
||||
*
|
||||
DO 70 J = 1, K
|
||||
CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
|
||||
$ WORK( 1, J ), 1 )
|
||||
70 CONTINUE
|
||||
*
|
||||
* W := W * V2
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C1**T*V1
|
||||
*
|
||||
CALL DGEMM( 'Transpose', 'No transpose',
|
||||
$ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T**T or W * T
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - V * W**T
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C1 := C1 - V1 * W**T
|
||||
*
|
||||
CALL DGEMM( 'No transpose', 'Transpose',
|
||||
$ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
|
||||
$ ONE, C, LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V2**T
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
*
|
||||
* C2 := C2 - W**T
|
||||
*
|
||||
DO 90 J = 1, K
|
||||
DO 80 I = 1, LASTC
|
||||
C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J)
|
||||
80 CONTINUE
|
||||
90 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
*
|
||||
* Form C * H or C * H**T where C = ( C1 C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILADLR( N, K, V, LDV ) )
|
||||
LASTC = ILADLR( M, LASTV, C, LDC )
|
||||
*
|
||||
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
|
||||
*
|
||||
* W := C2
|
||||
*
|
||||
DO 100 J = 1, K
|
||||
CALL DCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
|
||||
100 CONTINUE
|
||||
*
|
||||
* W := W * V2
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C1 * V1
|
||||
*
|
||||
CALL DGEMM( 'No transpose', 'No transpose',
|
||||
$ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T or W * T**T
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - W * V**T
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C1 := C1 - W * V1**T
|
||||
*
|
||||
CALL DGEMM( 'No transpose', 'Transpose',
|
||||
$ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
|
||||
$ ONE, C, LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V2**T
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
*
|
||||
* C2 := C2 - W
|
||||
*
|
||||
DO 120 J = 1, K
|
||||
DO 110 I = 1, LASTC
|
||||
C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J)
|
||||
110 CONTINUE
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
ELSE IF( LSAME( STOREV, 'R' ) ) THEN
|
||||
*
|
||||
IF( LSAME( DIRECT, 'F' ) ) THEN
|
||||
*
|
||||
* Let V = ( V1 V2 ) (V1: first K columns)
|
||||
* where V1 is unit upper triangular.
|
||||
*
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
*
|
||||
* Form H * C or H**T * C where C = ( C1 )
|
||||
* ( C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILADLC( K, M, V, LDV ) )
|
||||
LASTC = ILADLC( LASTV, N, C, LDC )
|
||||
*
|
||||
* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
|
||||
*
|
||||
* W := C1**T
|
||||
*
|
||||
DO 130 J = 1, K
|
||||
CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
|
||||
130 CONTINUE
|
||||
*
|
||||
* W := W * V1**T
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C2**T*V2**T
|
||||
*
|
||||
CALL DGEMM( 'Transpose', 'Transpose',
|
||||
$ LASTC, K, LASTV-K,
|
||||
$ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T**T or W * T
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - V**T * W**T
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C2 := C2 - V2**T * W**T
|
||||
*
|
||||
CALL DGEMM( 'Transpose', 'Transpose',
|
||||
$ LASTV-K, LASTC, K,
|
||||
$ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
|
||||
$ ONE, C( K+1, 1 ), LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V1
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W**T
|
||||
*
|
||||
DO 150 J = 1, K
|
||||
DO 140 I = 1, LASTC
|
||||
C( J, I ) = C( J, I ) - WORK( I, J )
|
||||
140 CONTINUE
|
||||
150 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
*
|
||||
* Form C * H or C * H**T where C = ( C1 C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILADLC( K, N, V, LDV ) )
|
||||
LASTC = ILADLR( M, LASTV, C, LDC )
|
||||
*
|
||||
* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
|
||||
*
|
||||
* W := C1
|
||||
*
|
||||
DO 160 J = 1, K
|
||||
CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
|
||||
160 CONTINUE
|
||||
*
|
||||
* W := W * V1**T
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C2 * V2**T
|
||||
*
|
||||
CALL DGEMM( 'No transpose', 'Transpose',
|
||||
$ LASTC, K, LASTV-K,
|
||||
$ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T or W * T**T
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - W * V
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C2 := C2 - W * V2
|
||||
*
|
||||
CALL DGEMM( 'No transpose', 'No transpose',
|
||||
$ LASTC, LASTV-K, K,
|
||||
$ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
|
||||
$ ONE, C( 1, K+1 ), LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V1
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W
|
||||
*
|
||||
DO 180 J = 1, K
|
||||
DO 170 I = 1, LASTC
|
||||
C( I, J ) = C( I, J ) - WORK( I, J )
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
*
|
||||
END IF
|
||||
*
|
||||
ELSE
|
||||
*
|
||||
* Let V = ( V1 V2 ) (V2: last K columns)
|
||||
* where V2 is unit lower triangular.
|
||||
*
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
*
|
||||
* Form H * C or H**T * C where C = ( C1 )
|
||||
* ( C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILADLC( K, M, V, LDV ) )
|
||||
LASTC = ILADLC( LASTV, N, C, LDC )
|
||||
*
|
||||
* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
|
||||
*
|
||||
* W := C2**T
|
||||
*
|
||||
DO 190 J = 1, K
|
||||
CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
|
||||
$ WORK( 1, J ), 1 )
|
||||
190 CONTINUE
|
||||
*
|
||||
* W := W * V2**T
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C1**T * V1**T
|
||||
*
|
||||
CALL DGEMM( 'Transpose', 'Transpose',
|
||||
$ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T**T or W * T
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - V**T * W**T
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C1 := C1 - V1**T * W**T
|
||||
*
|
||||
CALL DGEMM( 'Transpose', 'Transpose',
|
||||
$ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
|
||||
$ ONE, C, LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V2
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
*
|
||||
* C2 := C2 - W**T
|
||||
*
|
||||
DO 210 J = 1, K
|
||||
DO 200 I = 1, LASTC
|
||||
C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J)
|
||||
200 CONTINUE
|
||||
210 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
*
|
||||
* Form C * H or C * H**T where C = ( C1 C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILADLC( K, N, V, LDV ) )
|
||||
LASTC = ILADLR( M, LASTV, C, LDC )
|
||||
*
|
||||
* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
|
||||
*
|
||||
* W := C2
|
||||
*
|
||||
DO 220 J = 1, K
|
||||
CALL DCOPY( LASTC, C( 1, LASTV-K+J ), 1,
|
||||
$ WORK( 1, J ), 1 )
|
||||
220 CONTINUE
|
||||
*
|
||||
* W := W * V2**T
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C1 * V1**T
|
||||
*
|
||||
CALL DGEMM( 'No transpose', 'Transpose',
|
||||
$ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T or W * T**T
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - W * V
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C1 := C1 - W * V1
|
||||
*
|
||||
CALL DGEMM( 'No transpose', 'No transpose',
|
||||
$ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
|
||||
$ ONE, C, LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V2
|
||||
*
|
||||
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W
|
||||
*
|
||||
DO 240 J = 1, K
|
||||
DO 230 I = 1, LASTC
|
||||
C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J)
|
||||
230 CONTINUE
|
||||
240 CONTINUE
|
||||
*
|
||||
END IF
|
||||
*
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DLARFB
|
||||
*
|
||||
END
|
||||
196
cs440-acg/ext/eigen/lapack/dlarfg.f
Normal file
196
cs440-acg/ext/eigen/lapack/dlarfg.f
Normal file
@@ -0,0 +1,196 @@
|
||||
*> \brief \b DLARFG
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download DLARFG + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarfg.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarfg.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarfg.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX, N
|
||||
* DOUBLE PRECISION ALPHA, TAU
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION X( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLARFG generates a real elementary reflector H of order n, such
|
||||
*> that
|
||||
*>
|
||||
*> H * ( alpha ) = ( beta ), H**T * H = I.
|
||||
*> ( x ) ( 0 )
|
||||
*>
|
||||
*> where alpha and beta are scalars, and x is an (n-1)-element real
|
||||
*> vector. H is represented in the form
|
||||
*>
|
||||
*> H = I - tau * ( 1 ) * ( 1 v**T ) ,
|
||||
*> ( v )
|
||||
*>
|
||||
*> where tau is a real scalar and v is a real (n-1)-element
|
||||
*> vector.
|
||||
*>
|
||||
*> If the elements of x are all zero, then tau = 0 and H is taken to be
|
||||
*> the unit matrix.
|
||||
*>
|
||||
*> Otherwise 1 <= tau <= 2.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the elementary reflector.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is DOUBLE PRECISION
|
||||
*> On entry, the value alpha.
|
||||
*> On exit, it is overwritten with the value beta.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION array, dimension
|
||||
*> (1+(N-2)*abs(INCX))
|
||||
*> On entry, the vector x.
|
||||
*> On exit, it is overwritten with the vector v.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> The increment between elements of X. INCX > 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] TAU
|
||||
*> \verbatim
|
||||
*> TAU is DOUBLE PRECISION
|
||||
*> The value tau.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup doubleOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX, N
|
||||
DOUBLE PRECISION ALPHA, TAU
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION X( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE, ZERO
|
||||
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER J, KNT
|
||||
DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2
|
||||
EXTERNAL DLAMCH, DLAPY2, DNRM2
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, SIGN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DSCAL
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( N.LE.1 ) THEN
|
||||
TAU = ZERO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
XNORM = DNRM2( N-1, X, INCX )
|
||||
*
|
||||
IF( XNORM.EQ.ZERO ) THEN
|
||||
*
|
||||
* H = I
|
||||
*
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
*
|
||||
* general case
|
||||
*
|
||||
BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
|
||||
SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
|
||||
KNT = 0
|
||||
IF( ABS( BETA ).LT.SAFMIN ) THEN
|
||||
*
|
||||
* XNORM, BETA may be inaccurate; scale X and recompute them
|
||||
*
|
||||
RSAFMN = ONE / SAFMIN
|
||||
10 CONTINUE
|
||||
KNT = KNT + 1
|
||||
CALL DSCAL( N-1, RSAFMN, X, INCX )
|
||||
BETA = BETA*RSAFMN
|
||||
ALPHA = ALPHA*RSAFMN
|
||||
IF( ABS( BETA ).LT.SAFMIN )
|
||||
$ GO TO 10
|
||||
*
|
||||
* New BETA is at most 1, at least SAFMIN
|
||||
*
|
||||
XNORM = DNRM2( N-1, X, INCX )
|
||||
BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
|
||||
END IF
|
||||
TAU = ( BETA-ALPHA ) / BETA
|
||||
CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
|
||||
*
|
||||
* If ALPHA is subnormal, it may lose relative accuracy
|
||||
*
|
||||
DO 20 J = 1, KNT
|
||||
BETA = BETA*SAFMIN
|
||||
20 CONTINUE
|
||||
ALPHA = BETA
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DLARFG
|
||||
*
|
||||
END
|
||||
326
cs440-acg/ext/eigen/lapack/dlarft.f
Normal file
326
cs440-acg/ext/eigen/lapack/dlarft.f
Normal file
@@ -0,0 +1,326 @@
|
||||
*> \brief \b DLARFT
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download DLARFT + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarft.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarft.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarft.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER DIRECT, STOREV
|
||||
* INTEGER K, LDT, LDV, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLARFT forms the triangular factor T of a real block reflector H
|
||||
*> of order n, which is defined as a product of k elementary reflectors.
|
||||
*>
|
||||
*> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
|
||||
*>
|
||||
*> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
|
||||
*>
|
||||
*> If STOREV = 'C', the vector which defines the elementary reflector
|
||||
*> H(i) is stored in the i-th column of the array V, and
|
||||
*>
|
||||
*> H = I - V * T * V**T
|
||||
*>
|
||||
*> If STOREV = 'R', the vector which defines the elementary reflector
|
||||
*> H(i) is stored in the i-th row of the array V, and
|
||||
*>
|
||||
*> H = I - V**T * T * V
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] DIRECT
|
||||
*> \verbatim
|
||||
*> DIRECT is CHARACTER*1
|
||||
*> Specifies the order in which the elementary reflectors are
|
||||
*> multiplied to form the block reflector:
|
||||
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
|
||||
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] STOREV
|
||||
*> \verbatim
|
||||
*> STOREV is CHARACTER*1
|
||||
*> Specifies how the vectors which define the elementary
|
||||
*> reflectors are stored (see also Further Details):
|
||||
*> = 'C': columnwise
|
||||
*> = 'R': rowwise
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the block reflector H. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The order of the triangular factor T (= the number of
|
||||
*> elementary reflectors). K >= 1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] V
|
||||
*> \verbatim
|
||||
*> V is DOUBLE PRECISION array, dimension
|
||||
*> (LDV,K) if STOREV = 'C'
|
||||
*> (LDV,N) if STOREV = 'R'
|
||||
*> The matrix V. See further details.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDV
|
||||
*> \verbatim
|
||||
*> LDV is INTEGER
|
||||
*> The leading dimension of the array V.
|
||||
*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TAU
|
||||
*> \verbatim
|
||||
*> TAU is DOUBLE PRECISION array, dimension (K)
|
||||
*> TAU(i) must contain the scalar factor of the elementary
|
||||
*> reflector H(i).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] T
|
||||
*> \verbatim
|
||||
*> T is DOUBLE PRECISION array, dimension (LDT,K)
|
||||
*> The k by k triangular factor T of the block reflector.
|
||||
*> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
|
||||
*> lower triangular. The rest of the array is not used.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDT
|
||||
*> \verbatim
|
||||
*> LDT is INTEGER
|
||||
*> The leading dimension of the array T. LDT >= K.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date April 2012
|
||||
*
|
||||
*> \ingroup doubleOTHERauxiliary
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> The shape of the matrix V and the storage of the vectors which define
|
||||
*> the H(i) is best illustrated by the following example with n = 5 and
|
||||
*> k = 3. The elements equal to 1 are not stored.
|
||||
*>
|
||||
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
|
||||
*>
|
||||
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
|
||||
*> ( v1 1 ) ( 1 v2 v2 v2 )
|
||||
*> ( v1 v2 1 ) ( 1 v3 v3 )
|
||||
*> ( v1 v2 v3 )
|
||||
*> ( v1 v2 v3 )
|
||||
*>
|
||||
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
|
||||
*>
|
||||
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
|
||||
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
|
||||
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
|
||||
*> ( 1 v3 )
|
||||
*> ( 1 )
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.1) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* April 2012
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER DIRECT, STOREV
|
||||
INTEGER K, LDT, LDV, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE, ZERO
|
||||
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J, PREVLASTV, LASTV
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DGEMV, DTRMV
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
IF( LSAME( DIRECT, 'F' ) ) THEN
|
||||
PREVLASTV = N
|
||||
DO I = 1, K
|
||||
PREVLASTV = MAX( I, PREVLASTV )
|
||||
IF( TAU( I ).EQ.ZERO ) THEN
|
||||
*
|
||||
* H(i) = I
|
||||
*
|
||||
DO J = 1, I
|
||||
T( J, I ) = ZERO
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* general case
|
||||
*
|
||||
IF( LSAME( STOREV, 'C' ) ) THEN
|
||||
* Skip any trailing zeros.
|
||||
DO LASTV = N, I+1, -1
|
||||
IF( V( LASTV, I ).NE.ZERO ) EXIT
|
||||
END DO
|
||||
DO J = 1, I-1
|
||||
T( J, I ) = -TAU( I ) * V( I , J )
|
||||
END DO
|
||||
J = MIN( LASTV, PREVLASTV )
|
||||
*
|
||||
* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i)
|
||||
*
|
||||
CALL DGEMV( 'Transpose', J-I, I-1, -TAU( I ),
|
||||
$ V( I+1, 1 ), LDV, V( I+1, I ), 1, ONE,
|
||||
$ T( 1, I ), 1 )
|
||||
ELSE
|
||||
* Skip any trailing zeros.
|
||||
DO LASTV = N, I+1, -1
|
||||
IF( V( I, LASTV ).NE.ZERO ) EXIT
|
||||
END DO
|
||||
DO J = 1, I-1
|
||||
T( J, I ) = -TAU( I ) * V( J , I )
|
||||
END DO
|
||||
J = MIN( LASTV, PREVLASTV )
|
||||
*
|
||||
* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T
|
||||
*
|
||||
CALL DGEMV( 'No transpose', I-1, J-I, -TAU( I ),
|
||||
$ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, ONE,
|
||||
$ T( 1, I ), 1 )
|
||||
END IF
|
||||
*
|
||||
* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
|
||||
*
|
||||
CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
|
||||
$ LDT, T( 1, I ), 1 )
|
||||
T( I, I ) = TAU( I )
|
||||
IF( I.GT.1 ) THEN
|
||||
PREVLASTV = MAX( PREVLASTV, LASTV )
|
||||
ELSE
|
||||
PREVLASTV = LASTV
|
||||
END IF
|
||||
END IF
|
||||
END DO
|
||||
ELSE
|
||||
PREVLASTV = 1
|
||||
DO I = K, 1, -1
|
||||
IF( TAU( I ).EQ.ZERO ) THEN
|
||||
*
|
||||
* H(i) = I
|
||||
*
|
||||
DO J = I, K
|
||||
T( J, I ) = ZERO
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* general case
|
||||
*
|
||||
IF( I.LT.K ) THEN
|
||||
IF( LSAME( STOREV, 'C' ) ) THEN
|
||||
* Skip any leading zeros.
|
||||
DO LASTV = 1, I-1
|
||||
IF( V( LASTV, I ).NE.ZERO ) EXIT
|
||||
END DO
|
||||
DO J = I+1, K
|
||||
T( J, I ) = -TAU( I ) * V( N-K+I , J )
|
||||
END DO
|
||||
J = MAX( LASTV, PREVLASTV )
|
||||
*
|
||||
* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i)
|
||||
*
|
||||
CALL DGEMV( 'Transpose', N-K+I-J, K-I, -TAU( I ),
|
||||
$ V( J, I+1 ), LDV, V( J, I ), 1, ONE,
|
||||
$ T( I+1, I ), 1 )
|
||||
ELSE
|
||||
* Skip any leading zeros.
|
||||
DO LASTV = 1, I-1
|
||||
IF( V( I, LASTV ).NE.ZERO ) EXIT
|
||||
END DO
|
||||
DO J = I+1, K
|
||||
T( J, I ) = -TAU( I ) * V( J, N-K+I )
|
||||
END DO
|
||||
J = MAX( LASTV, PREVLASTV )
|
||||
*
|
||||
* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T
|
||||
*
|
||||
CALL DGEMV( 'No transpose', K-I, N-K+I-J,
|
||||
$ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV,
|
||||
$ ONE, T( I+1, I ), 1 )
|
||||
END IF
|
||||
*
|
||||
* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
|
||||
*
|
||||
CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
|
||||
$ T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
|
||||
IF( I.GT.1 ) THEN
|
||||
PREVLASTV = MIN( PREVLASTV, LASTV )
|
||||
ELSE
|
||||
PREVLASTV = LASTV
|
||||
END IF
|
||||
END IF
|
||||
T( I, I ) = TAU( I )
|
||||
END IF
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of DLARFT
|
||||
*
|
||||
END
|
||||
18
cs440-acg/ext/eigen/lapack/double.cpp
Normal file
18
cs440-acg/ext/eigen/lapack/double.cpp
Normal file
@@ -0,0 +1,18 @@
|
||||
// This file is part of Eigen, a lightweight C++ template library
|
||||
// for linear algebra.
|
||||
//
|
||||
// Copyright (C) 2009-2014 Gael Guennebaud <gael.guennebaud@inria.fr>
|
||||
//
|
||||
// This Source Code Form is subject to the terms of the Mozilla
|
||||
// Public License v. 2.0. If a copy of the MPL was not distributed
|
||||
// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
#define SCALAR double
|
||||
#define SCALAR_SUFFIX d
|
||||
#define SCALAR_SUFFIX_UP "D"
|
||||
#define ISCOMPLEX 0
|
||||
|
||||
#include "cholesky.cpp"
|
||||
#include "lu.cpp"
|
||||
#include "eigenvalues.cpp"
|
||||
#include "svd.cpp"
|
||||
52
cs440-acg/ext/eigen/lapack/dsecnd_NONE.f
Normal file
52
cs440-acg/ext/eigen/lapack/dsecnd_NONE.f
Normal file
@@ -0,0 +1,52 @@
|
||||
*> \brief \b DSECND returns nothing
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* DOUBLE PRECISION FUNCTION DSECND( )
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DSECND returns nothing instead of returning the user time for a process in seconds.
|
||||
*> If you are using that routine, it means that neither EXTERNAL ETIME,
|
||||
*> EXTERNAL ETIME_, INTERNAL ETIME, INTERNAL CPU_TIME is available on
|
||||
*> your machine.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup auxOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
DOUBLE PRECISION FUNCTION DSECND( )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
DSECND = 0.0D+0
|
||||
RETURN
|
||||
*
|
||||
* End of DSECND
|
||||
*
|
||||
END
|
||||
62
cs440-acg/ext/eigen/lapack/eigenvalues.cpp
Normal file
62
cs440-acg/ext/eigen/lapack/eigenvalues.cpp
Normal file
@@ -0,0 +1,62 @@
|
||||
// This file is part of Eigen, a lightweight C++ template library
|
||||
// for linear algebra.
|
||||
//
|
||||
// Copyright (C) 2011 Gael Guennebaud <gael.guennebaud@inria.fr>
|
||||
//
|
||||
// This Source Code Form is subject to the terms of the Mozilla
|
||||
// Public License v. 2.0. If a copy of the MPL was not distributed
|
||||
// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
#include "lapack_common.h"
|
||||
#include <Eigen/Eigenvalues>
|
||||
|
||||
// computes eigen values and vectors of a general N-by-N matrix A
|
||||
EIGEN_LAPACK_FUNC(syev,(char *jobz, char *uplo, int* n, Scalar* a, int *lda, Scalar* w, Scalar* /*work*/, int* lwork, int *info))
|
||||
{
|
||||
// TODO exploit the work buffer
|
||||
bool query_size = *lwork==-1;
|
||||
|
||||
*info = 0;
|
||||
if(*jobz!='N' && *jobz!='V') *info = -1;
|
||||
else if(UPLO(*uplo)==INVALID) *info = -2;
|
||||
else if(*n<0) *info = -3;
|
||||
else if(*lda<std::max(1,*n)) *info = -5;
|
||||
else if((!query_size) && *lwork<std::max(1,3**n-1)) *info = -8;
|
||||
|
||||
if(*info!=0)
|
||||
{
|
||||
int e = -*info;
|
||||
return xerbla_(SCALAR_SUFFIX_UP"SYEV ", &e, 6);
|
||||
}
|
||||
|
||||
if(query_size)
|
||||
{
|
||||
*lwork = 0;
|
||||
return 0;
|
||||
}
|
||||
|
||||
if(*n==0)
|
||||
return 0;
|
||||
|
||||
PlainMatrixType mat(*n,*n);
|
||||
if(UPLO(*uplo)==UP) mat = matrix(a,*n,*n,*lda).adjoint();
|
||||
else mat = matrix(a,*n,*n,*lda);
|
||||
|
||||
bool computeVectors = *jobz=='V' || *jobz=='v';
|
||||
SelfAdjointEigenSolver<PlainMatrixType> eig(mat,computeVectors?ComputeEigenvectors:EigenvaluesOnly);
|
||||
|
||||
if(eig.info()==NoConvergence)
|
||||
{
|
||||
make_vector(w,*n).setZero();
|
||||
if(computeVectors)
|
||||
matrix(a,*n,*n,*lda).setIdentity();
|
||||
//*info = 1;
|
||||
return 0;
|
||||
}
|
||||
|
||||
make_vector(w,*n) = eig.eigenvalues();
|
||||
if(computeVectors)
|
||||
matrix(a,*n,*n,*lda) = eig.eigenvectors();
|
||||
|
||||
return 0;
|
||||
}
|
||||
118
cs440-acg/ext/eigen/lapack/ilaclc.f
Normal file
118
cs440-acg/ext/eigen/lapack/ilaclc.f
Normal file
@@ -0,0 +1,118 @@
|
||||
*> \brief \b ILACLC
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ILACLC + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ilaclc.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ilaclc.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ilaclc.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* INTEGER FUNCTION ILACLC( M, N, A, LDA )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER M, N, LDA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ILACLC scans A for its last non-zero column.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX array, dimension (LDA,N)
|
||||
*> The m by n matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,M).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complexOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
INTEGER FUNCTION ILACLC( M, N, A, LDA )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER M, N, LDA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ZERO
|
||||
PARAMETER ( ZERO = (0.0E+0, 0.0E+0) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Quick test for the common case where one corner is non-zero.
|
||||
IF( N.EQ.0 ) THEN
|
||||
ILACLC = N
|
||||
ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
|
||||
ILACLC = N
|
||||
ELSE
|
||||
* Now scan each column from the end, returning with the first non-zero.
|
||||
DO ILACLC = N, 1, -1
|
||||
DO I = 1, M
|
||||
IF( A(I, ILACLC).NE.ZERO ) RETURN
|
||||
END DO
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
121
cs440-acg/ext/eigen/lapack/ilaclr.f
Normal file
121
cs440-acg/ext/eigen/lapack/ilaclr.f
Normal file
@@ -0,0 +1,121 @@
|
||||
*> \brief \b ILACLR
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ILACLR + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ilaclr.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ilaclr.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ilaclr.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* INTEGER FUNCTION ILACLR( M, N, A, LDA )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER M, N, LDA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ILACLR scans A for its last non-zero row.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is array, dimension (LDA,N)
|
||||
*> The m by n matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,M).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date April 2012
|
||||
*
|
||||
*> \ingroup complexOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
INTEGER FUNCTION ILACLR( M, N, A, LDA )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.1) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* April 2012
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER M, N, LDA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ZERO
|
||||
PARAMETER ( ZERO = (0.0E+0, 0.0E+0) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Quick test for the common case where one corner is non-zero.
|
||||
IF( M.EQ.0 ) THEN
|
||||
ILACLR = M
|
||||
ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
|
||||
ILACLR = M
|
||||
ELSE
|
||||
* Scan up each column tracking the last zero row seen.
|
||||
ILACLR = 0
|
||||
DO J = 1, N
|
||||
I=M
|
||||
DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1))
|
||||
I=I-1
|
||||
ENDDO
|
||||
ILACLR = MAX( ILACLR, I )
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
118
cs440-acg/ext/eigen/lapack/iladlc.f
Normal file
118
cs440-acg/ext/eigen/lapack/iladlc.f
Normal file
@@ -0,0 +1,118 @@
|
||||
*> \brief \b ILADLC
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ILADLC + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/iladlc.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/iladlc.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/iladlc.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* INTEGER FUNCTION ILADLC( M, N, A, LDA )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER M, N, LDA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ILADLC scans A for its last non-zero column.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array, dimension (LDA,N)
|
||||
*> The m by n matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,M).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup auxOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
INTEGER FUNCTION ILADLC( M, N, A, LDA )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER M, N, LDA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER ( ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Quick test for the common case where one corner is non-zero.
|
||||
IF( N.EQ.0 ) THEN
|
||||
ILADLC = N
|
||||
ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
|
||||
ILADLC = N
|
||||
ELSE
|
||||
* Now scan each column from the end, returning with the first non-zero.
|
||||
DO ILADLC = N, 1, -1
|
||||
DO I = 1, M
|
||||
IF( A(I, ILADLC).NE.ZERO ) RETURN
|
||||
END DO
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
121
cs440-acg/ext/eigen/lapack/iladlr.f
Normal file
121
cs440-acg/ext/eigen/lapack/iladlr.f
Normal file
@@ -0,0 +1,121 @@
|
||||
*> \brief \b ILADLR
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ILADLR + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/iladlr.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/iladlr.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/iladlr.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* INTEGER FUNCTION ILADLR( M, N, A, LDA )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER M, N, LDA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ILADLR scans A for its last non-zero row.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array, dimension (LDA,N)
|
||||
*> The m by n matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,M).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date April 2012
|
||||
*
|
||||
*> \ingroup auxOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
INTEGER FUNCTION ILADLR( M, N, A, LDA )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.1) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* April 2012
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER M, N, LDA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER ( ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Quick test for the common case where one corner is non-zero.
|
||||
IF( M.EQ.0 ) THEN
|
||||
ILADLR = M
|
||||
ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
|
||||
ILADLR = M
|
||||
ELSE
|
||||
* Scan up each column tracking the last zero row seen.
|
||||
ILADLR = 0
|
||||
DO J = 1, N
|
||||
I=M
|
||||
DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1))
|
||||
I=I-1
|
||||
ENDDO
|
||||
ILADLR = MAX( ILADLR, I )
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
118
cs440-acg/ext/eigen/lapack/ilaslc.f
Normal file
118
cs440-acg/ext/eigen/lapack/ilaslc.f
Normal file
@@ -0,0 +1,118 @@
|
||||
*> \brief \b ILASLC
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ILASLC + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ilaslc.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ilaslc.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ilaslc.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* INTEGER FUNCTION ILASLC( M, N, A, LDA )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER M, N, LDA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ILASLC scans A for its last non-zero column.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is REAL array, dimension (LDA,N)
|
||||
*> The m by n matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,M).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup realOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
INTEGER FUNCTION ILASLC( M, N, A, LDA )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER M, N, LDA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ZERO
|
||||
PARAMETER ( ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Quick test for the common case where one corner is non-zero.
|
||||
IF( N.EQ.0 ) THEN
|
||||
ILASLC = N
|
||||
ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
|
||||
ILASLC = N
|
||||
ELSE
|
||||
* Now scan each column from the end, returning with the first non-zero.
|
||||
DO ILASLC = N, 1, -1
|
||||
DO I = 1, M
|
||||
IF( A(I, ILASLC).NE.ZERO ) RETURN
|
||||
END DO
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
121
cs440-acg/ext/eigen/lapack/ilaslr.f
Normal file
121
cs440-acg/ext/eigen/lapack/ilaslr.f
Normal file
@@ -0,0 +1,121 @@
|
||||
*> \brief \b ILASLR
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ILASLR + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ilaslr.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ilaslr.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ilaslr.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* INTEGER FUNCTION ILASLR( M, N, A, LDA )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER M, N, LDA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ILASLR scans A for its last non-zero row.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is REAL array, dimension (LDA,N)
|
||||
*> The m by n matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,M).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date April 2012
|
||||
*
|
||||
*> \ingroup realOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
INTEGER FUNCTION ILASLR( M, N, A, LDA )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.1) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* April 2012
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER M, N, LDA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ZERO
|
||||
PARAMETER ( ZERO = 0.0E+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Quick test for the common case where one corner is non-zero.
|
||||
IF( M.EQ.0 ) THEN
|
||||
ILASLR = M
|
||||
ELSEIF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
|
||||
ILASLR = M
|
||||
ELSE
|
||||
* Scan up each column tracking the last zero row seen.
|
||||
ILASLR = 0
|
||||
DO J = 1, N
|
||||
I=M
|
||||
DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1))
|
||||
I=I-1
|
||||
ENDDO
|
||||
ILASLR = MAX( ILASLR, I )
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
118
cs440-acg/ext/eigen/lapack/ilazlc.f
Normal file
118
cs440-acg/ext/eigen/lapack/ilazlc.f
Normal file
@@ -0,0 +1,118 @@
|
||||
*> \brief \b ILAZLC
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ILAZLC + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ilazlc.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ilazlc.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ilazlc.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* INTEGER FUNCTION ILAZLC( M, N, A, LDA )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER M, N, LDA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ILAZLC scans A for its last non-zero column.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA,N)
|
||||
*> The m by n matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,M).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16OTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
INTEGER FUNCTION ILAZLC( M, N, A, LDA )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER M, N, LDA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ZERO
|
||||
PARAMETER ( ZERO = (0.0D+0, 0.0D+0) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Quick test for the common case where one corner is non-zero.
|
||||
IF( N.EQ.0 ) THEN
|
||||
ILAZLC = N
|
||||
ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
|
||||
ILAZLC = N
|
||||
ELSE
|
||||
* Now scan each column from the end, returning with the first non-zero.
|
||||
DO ILAZLC = N, 1, -1
|
||||
DO I = 1, M
|
||||
IF( A(I, ILAZLC).NE.ZERO ) RETURN
|
||||
END DO
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
121
cs440-acg/ext/eigen/lapack/ilazlr.f
Normal file
121
cs440-acg/ext/eigen/lapack/ilazlr.f
Normal file
@@ -0,0 +1,121 @@
|
||||
*> \brief \b ILAZLR
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ILAZLR + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ilazlr.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ilazlr.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ilazlr.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* INTEGER FUNCTION ILAZLR( M, N, A, LDA )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER M, N, LDA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ILAZLR scans A for its last non-zero row.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA,N)
|
||||
*> The m by n matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,M).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date April 2012
|
||||
*
|
||||
*> \ingroup complex16OTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
INTEGER FUNCTION ILAZLR( M, N, A, LDA )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.1) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* April 2012
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER M, N, LDA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ZERO
|
||||
PARAMETER ( ZERO = (0.0D+0, 0.0D+0) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Quick test for the common case where one corner is non-zero.
|
||||
IF( M.EQ.0 ) THEN
|
||||
ILAZLR = M
|
||||
ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
|
||||
ILAZLR = M
|
||||
ELSE
|
||||
* Scan up each column tracking the last zero row seen.
|
||||
ILAZLR = 0
|
||||
DO J = 1, N
|
||||
I=M
|
||||
DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1))
|
||||
I=I-1
|
||||
ENDDO
|
||||
ILAZLR = MAX( ILAZLR, I )
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
29
cs440-acg/ext/eigen/lapack/lapack_common.h
Normal file
29
cs440-acg/ext/eigen/lapack/lapack_common.h
Normal file
@@ -0,0 +1,29 @@
|
||||
// This file is part of Eigen, a lightweight C++ template library
|
||||
// for linear algebra.
|
||||
//
|
||||
// Copyright (C) 2010-2014 Gael Guennebaud <gael.guennebaud@inria.fr>
|
||||
//
|
||||
// This Source Code Form is subject to the terms of the Mozilla
|
||||
// Public License v. 2.0. If a copy of the MPL was not distributed
|
||||
// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
#ifndef EIGEN_LAPACK_COMMON_H
|
||||
#define EIGEN_LAPACK_COMMON_H
|
||||
|
||||
#include "../blas/common.h"
|
||||
#include "../Eigen/src/misc/lapack.h"
|
||||
|
||||
#define EIGEN_LAPACK_FUNC(FUNC,ARGLIST) \
|
||||
extern "C" { int EIGEN_BLAS_FUNC(FUNC) ARGLIST; } \
|
||||
int EIGEN_BLAS_FUNC(FUNC) ARGLIST
|
||||
|
||||
typedef Eigen::Map<Eigen::Transpositions<Eigen::Dynamic,Eigen::Dynamic,int> > PivotsType;
|
||||
|
||||
#if ISCOMPLEX
|
||||
#define EIGEN_LAPACK_ARG_IF_COMPLEX(X) X,
|
||||
#else
|
||||
#define EIGEN_LAPACK_ARG_IF_COMPLEX(X)
|
||||
#endif
|
||||
|
||||
|
||||
#endif // EIGEN_LAPACK_COMMON_H
|
||||
89
cs440-acg/ext/eigen/lapack/lu.cpp
Normal file
89
cs440-acg/ext/eigen/lapack/lu.cpp
Normal file
@@ -0,0 +1,89 @@
|
||||
// This file is part of Eigen, a lightweight C++ template library
|
||||
// for linear algebra.
|
||||
//
|
||||
// Copyright (C) 2010-2011 Gael Guennebaud <gael.guennebaud@inria.fr>
|
||||
//
|
||||
// This Source Code Form is subject to the terms of the Mozilla
|
||||
// Public License v. 2.0. If a copy of the MPL was not distributed
|
||||
// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
#include "common.h"
|
||||
#include <Eigen/LU>
|
||||
|
||||
// computes an LU factorization of a general M-by-N matrix A using partial pivoting with row interchanges
|
||||
EIGEN_LAPACK_FUNC(getrf,(int *m, int *n, RealScalar *pa, int *lda, int *ipiv, int *info))
|
||||
{
|
||||
*info = 0;
|
||||
if(*m<0) *info = -1;
|
||||
else if(*n<0) *info = -2;
|
||||
else if(*lda<std::max(1,*m)) *info = -4;
|
||||
if(*info!=0)
|
||||
{
|
||||
int e = -*info;
|
||||
return xerbla_(SCALAR_SUFFIX_UP"GETRF", &e, 6);
|
||||
}
|
||||
|
||||
if(*m==0 || *n==0)
|
||||
return 0;
|
||||
|
||||
Scalar* a = reinterpret_cast<Scalar*>(pa);
|
||||
int nb_transpositions;
|
||||
int ret = int(Eigen::internal::partial_lu_impl<Scalar,ColMajor,int>
|
||||
::blocked_lu(*m, *n, a, *lda, ipiv, nb_transpositions));
|
||||
|
||||
for(int i=0; i<std::min(*m,*n); ++i)
|
||||
ipiv[i]++;
|
||||
|
||||
if(ret>=0)
|
||||
*info = ret+1;
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
//GETRS solves a system of linear equations
|
||||
// A * X = B or A' * X = B
|
||||
// with a general N-by-N matrix A using the LU factorization computed by GETRF
|
||||
EIGEN_LAPACK_FUNC(getrs,(char *trans, int *n, int *nrhs, RealScalar *pa, int *lda, int *ipiv, RealScalar *pb, int *ldb, int *info))
|
||||
{
|
||||
*info = 0;
|
||||
if(OP(*trans)==INVALID) *info = -1;
|
||||
else if(*n<0) *info = -2;
|
||||
else if(*nrhs<0) *info = -3;
|
||||
else if(*lda<std::max(1,*n)) *info = -5;
|
||||
else if(*ldb<std::max(1,*n)) *info = -8;
|
||||
if(*info!=0)
|
||||
{
|
||||
int e = -*info;
|
||||
return xerbla_(SCALAR_SUFFIX_UP"GETRS", &e, 6);
|
||||
}
|
||||
|
||||
Scalar* a = reinterpret_cast<Scalar*>(pa);
|
||||
Scalar* b = reinterpret_cast<Scalar*>(pb);
|
||||
MatrixType lu(a,*n,*n,*lda);
|
||||
MatrixType B(b,*n,*nrhs,*ldb);
|
||||
|
||||
for(int i=0; i<*n; ++i)
|
||||
ipiv[i]--;
|
||||
if(OP(*trans)==NOTR)
|
||||
{
|
||||
B = PivotsType(ipiv,*n) * B;
|
||||
lu.triangularView<UnitLower>().solveInPlace(B);
|
||||
lu.triangularView<Upper>().solveInPlace(B);
|
||||
}
|
||||
else if(OP(*trans)==TR)
|
||||
{
|
||||
lu.triangularView<Upper>().transpose().solveInPlace(B);
|
||||
lu.triangularView<UnitLower>().transpose().solveInPlace(B);
|
||||
B = PivotsType(ipiv,*n).transpose() * B;
|
||||
}
|
||||
else if(OP(*trans)==ADJ)
|
||||
{
|
||||
lu.triangularView<Upper>().adjoint().solveInPlace(B);
|
||||
lu.triangularView<UnitLower>().adjoint().solveInPlace(B);
|
||||
B = PivotsType(ipiv,*n).transpose() * B;
|
||||
}
|
||||
for(int i=0; i<*n; ++i)
|
||||
ipiv[i]++;
|
||||
|
||||
return 0;
|
||||
}
|
||||
52
cs440-acg/ext/eigen/lapack/second_NONE.f
Normal file
52
cs440-acg/ext/eigen/lapack/second_NONE.f
Normal file
@@ -0,0 +1,52 @@
|
||||
*> \brief \b SECOND returns nothing
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* REAL FUNCTION SECOND( )
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SECOND returns nothing instead of returning the user time for a process in seconds.
|
||||
*> If you are using that routine, it means that neither EXTERNAL ETIME,
|
||||
*> EXTERNAL ETIME_, INTERNAL ETIME, INTERNAL CPU_TIME is available on
|
||||
*> your machine.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup auxOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
REAL FUNCTION SECOND( )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
SECOND = 0.0E+0
|
||||
RETURN
|
||||
*
|
||||
* End of SECOND
|
||||
*
|
||||
END
|
||||
18
cs440-acg/ext/eigen/lapack/single.cpp
Normal file
18
cs440-acg/ext/eigen/lapack/single.cpp
Normal file
@@ -0,0 +1,18 @@
|
||||
// This file is part of Eigen, a lightweight C++ template library
|
||||
// for linear algebra.
|
||||
//
|
||||
// Copyright (C) 2009-2014 Gael Guennebaud <gael.guennebaud@inria.fr>
|
||||
//
|
||||
// This Source Code Form is subject to the terms of the Mozilla
|
||||
// Public License v. 2.0. If a copy of the MPL was not distributed
|
||||
// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
#define SCALAR float
|
||||
#define SCALAR_SUFFIX s
|
||||
#define SCALAR_SUFFIX_UP "S"
|
||||
#define ISCOMPLEX 0
|
||||
|
||||
#include "cholesky.cpp"
|
||||
#include "lu.cpp"
|
||||
#include "eigenvalues.cpp"
|
||||
#include "svd.cpp"
|
||||
128
cs440-acg/ext/eigen/lapack/sladiv.f
Normal file
128
cs440-acg/ext/eigen/lapack/sladiv.f
Normal file
@@ -0,0 +1,128 @@
|
||||
*> \brief \b SLADIV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download SLADIV + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sladiv.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sladiv.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sladiv.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SLADIV( A, B, C, D, P, Q )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* REAL A, B, C, D, P, Q
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLADIV performs complex division in real arithmetic
|
||||
*>
|
||||
*> a + i*b
|
||||
*> p + i*q = ---------
|
||||
*> c + i*d
|
||||
*>
|
||||
*> The algorithm is due to Robert L. Smith and can be found
|
||||
*> in D. Knuth, The art of Computer Programming, Vol.2, p.195
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is REAL
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> B is REAL
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] C
|
||||
*> \verbatim
|
||||
*> C is REAL
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is REAL
|
||||
*> The scalars a, b, c, and d in the above expression.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] P
|
||||
*> \verbatim
|
||||
*> P is REAL
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] Q
|
||||
*> \verbatim
|
||||
*> Q is REAL
|
||||
*> The scalars p and q in the above expression.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup auxOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE SLADIV( A, B, C, D, P, Q )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL A, B, C, D, P, Q
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
REAL E, F
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( ABS( D ).LT.ABS( C ) ) THEN
|
||||
E = D / C
|
||||
F = C + D*E
|
||||
P = ( A+B*E ) / F
|
||||
Q = ( B-A*E ) / F
|
||||
ELSE
|
||||
E = C / D
|
||||
F = D + C*E
|
||||
P = ( B+A*E ) / F
|
||||
Q = ( -A+B*E ) / F
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of SLADIV
|
||||
*
|
||||
END
|
||||
192
cs440-acg/ext/eigen/lapack/slamch.f
Normal file
192
cs440-acg/ext/eigen/lapack/slamch.f
Normal file
@@ -0,0 +1,192 @@
|
||||
*> \brief \b SLAMCH
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* REAL FUNCTION SLAMCH( CMACH )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER CMACH
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLAMCH determines single precision machine parameters.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] CMACH
|
||||
*> \verbatim
|
||||
*> Specifies the value to be returned by SLAMCH:
|
||||
*> = 'E' or 'e', SLAMCH := eps
|
||||
*> = 'S' or 's , SLAMCH := sfmin
|
||||
*> = 'B' or 'b', SLAMCH := base
|
||||
*> = 'P' or 'p', SLAMCH := eps*base
|
||||
*> = 'N' or 'n', SLAMCH := t
|
||||
*> = 'R' or 'r', SLAMCH := rnd
|
||||
*> = 'M' or 'm', SLAMCH := emin
|
||||
*> = 'U' or 'u', SLAMCH := rmin
|
||||
*> = 'L' or 'l', SLAMCH := emax
|
||||
*> = 'O' or 'o', SLAMCH := rmax
|
||||
*> where
|
||||
*> eps = relative machine precision
|
||||
*> sfmin = safe minimum, such that 1/sfmin does not overflow
|
||||
*> base = base of the machine
|
||||
*> prec = eps*base
|
||||
*> t = number of (base) digits in the mantissa
|
||||
*> rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
|
||||
*> emin = minimum exponent before (gradual) underflow
|
||||
*> rmin = underflow threshold - base**(emin-1)
|
||||
*> emax = largest exponent before overflow
|
||||
*> rmax = overflow threshold - (base**emax)*(1-eps)
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup auxOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
REAL FUNCTION SLAMCH( CMACH )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER CMACH
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ONE, ZERO
|
||||
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
REAL RND, EPS, SFMIN, SMALL, RMACH
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT,
|
||||
$ MINEXPONENT, RADIX, TINY
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
*
|
||||
* Assume rounding, not chopping. Always.
|
||||
*
|
||||
RND = ONE
|
||||
*
|
||||
IF( ONE.EQ.RND ) THEN
|
||||
EPS = EPSILON(ZERO) * 0.5
|
||||
ELSE
|
||||
EPS = EPSILON(ZERO)
|
||||
END IF
|
||||
*
|
||||
IF( LSAME( CMACH, 'E' ) ) THEN
|
||||
RMACH = EPS
|
||||
ELSE IF( LSAME( CMACH, 'S' ) ) THEN
|
||||
SFMIN = TINY(ZERO)
|
||||
SMALL = ONE / HUGE(ZERO)
|
||||
IF( SMALL.GE.SFMIN ) THEN
|
||||
*
|
||||
* Use SMALL plus a bit, to avoid the possibility of rounding
|
||||
* causing overflow when computing 1/sfmin.
|
||||
*
|
||||
SFMIN = SMALL*( ONE+EPS )
|
||||
END IF
|
||||
RMACH = SFMIN
|
||||
ELSE IF( LSAME( CMACH, 'B' ) ) THEN
|
||||
RMACH = RADIX(ZERO)
|
||||
ELSE IF( LSAME( CMACH, 'P' ) ) THEN
|
||||
RMACH = EPS * RADIX(ZERO)
|
||||
ELSE IF( LSAME( CMACH, 'N' ) ) THEN
|
||||
RMACH = DIGITS(ZERO)
|
||||
ELSE IF( LSAME( CMACH, 'R' ) ) THEN
|
||||
RMACH = RND
|
||||
ELSE IF( LSAME( CMACH, 'M' ) ) THEN
|
||||
RMACH = MINEXPONENT(ZERO)
|
||||
ELSE IF( LSAME( CMACH, 'U' ) ) THEN
|
||||
RMACH = tiny(zero)
|
||||
ELSE IF( LSAME( CMACH, 'L' ) ) THEN
|
||||
RMACH = MAXEXPONENT(ZERO)
|
||||
ELSE IF( LSAME( CMACH, 'O' ) ) THEN
|
||||
RMACH = HUGE(ZERO)
|
||||
ELSE
|
||||
RMACH = ZERO
|
||||
END IF
|
||||
*
|
||||
SLAMCH = RMACH
|
||||
RETURN
|
||||
*
|
||||
* End of SLAMCH
|
||||
*
|
||||
END
|
||||
************************************************************************
|
||||
*> \brief \b SLAMC3
|
||||
*> \details
|
||||
*> \b Purpose:
|
||||
*> \verbatim
|
||||
*> SLAMC3 is intended to force A and B to be stored prior to doing
|
||||
*> the addition of A and B , for use in situations where optimizers
|
||||
*> might hold one of these in a register.
|
||||
*> \endverbatim
|
||||
*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..
|
||||
*> \date November 2011
|
||||
*> \ingroup auxOTHERauxiliary
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> The values A and B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*
|
||||
REAL FUNCTION SLAMC3( A, B )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
|
||||
* November 2010
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL A, B
|
||||
* ..
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
SLAMC3 = A + B
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of SLAMC3
|
||||
*
|
||||
END
|
||||
*
|
||||
************************************************************************
|
||||
104
cs440-acg/ext/eigen/lapack/slapy2.f
Normal file
104
cs440-acg/ext/eigen/lapack/slapy2.f
Normal file
@@ -0,0 +1,104 @@
|
||||
*> \brief \b SLAPY2
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download SLAPY2 + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slapy2.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slapy2.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slapy2.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* REAL FUNCTION SLAPY2( X, Y )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* REAL X, Y
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
|
||||
*> overflow.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is REAL
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] Y
|
||||
*> \verbatim
|
||||
*> Y is REAL
|
||||
*> X and Y specify the values x and y.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup auxOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
REAL FUNCTION SLAPY2( X, Y )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL X, Y
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ZERO
|
||||
PARAMETER ( ZERO = 0.0E0 )
|
||||
REAL ONE
|
||||
PARAMETER ( ONE = 1.0E0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
REAL W, XABS, YABS, Z
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, MAX, MIN, SQRT
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
XABS = ABS( X )
|
||||
YABS = ABS( Y )
|
||||
W = MAX( XABS, YABS )
|
||||
Z = MIN( XABS, YABS )
|
||||
IF( Z.EQ.ZERO ) THEN
|
||||
SLAPY2 = W
|
||||
ELSE
|
||||
SLAPY2 = W*SQRT( ONE+( Z / W )**2 )
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of SLAPY2
|
||||
*
|
||||
END
|
||||
111
cs440-acg/ext/eigen/lapack/slapy3.f
Normal file
111
cs440-acg/ext/eigen/lapack/slapy3.f
Normal file
@@ -0,0 +1,111 @@
|
||||
*> \brief \b SLAPY3
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download SLAPY3 + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slapy3.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slapy3.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slapy3.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* REAL FUNCTION SLAPY3( X, Y, Z )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* REAL X, Y, Z
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
|
||||
*> unnecessary overflow.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is REAL
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] Y
|
||||
*> \verbatim
|
||||
*> Y is REAL
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] Z
|
||||
*> \verbatim
|
||||
*> Z is REAL
|
||||
*> X, Y and Z specify the values x, y and z.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup auxOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
REAL FUNCTION SLAPY3( X, Y, Z )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
REAL X, Y, Z
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ZERO
|
||||
PARAMETER ( ZERO = 0.0E0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
REAL W, XABS, YABS, ZABS
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, MAX, SQRT
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
XABS = ABS( X )
|
||||
YABS = ABS( Y )
|
||||
ZABS = ABS( Z )
|
||||
W = MAX( XABS, YABS, ZABS )
|
||||
IF( W.EQ.ZERO ) THEN
|
||||
* W can be zero for max(0,nan,0)
|
||||
* adding all three entries together will make sure
|
||||
* NaN will not disappear.
|
||||
SLAPY3 = XABS + YABS + ZABS
|
||||
ELSE
|
||||
SLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+
|
||||
$ ( ZABS / W )**2 )
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of SLAPY3
|
||||
*
|
||||
END
|
||||
227
cs440-acg/ext/eigen/lapack/slarf.f
Normal file
227
cs440-acg/ext/eigen/lapack/slarf.f
Normal file
@@ -0,0 +1,227 @@
|
||||
*> \brief \b SLARF
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download SLARF + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slarf.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slarf.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slarf.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER SIDE
|
||||
* INTEGER INCV, LDC, M, N
|
||||
* REAL TAU
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL C( LDC, * ), V( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLARF applies a real elementary reflector H to a real m by n matrix
|
||||
*> C, from either the left or the right. H is represented in the form
|
||||
*>
|
||||
*> H = I - tau * v * v**T
|
||||
*>
|
||||
*> where tau is a real scalar and v is a real vector.
|
||||
*>
|
||||
*> If tau = 0, then H is taken to be the unit matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> = 'L': form H * C
|
||||
*> = 'R': form C * H
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] V
|
||||
*> \verbatim
|
||||
*> V is REAL array, dimension
|
||||
*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
|
||||
*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
|
||||
*> The vector v in the representation of H. V is not used if
|
||||
*> TAU = 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCV
|
||||
*> \verbatim
|
||||
*> INCV is INTEGER
|
||||
*> The increment between elements of v. INCV <> 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TAU
|
||||
*> \verbatim
|
||||
*> TAU is REAL
|
||||
*> The value tau in the representation of H.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is REAL array, dimension (LDC,N)
|
||||
*> On entry, the m by n matrix C.
|
||||
*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
|
||||
*> or C * H if SIDE = 'R'.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> The leading dimension of the array C. LDC >= max(1,M).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is REAL array, dimension
|
||||
*> (N) if SIDE = 'L'
|
||||
*> or (M) if SIDE = 'R'
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup realOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER SIDE
|
||||
INTEGER INCV, LDC, M, N
|
||||
REAL TAU
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL C( LDC, * ), V( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ONE, ZERO
|
||||
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
LOGICAL APPLYLEFT
|
||||
INTEGER I, LASTV, LASTC
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL SGEMV, SGER
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
INTEGER ILASLR, ILASLC
|
||||
EXTERNAL LSAME, ILASLR, ILASLC
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
APPLYLEFT = LSAME( SIDE, 'L' )
|
||||
LASTV = 0
|
||||
LASTC = 0
|
||||
IF( TAU.NE.ZERO ) THEN
|
||||
! Set up variables for scanning V. LASTV begins pointing to the end
|
||||
! of V.
|
||||
IF( APPLYLEFT ) THEN
|
||||
LASTV = M
|
||||
ELSE
|
||||
LASTV = N
|
||||
END IF
|
||||
IF( INCV.GT.0 ) THEN
|
||||
I = 1 + (LASTV-1) * INCV
|
||||
ELSE
|
||||
I = 1
|
||||
END IF
|
||||
! Look for the last non-zero row in V.
|
||||
DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
|
||||
LASTV = LASTV - 1
|
||||
I = I - INCV
|
||||
END DO
|
||||
IF( APPLYLEFT ) THEN
|
||||
! Scan for the last non-zero column in C(1:lastv,:).
|
||||
LASTC = ILASLC(LASTV, N, C, LDC)
|
||||
ELSE
|
||||
! Scan for the last non-zero row in C(:,1:lastv).
|
||||
LASTC = ILASLR(M, LASTV, C, LDC)
|
||||
END IF
|
||||
END IF
|
||||
! Note that lastc.eq.0 renders the BLAS operations null; no special
|
||||
! case is needed at this level.
|
||||
IF( APPLYLEFT ) THEN
|
||||
*
|
||||
* Form H * C
|
||||
*
|
||||
IF( LASTV.GT.0 ) THEN
|
||||
*
|
||||
* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1)
|
||||
*
|
||||
CALL SGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV,
|
||||
$ ZERO, WORK, 1 )
|
||||
*
|
||||
* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T
|
||||
*
|
||||
CALL SGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form C * H
|
||||
*
|
||||
IF( LASTV.GT.0 ) THEN
|
||||
*
|
||||
* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
|
||||
*
|
||||
CALL SGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
|
||||
$ V, INCV, ZERO, WORK, 1 )
|
||||
*
|
||||
* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T
|
||||
*
|
||||
CALL SGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
|
||||
END IF
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of SLARF
|
||||
*
|
||||
END
|
||||
763
cs440-acg/ext/eigen/lapack/slarfb.f
Normal file
763
cs440-acg/ext/eigen/lapack/slarfb.f
Normal file
@@ -0,0 +1,763 @@
|
||||
*> \brief \b SLARFB
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download SLARFB + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slarfb.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slarfb.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slarfb.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
|
||||
* T, LDT, C, LDC, WORK, LDWORK )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER DIRECT, SIDE, STOREV, TRANS
|
||||
* INTEGER K, LDC, LDT, LDV, LDWORK, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL C( LDC, * ), T( LDT, * ), V( LDV, * ),
|
||||
* $ WORK( LDWORK, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLARFB applies a real block reflector H or its transpose H**T to a
|
||||
*> real m by n matrix C, from either the left or the right.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> = 'L': apply H or H**T from the Left
|
||||
*> = 'R': apply H or H**T from the Right
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> = 'N': apply H (No transpose)
|
||||
*> = 'T': apply H**T (Transpose)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIRECT
|
||||
*> \verbatim
|
||||
*> DIRECT is CHARACTER*1
|
||||
*> Indicates how H is formed from a product of elementary
|
||||
*> reflectors
|
||||
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
|
||||
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] STOREV
|
||||
*> \verbatim
|
||||
*> STOREV is CHARACTER*1
|
||||
*> Indicates how the vectors which define the elementary
|
||||
*> reflectors are stored:
|
||||
*> = 'C': Columnwise
|
||||
*> = 'R': Rowwise
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The order of the matrix T (= the number of elementary
|
||||
*> reflectors whose product defines the block reflector).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] V
|
||||
*> \verbatim
|
||||
*> V is REAL array, dimension
|
||||
*> (LDV,K) if STOREV = 'C'
|
||||
*> (LDV,M) if STOREV = 'R' and SIDE = 'L'
|
||||
*> (LDV,N) if STOREV = 'R' and SIDE = 'R'
|
||||
*> The matrix V. See Further Details.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDV
|
||||
*> \verbatim
|
||||
*> LDV is INTEGER
|
||||
*> The leading dimension of the array V.
|
||||
*> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
|
||||
*> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
|
||||
*> if STOREV = 'R', LDV >= K.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] T
|
||||
*> \verbatim
|
||||
*> T is REAL array, dimension (LDT,K)
|
||||
*> The triangular k by k matrix T in the representation of the
|
||||
*> block reflector.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDT
|
||||
*> \verbatim
|
||||
*> LDT is INTEGER
|
||||
*> The leading dimension of the array T. LDT >= K.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is REAL array, dimension (LDC,N)
|
||||
*> On entry, the m by n matrix C.
|
||||
*> On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> The leading dimension of the array C. LDC >= max(1,M).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is REAL array, dimension (LDWORK,K)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDWORK
|
||||
*> \verbatim
|
||||
*> LDWORK is INTEGER
|
||||
*> The leading dimension of the array WORK.
|
||||
*> If SIDE = 'L', LDWORK >= max(1,N);
|
||||
*> if SIDE = 'R', LDWORK >= max(1,M).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup realOTHERauxiliary
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> The shape of the matrix V and the storage of the vectors which define
|
||||
*> the H(i) is best illustrated by the following example with n = 5 and
|
||||
*> k = 3. The elements equal to 1 are not stored; the corresponding
|
||||
*> array elements are modified but restored on exit. The rest of the
|
||||
*> array is not used.
|
||||
*>
|
||||
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
|
||||
*>
|
||||
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
|
||||
*> ( v1 1 ) ( 1 v2 v2 v2 )
|
||||
*> ( v1 v2 1 ) ( 1 v3 v3 )
|
||||
*> ( v1 v2 v3 )
|
||||
*> ( v1 v2 v3 )
|
||||
*>
|
||||
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
|
||||
*>
|
||||
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
|
||||
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
|
||||
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
|
||||
*> ( 1 v3 )
|
||||
*> ( 1 )
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
|
||||
$ T, LDT, C, LDC, WORK, LDWORK )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER DIRECT, SIDE, STOREV, TRANS
|
||||
INTEGER K, LDC, LDT, LDV, LDWORK, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL C( LDC, * ), T( LDT, * ), V( LDV, * ),
|
||||
$ WORK( LDWORK, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ONE
|
||||
PARAMETER ( ONE = 1.0E+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
CHARACTER TRANST
|
||||
INTEGER I, J, LASTV, LASTC
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
INTEGER ILASLR, ILASLC
|
||||
EXTERNAL LSAME, ILASLR, ILASLC
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL SCOPY, SGEMM, STRMM
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( M.LE.0 .OR. N.LE.0 )
|
||||
$ RETURN
|
||||
*
|
||||
IF( LSAME( TRANS, 'N' ) ) THEN
|
||||
TRANST = 'T'
|
||||
ELSE
|
||||
TRANST = 'N'
|
||||
END IF
|
||||
*
|
||||
IF( LSAME( STOREV, 'C' ) ) THEN
|
||||
*
|
||||
IF( LSAME( DIRECT, 'F' ) ) THEN
|
||||
*
|
||||
* Let V = ( V1 ) (first K rows)
|
||||
* ( V2 )
|
||||
* where V1 is unit lower triangular.
|
||||
*
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
*
|
||||
* Form H * C or H**T * C where C = ( C1 )
|
||||
* ( C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILASLR( M, K, V, LDV ) )
|
||||
LASTC = ILASLC( LASTV, N, C, LDC )
|
||||
*
|
||||
* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
|
||||
*
|
||||
* W := C1**T
|
||||
*
|
||||
DO 10 J = 1, K
|
||||
CALL SCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
|
||||
10 CONTINUE
|
||||
*
|
||||
* W := W * V1
|
||||
*
|
||||
CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C2**T *V2
|
||||
*
|
||||
CALL SGEMM( 'Transpose', 'No transpose',
|
||||
$ LASTC, K, LASTV-K,
|
||||
$ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T**T or W * T
|
||||
*
|
||||
CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - V * W**T
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C2 := C2 - V2 * W**T
|
||||
*
|
||||
CALL SGEMM( 'No transpose', 'Transpose',
|
||||
$ LASTV-K, LASTC, K,
|
||||
$ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
|
||||
$ C( K+1, 1 ), LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V1**T
|
||||
*
|
||||
CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W**T
|
||||
*
|
||||
DO 30 J = 1, K
|
||||
DO 20 I = 1, LASTC
|
||||
C( J, I ) = C( J, I ) - WORK( I, J )
|
||||
20 CONTINUE
|
||||
30 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
*
|
||||
* Form C * H or C * H**T where C = ( C1 C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILASLR( N, K, V, LDV ) )
|
||||
LASTC = ILASLR( M, LASTV, C, LDC )
|
||||
*
|
||||
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
|
||||
*
|
||||
* W := C1
|
||||
*
|
||||
DO 40 J = 1, K
|
||||
CALL SCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
|
||||
40 CONTINUE
|
||||
*
|
||||
* W := W * V1
|
||||
*
|
||||
CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C2 * V2
|
||||
*
|
||||
CALL SGEMM( 'No transpose', 'No transpose',
|
||||
$ LASTC, K, LASTV-K,
|
||||
$ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T or W * T**T
|
||||
*
|
||||
CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - W * V**T
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C2 := C2 - W * V2**T
|
||||
*
|
||||
CALL SGEMM( 'No transpose', 'Transpose',
|
||||
$ LASTC, LASTV-K, K,
|
||||
$ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
|
||||
$ C( 1, K+1 ), LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V1**T
|
||||
*
|
||||
CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W
|
||||
*
|
||||
DO 60 J = 1, K
|
||||
DO 50 I = 1, LASTC
|
||||
C( I, J ) = C( I, J ) - WORK( I, J )
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
END IF
|
||||
*
|
||||
ELSE
|
||||
*
|
||||
* Let V = ( V1 )
|
||||
* ( V2 ) (last K rows)
|
||||
* where V2 is unit upper triangular.
|
||||
*
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
*
|
||||
* Form H * C or H**T * C where C = ( C1 )
|
||||
* ( C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILASLR( M, K, V, LDV ) )
|
||||
LASTC = ILASLC( LASTV, N, C, LDC )
|
||||
*
|
||||
* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
|
||||
*
|
||||
* W := C2**T
|
||||
*
|
||||
DO 70 J = 1, K
|
||||
CALL SCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
|
||||
$ WORK( 1, J ), 1 )
|
||||
70 CONTINUE
|
||||
*
|
||||
* W := W * V2
|
||||
*
|
||||
CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C1**T*V1
|
||||
*
|
||||
CALL SGEMM( 'Transpose', 'No transpose',
|
||||
$ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T**T or W * T
|
||||
*
|
||||
CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - V * W**T
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C1 := C1 - V1 * W**T
|
||||
*
|
||||
CALL SGEMM( 'No transpose', 'Transpose',
|
||||
$ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
|
||||
$ ONE, C, LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V2**T
|
||||
*
|
||||
CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
*
|
||||
* C2 := C2 - W**T
|
||||
*
|
||||
DO 90 J = 1, K
|
||||
DO 80 I = 1, LASTC
|
||||
C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J)
|
||||
80 CONTINUE
|
||||
90 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
*
|
||||
* Form C * H or C * H**T where C = ( C1 C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILASLR( N, K, V, LDV ) )
|
||||
LASTC = ILASLR( M, LASTV, C, LDC )
|
||||
*
|
||||
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
|
||||
*
|
||||
* W := C2
|
||||
*
|
||||
DO 100 J = 1, K
|
||||
CALL SCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
|
||||
100 CONTINUE
|
||||
*
|
||||
* W := W * V2
|
||||
*
|
||||
CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C1 * V1
|
||||
*
|
||||
CALL SGEMM( 'No transpose', 'No transpose',
|
||||
$ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T or W * T**T
|
||||
*
|
||||
CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - W * V**T
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C1 := C1 - W * V1**T
|
||||
*
|
||||
CALL SGEMM( 'No transpose', 'Transpose',
|
||||
$ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
|
||||
$ ONE, C, LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V2**T
|
||||
*
|
||||
CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
*
|
||||
* C2 := C2 - W
|
||||
*
|
||||
DO 120 J = 1, K
|
||||
DO 110 I = 1, LASTC
|
||||
C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J)
|
||||
110 CONTINUE
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
ELSE IF( LSAME( STOREV, 'R' ) ) THEN
|
||||
*
|
||||
IF( LSAME( DIRECT, 'F' ) ) THEN
|
||||
*
|
||||
* Let V = ( V1 V2 ) (V1: first K columns)
|
||||
* where V1 is unit upper triangular.
|
||||
*
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
*
|
||||
* Form H * C or H**T * C where C = ( C1 )
|
||||
* ( C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILASLC( K, M, V, LDV ) )
|
||||
LASTC = ILASLC( LASTV, N, C, LDC )
|
||||
*
|
||||
* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
|
||||
*
|
||||
* W := C1**T
|
||||
*
|
||||
DO 130 J = 1, K
|
||||
CALL SCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
|
||||
130 CONTINUE
|
||||
*
|
||||
* W := W * V1**T
|
||||
*
|
||||
CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C2**T*V2**T
|
||||
*
|
||||
CALL SGEMM( 'Transpose', 'Transpose',
|
||||
$ LASTC, K, LASTV-K,
|
||||
$ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T**T or W * T
|
||||
*
|
||||
CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - V**T * W**T
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C2 := C2 - V2**T * W**T
|
||||
*
|
||||
CALL SGEMM( 'Transpose', 'Transpose',
|
||||
$ LASTV-K, LASTC, K,
|
||||
$ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
|
||||
$ ONE, C( K+1, 1 ), LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V1
|
||||
*
|
||||
CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W**T
|
||||
*
|
||||
DO 150 J = 1, K
|
||||
DO 140 I = 1, LASTC
|
||||
C( J, I ) = C( J, I ) - WORK( I, J )
|
||||
140 CONTINUE
|
||||
150 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
*
|
||||
* Form C * H or C * H**T where C = ( C1 C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILASLC( K, N, V, LDV ) )
|
||||
LASTC = ILASLR( M, LASTV, C, LDC )
|
||||
*
|
||||
* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
|
||||
*
|
||||
* W := C1
|
||||
*
|
||||
DO 160 J = 1, K
|
||||
CALL SCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
|
||||
160 CONTINUE
|
||||
*
|
||||
* W := W * V1**T
|
||||
*
|
||||
CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C2 * V2**T
|
||||
*
|
||||
CALL SGEMM( 'No transpose', 'Transpose',
|
||||
$ LASTC, K, LASTV-K,
|
||||
$ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T or W * T**T
|
||||
*
|
||||
CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - W * V
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C2 := C2 - W * V2
|
||||
*
|
||||
CALL SGEMM( 'No transpose', 'No transpose',
|
||||
$ LASTC, LASTV-K, K,
|
||||
$ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
|
||||
$ ONE, C( 1, K+1 ), LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V1
|
||||
*
|
||||
CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W
|
||||
*
|
||||
DO 180 J = 1, K
|
||||
DO 170 I = 1, LASTC
|
||||
C( I, J ) = C( I, J ) - WORK( I, J )
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
*
|
||||
END IF
|
||||
*
|
||||
ELSE
|
||||
*
|
||||
* Let V = ( V1 V2 ) (V2: last K columns)
|
||||
* where V2 is unit lower triangular.
|
||||
*
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
*
|
||||
* Form H * C or H**T * C where C = ( C1 )
|
||||
* ( C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILASLC( K, M, V, LDV ) )
|
||||
LASTC = ILASLC( LASTV, N, C, LDC )
|
||||
*
|
||||
* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
|
||||
*
|
||||
* W := C2**T
|
||||
*
|
||||
DO 190 J = 1, K
|
||||
CALL SCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
|
||||
$ WORK( 1, J ), 1 )
|
||||
190 CONTINUE
|
||||
*
|
||||
* W := W * V2**T
|
||||
*
|
||||
CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C1**T * V1**T
|
||||
*
|
||||
CALL SGEMM( 'Transpose', 'Transpose',
|
||||
$ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T**T or W * T
|
||||
*
|
||||
CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - V**T * W**T
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C1 := C1 - V1**T * W**T
|
||||
*
|
||||
CALL SGEMM( 'Transpose', 'Transpose',
|
||||
$ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
|
||||
$ ONE, C, LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V2
|
||||
*
|
||||
CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
*
|
||||
* C2 := C2 - W**T
|
||||
*
|
||||
DO 210 J = 1, K
|
||||
DO 200 I = 1, LASTC
|
||||
C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J)
|
||||
200 CONTINUE
|
||||
210 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
*
|
||||
* Form C * H or C * H**T where C = ( C1 C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILASLC( K, N, V, LDV ) )
|
||||
LASTC = ILASLR( M, LASTV, C, LDC )
|
||||
*
|
||||
* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
|
||||
*
|
||||
* W := C2
|
||||
*
|
||||
DO 220 J = 1, K
|
||||
CALL SCOPY( LASTC, C( 1, LASTV-K+J ), 1,
|
||||
$ WORK( 1, J ), 1 )
|
||||
220 CONTINUE
|
||||
*
|
||||
* W := W * V2**T
|
||||
*
|
||||
CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C1 * V1**T
|
||||
*
|
||||
CALL SGEMM( 'No transpose', 'Transpose',
|
||||
$ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T or W * T**T
|
||||
*
|
||||
CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - W * V
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C1 := C1 - W * V1
|
||||
*
|
||||
CALL SGEMM( 'No transpose', 'No transpose',
|
||||
$ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
|
||||
$ ONE, C, LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V2
|
||||
*
|
||||
CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W
|
||||
*
|
||||
DO 240 J = 1, K
|
||||
DO 230 I = 1, LASTC
|
||||
C( I, LASTV-K+J ) = C( I, LASTV-K+J )
|
||||
$ - WORK( I, J )
|
||||
230 CONTINUE
|
||||
240 CONTINUE
|
||||
*
|
||||
END IF
|
||||
*
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of SLARFB
|
||||
*
|
||||
END
|
||||
196
cs440-acg/ext/eigen/lapack/slarfg.f
Normal file
196
cs440-acg/ext/eigen/lapack/slarfg.f
Normal file
@@ -0,0 +1,196 @@
|
||||
*> \brief \b SLARFG
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download SLARFG + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slarfg.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slarfg.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slarfg.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SLARFG( N, ALPHA, X, INCX, TAU )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX, N
|
||||
* REAL ALPHA, TAU
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL X( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLARFG generates a real elementary reflector H of order n, such
|
||||
*> that
|
||||
*>
|
||||
*> H * ( alpha ) = ( beta ), H**T * H = I.
|
||||
*> ( x ) ( 0 )
|
||||
*>
|
||||
*> where alpha and beta are scalars, and x is an (n-1)-element real
|
||||
*> vector. H is represented in the form
|
||||
*>
|
||||
*> H = I - tau * ( 1 ) * ( 1 v**T ) ,
|
||||
*> ( v )
|
||||
*>
|
||||
*> where tau is a real scalar and v is a real (n-1)-element
|
||||
*> vector.
|
||||
*>
|
||||
*> If the elements of x are all zero, then tau = 0 and H is taken to be
|
||||
*> the unit matrix.
|
||||
*>
|
||||
*> Otherwise 1 <= tau <= 2.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the elementary reflector.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is REAL
|
||||
*> On entry, the value alpha.
|
||||
*> On exit, it is overwritten with the value beta.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] X
|
||||
*> \verbatim
|
||||
*> X is REAL array, dimension
|
||||
*> (1+(N-2)*abs(INCX))
|
||||
*> On entry, the vector x.
|
||||
*> On exit, it is overwritten with the vector v.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> The increment between elements of X. INCX > 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] TAU
|
||||
*> \verbatim
|
||||
*> TAU is REAL
|
||||
*> The value tau.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup realOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE SLARFG( N, ALPHA, X, INCX, TAU )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX, N
|
||||
REAL ALPHA, TAU
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL X( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ONE, ZERO
|
||||
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER J, KNT
|
||||
REAL BETA, RSAFMN, SAFMIN, XNORM
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
REAL SLAMCH, SLAPY2, SNRM2
|
||||
EXTERNAL SLAMCH, SLAPY2, SNRM2
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, SIGN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL SSCAL
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( N.LE.1 ) THEN
|
||||
TAU = ZERO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
XNORM = SNRM2( N-1, X, INCX )
|
||||
*
|
||||
IF( XNORM.EQ.ZERO ) THEN
|
||||
*
|
||||
* H = I
|
||||
*
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
*
|
||||
* general case
|
||||
*
|
||||
BETA = -SIGN( SLAPY2( ALPHA, XNORM ), ALPHA )
|
||||
SAFMIN = SLAMCH( 'S' ) / SLAMCH( 'E' )
|
||||
KNT = 0
|
||||
IF( ABS( BETA ).LT.SAFMIN ) THEN
|
||||
*
|
||||
* XNORM, BETA may be inaccurate; scale X and recompute them
|
||||
*
|
||||
RSAFMN = ONE / SAFMIN
|
||||
10 CONTINUE
|
||||
KNT = KNT + 1
|
||||
CALL SSCAL( N-1, RSAFMN, X, INCX )
|
||||
BETA = BETA*RSAFMN
|
||||
ALPHA = ALPHA*RSAFMN
|
||||
IF( ABS( BETA ).LT.SAFMIN )
|
||||
$ GO TO 10
|
||||
*
|
||||
* New BETA is at most 1, at least SAFMIN
|
||||
*
|
||||
XNORM = SNRM2( N-1, X, INCX )
|
||||
BETA = -SIGN( SLAPY2( ALPHA, XNORM ), ALPHA )
|
||||
END IF
|
||||
TAU = ( BETA-ALPHA ) / BETA
|
||||
CALL SSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
|
||||
*
|
||||
* If ALPHA is subnormal, it may lose relative accuracy
|
||||
*
|
||||
DO 20 J = 1, KNT
|
||||
BETA = BETA*SAFMIN
|
||||
20 CONTINUE
|
||||
ALPHA = BETA
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of SLARFG
|
||||
*
|
||||
END
|
||||
326
cs440-acg/ext/eigen/lapack/slarft.f
Normal file
326
cs440-acg/ext/eigen/lapack/slarft.f
Normal file
@@ -0,0 +1,326 @@
|
||||
*> \brief \b SLARFT
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download SLARFT + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slarft.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slarft.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slarft.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER DIRECT, STOREV
|
||||
* INTEGER K, LDT, LDV, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* REAL T( LDT, * ), TAU( * ), V( LDV, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLARFT forms the triangular factor T of a real block reflector H
|
||||
*> of order n, which is defined as a product of k elementary reflectors.
|
||||
*>
|
||||
*> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
|
||||
*>
|
||||
*> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
|
||||
*>
|
||||
*> If STOREV = 'C', the vector which defines the elementary reflector
|
||||
*> H(i) is stored in the i-th column of the array V, and
|
||||
*>
|
||||
*> H = I - V * T * V**T
|
||||
*>
|
||||
*> If STOREV = 'R', the vector which defines the elementary reflector
|
||||
*> H(i) is stored in the i-th row of the array V, and
|
||||
*>
|
||||
*> H = I - V**T * T * V
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] DIRECT
|
||||
*> \verbatim
|
||||
*> DIRECT is CHARACTER*1
|
||||
*> Specifies the order in which the elementary reflectors are
|
||||
*> multiplied to form the block reflector:
|
||||
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
|
||||
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] STOREV
|
||||
*> \verbatim
|
||||
*> STOREV is CHARACTER*1
|
||||
*> Specifies how the vectors which define the elementary
|
||||
*> reflectors are stored (see also Further Details):
|
||||
*> = 'C': columnwise
|
||||
*> = 'R': rowwise
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the block reflector H. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The order of the triangular factor T (= the number of
|
||||
*> elementary reflectors). K >= 1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] V
|
||||
*> \verbatim
|
||||
*> V is REAL array, dimension
|
||||
*> (LDV,K) if STOREV = 'C'
|
||||
*> (LDV,N) if STOREV = 'R'
|
||||
*> The matrix V. See further details.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDV
|
||||
*> \verbatim
|
||||
*> LDV is INTEGER
|
||||
*> The leading dimension of the array V.
|
||||
*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TAU
|
||||
*> \verbatim
|
||||
*> TAU is REAL array, dimension (K)
|
||||
*> TAU(i) must contain the scalar factor of the elementary
|
||||
*> reflector H(i).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] T
|
||||
*> \verbatim
|
||||
*> T is REAL array, dimension (LDT,K)
|
||||
*> The k by k triangular factor T of the block reflector.
|
||||
*> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
|
||||
*> lower triangular. The rest of the array is not used.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDT
|
||||
*> \verbatim
|
||||
*> LDT is INTEGER
|
||||
*> The leading dimension of the array T. LDT >= K.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date April 2012
|
||||
*
|
||||
*> \ingroup realOTHERauxiliary
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> The shape of the matrix V and the storage of the vectors which define
|
||||
*> the H(i) is best illustrated by the following example with n = 5 and
|
||||
*> k = 3. The elements equal to 1 are not stored.
|
||||
*>
|
||||
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
|
||||
*>
|
||||
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
|
||||
*> ( v1 1 ) ( 1 v2 v2 v2 )
|
||||
*> ( v1 v2 1 ) ( 1 v3 v3 )
|
||||
*> ( v1 v2 v3 )
|
||||
*> ( v1 v2 v3 )
|
||||
*>
|
||||
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
|
||||
*>
|
||||
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
|
||||
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
|
||||
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
|
||||
*> ( 1 v3 )
|
||||
*> ( 1 )
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.1) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* April 2012
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER DIRECT, STOREV
|
||||
INTEGER K, LDT, LDV, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL T( LDT, * ), TAU( * ), V( LDV, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
REAL ONE, ZERO
|
||||
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J, PREVLASTV, LASTV
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL SGEMV, STRMV
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
IF( LSAME( DIRECT, 'F' ) ) THEN
|
||||
PREVLASTV = N
|
||||
DO I = 1, K
|
||||
PREVLASTV = MAX( I, PREVLASTV )
|
||||
IF( TAU( I ).EQ.ZERO ) THEN
|
||||
*
|
||||
* H(i) = I
|
||||
*
|
||||
DO J = 1, I
|
||||
T( J, I ) = ZERO
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* general case
|
||||
*
|
||||
IF( LSAME( STOREV, 'C' ) ) THEN
|
||||
* Skip any trailing zeros.
|
||||
DO LASTV = N, I+1, -1
|
||||
IF( V( LASTV, I ).NE.ZERO ) EXIT
|
||||
END DO
|
||||
DO J = 1, I-1
|
||||
T( J, I ) = -TAU( I ) * V( I , J )
|
||||
END DO
|
||||
J = MIN( LASTV, PREVLASTV )
|
||||
*
|
||||
* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i)
|
||||
*
|
||||
CALL SGEMV( 'Transpose', J-I, I-1, -TAU( I ),
|
||||
$ V( I+1, 1 ), LDV, V( I+1, I ), 1, ONE,
|
||||
$ T( 1, I ), 1 )
|
||||
ELSE
|
||||
* Skip any trailing zeros.
|
||||
DO LASTV = N, I+1, -1
|
||||
IF( V( I, LASTV ).NE.ZERO ) EXIT
|
||||
END DO
|
||||
DO J = 1, I-1
|
||||
T( J, I ) = -TAU( I ) * V( J , I )
|
||||
END DO
|
||||
J = MIN( LASTV, PREVLASTV )
|
||||
*
|
||||
* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T
|
||||
*
|
||||
CALL SGEMV( 'No transpose', I-1, J-I, -TAU( I ),
|
||||
$ V( 1, I+1 ), LDV, V( I, I+1 ), LDV,
|
||||
$ ONE, T( 1, I ), 1 )
|
||||
END IF
|
||||
*
|
||||
* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
|
||||
*
|
||||
CALL STRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
|
||||
$ LDT, T( 1, I ), 1 )
|
||||
T( I, I ) = TAU( I )
|
||||
IF( I.GT.1 ) THEN
|
||||
PREVLASTV = MAX( PREVLASTV, LASTV )
|
||||
ELSE
|
||||
PREVLASTV = LASTV
|
||||
END IF
|
||||
END IF
|
||||
END DO
|
||||
ELSE
|
||||
PREVLASTV = 1
|
||||
DO I = K, 1, -1
|
||||
IF( TAU( I ).EQ.ZERO ) THEN
|
||||
*
|
||||
* H(i) = I
|
||||
*
|
||||
DO J = I, K
|
||||
T( J, I ) = ZERO
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* general case
|
||||
*
|
||||
IF( I.LT.K ) THEN
|
||||
IF( LSAME( STOREV, 'C' ) ) THEN
|
||||
* Skip any leading zeros.
|
||||
DO LASTV = 1, I-1
|
||||
IF( V( LASTV, I ).NE.ZERO ) EXIT
|
||||
END DO
|
||||
DO J = I+1, K
|
||||
T( J, I ) = -TAU( I ) * V( N-K+I , J )
|
||||
END DO
|
||||
J = MAX( LASTV, PREVLASTV )
|
||||
*
|
||||
* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i)
|
||||
*
|
||||
CALL SGEMV( 'Transpose', N-K+I-J, K-I, -TAU( I ),
|
||||
$ V( J, I+1 ), LDV, V( J, I ), 1, ONE,
|
||||
$ T( I+1, I ), 1 )
|
||||
ELSE
|
||||
* Skip any leading zeros.
|
||||
DO LASTV = 1, I-1
|
||||
IF( V( I, LASTV ).NE.ZERO ) EXIT
|
||||
END DO
|
||||
DO J = I+1, K
|
||||
T( J, I ) = -TAU( I ) * V( J, N-K+I )
|
||||
END DO
|
||||
J = MAX( LASTV, PREVLASTV )
|
||||
*
|
||||
* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T
|
||||
*
|
||||
CALL SGEMV( 'No transpose', K-I, N-K+I-J,
|
||||
$ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV,
|
||||
$ ONE, T( I+1, I ), 1 )
|
||||
END IF
|
||||
*
|
||||
* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
|
||||
*
|
||||
CALL STRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
|
||||
$ T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
|
||||
IF( I.GT.1 ) THEN
|
||||
PREVLASTV = MIN( PREVLASTV, LASTV )
|
||||
ELSE
|
||||
PREVLASTV = LASTV
|
||||
END IF
|
||||
END IF
|
||||
T( I, I ) = TAU( I )
|
||||
END IF
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of SLARFT
|
||||
*
|
||||
END
|
||||
138
cs440-acg/ext/eigen/lapack/svd.cpp
Normal file
138
cs440-acg/ext/eigen/lapack/svd.cpp
Normal file
@@ -0,0 +1,138 @@
|
||||
// This file is part of Eigen, a lightweight C++ template library
|
||||
// for linear algebra.
|
||||
//
|
||||
// Copyright (C) 2014 Gael Guennebaud <gael.guennebaud@inria.fr>
|
||||
//
|
||||
// This Source Code Form is subject to the terms of the Mozilla
|
||||
// Public License v. 2.0. If a copy of the MPL was not distributed
|
||||
// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
#include "lapack_common.h"
|
||||
#include <Eigen/SVD>
|
||||
|
||||
// computes the singular values/vectors a general M-by-N matrix A using divide-and-conquer
|
||||
EIGEN_LAPACK_FUNC(gesdd,(char *jobz, int *m, int* n, Scalar* a, int *lda, RealScalar *s, Scalar *u, int *ldu, Scalar *vt, int *ldvt, Scalar* /*work*/, int* lwork,
|
||||
EIGEN_LAPACK_ARG_IF_COMPLEX(RealScalar */*rwork*/) int * /*iwork*/, int *info))
|
||||
{
|
||||
// TODO exploit the work buffer
|
||||
bool query_size = *lwork==-1;
|
||||
int diag_size = (std::min)(*m,*n);
|
||||
|
||||
*info = 0;
|
||||
if(*jobz!='A' && *jobz!='S' && *jobz!='O' && *jobz!='N') *info = -1;
|
||||
else if(*m<0) *info = -2;
|
||||
else if(*n<0) *info = -3;
|
||||
else if(*lda<std::max(1,*m)) *info = -5;
|
||||
else if(*lda<std::max(1,*m)) *info = -8;
|
||||
else if(*ldu <1 || (*jobz=='A' && *ldu <*m)
|
||||
|| (*jobz=='O' && *m<*n && *ldu<*m)) *info = -8;
|
||||
else if(*ldvt<1 || (*jobz=='A' && *ldvt<*n)
|
||||
|| (*jobz=='S' && *ldvt<diag_size)
|
||||
|| (*jobz=='O' && *m>=*n && *ldvt<*n)) *info = -10;
|
||||
|
||||
if(*info!=0)
|
||||
{
|
||||
int e = -*info;
|
||||
return xerbla_(SCALAR_SUFFIX_UP"GESDD ", &e, 6);
|
||||
}
|
||||
|
||||
if(query_size)
|
||||
{
|
||||
*lwork = 0;
|
||||
return 0;
|
||||
}
|
||||
|
||||
if(*n==0 || *m==0)
|
||||
return 0;
|
||||
|
||||
PlainMatrixType mat(*m,*n);
|
||||
mat = matrix(a,*m,*n,*lda);
|
||||
|
||||
int option = *jobz=='A' ? ComputeFullU|ComputeFullV
|
||||
: *jobz=='S' ? ComputeThinU|ComputeThinV
|
||||
: *jobz=='O' ? ComputeThinU|ComputeThinV
|
||||
: 0;
|
||||
|
||||
BDCSVD<PlainMatrixType> svd(mat,option);
|
||||
|
||||
make_vector(s,diag_size) = svd.singularValues().head(diag_size);
|
||||
|
||||
if(*jobz=='A')
|
||||
{
|
||||
matrix(u,*m,*m,*ldu) = svd.matrixU();
|
||||
matrix(vt,*n,*n,*ldvt) = svd.matrixV().adjoint();
|
||||
}
|
||||
else if(*jobz=='S')
|
||||
{
|
||||
matrix(u,*m,diag_size,*ldu) = svd.matrixU();
|
||||
matrix(vt,diag_size,*n,*ldvt) = svd.matrixV().adjoint();
|
||||
}
|
||||
else if(*jobz=='O' && *m>=*n)
|
||||
{
|
||||
matrix(a,*m,*n,*lda) = svd.matrixU();
|
||||
matrix(vt,*n,*n,*ldvt) = svd.matrixV().adjoint();
|
||||
}
|
||||
else if(*jobz=='O')
|
||||
{
|
||||
matrix(u,*m,*m,*ldu) = svd.matrixU();
|
||||
matrix(a,diag_size,*n,*lda) = svd.matrixV().adjoint();
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
// computes the singular values/vectors a general M-by-N matrix A using two sided jacobi algorithm
|
||||
EIGEN_LAPACK_FUNC(gesvd,(char *jobu, char *jobv, int *m, int* n, Scalar* a, int *lda, RealScalar *s, Scalar *u, int *ldu, Scalar *vt, int *ldvt, Scalar* /*work*/, int* lwork,
|
||||
EIGEN_LAPACK_ARG_IF_COMPLEX(RealScalar */*rwork*/) int *info))
|
||||
{
|
||||
// TODO exploit the work buffer
|
||||
bool query_size = *lwork==-1;
|
||||
int diag_size = (std::min)(*m,*n);
|
||||
|
||||
*info = 0;
|
||||
if( *jobu!='A' && *jobu!='S' && *jobu!='O' && *jobu!='N') *info = -1;
|
||||
else if((*jobv!='A' && *jobv!='S' && *jobv!='O' && *jobv!='N')
|
||||
|| (*jobu=='O' && *jobv=='O')) *info = -2;
|
||||
else if(*m<0) *info = -3;
|
||||
else if(*n<0) *info = -4;
|
||||
else if(*lda<std::max(1,*m)) *info = -6;
|
||||
else if(*ldu <1 || ((*jobu=='A' || *jobu=='S') && *ldu<*m)) *info = -9;
|
||||
else if(*ldvt<1 || (*jobv=='A' && *ldvt<*n)
|
||||
|| (*jobv=='S' && *ldvt<diag_size)) *info = -11;
|
||||
|
||||
if(*info!=0)
|
||||
{
|
||||
int e = -*info;
|
||||
return xerbla_(SCALAR_SUFFIX_UP"GESVD ", &e, 6);
|
||||
}
|
||||
|
||||
if(query_size)
|
||||
{
|
||||
*lwork = 0;
|
||||
return 0;
|
||||
}
|
||||
|
||||
if(*n==0 || *m==0)
|
||||
return 0;
|
||||
|
||||
PlainMatrixType mat(*m,*n);
|
||||
mat = matrix(a,*m,*n,*lda);
|
||||
|
||||
int option = (*jobu=='A' ? ComputeFullU : *jobu=='S' || *jobu=='O' ? ComputeThinU : 0)
|
||||
| (*jobv=='A' ? ComputeFullV : *jobv=='S' || *jobv=='O' ? ComputeThinV : 0);
|
||||
|
||||
JacobiSVD<PlainMatrixType> svd(mat,option);
|
||||
|
||||
make_vector(s,diag_size) = svd.singularValues().head(diag_size);
|
||||
{
|
||||
if(*jobu=='A') matrix(u,*m,*m,*ldu) = svd.matrixU();
|
||||
else if(*jobu=='S') matrix(u,*m,diag_size,*ldu) = svd.matrixU();
|
||||
else if(*jobu=='O') matrix(a,*m,diag_size,*lda) = svd.matrixU();
|
||||
}
|
||||
{
|
||||
if(*jobv=='A') matrix(vt,*n,*n,*ldvt) = svd.matrixV().adjoint();
|
||||
else if(*jobv=='S') matrix(vt,diag_size,*n,*ldvt) = svd.matrixV().adjoint();
|
||||
else if(*jobv=='O') matrix(a,diag_size,*n,*lda) = svd.matrixV().adjoint();
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
116
cs440-acg/ext/eigen/lapack/zlacgv.f
Normal file
116
cs440-acg/ext/eigen/lapack/zlacgv.f
Normal file
@@ -0,0 +1,116 @@
|
||||
*> \brief \b ZLACGV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZLACGV + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlacgv.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlacgv.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlacgv.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLACGV( N, X, INCX )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 X( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLACGV conjugates a complex vector of length N.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The length of the vector X. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX*16 array, dimension
|
||||
*> (1+(N-1)*abs(INCX))
|
||||
*> On entry, the vector of length N to be conjugated.
|
||||
*> On exit, X is overwritten with conjg(X).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> The spacing between successive elements of X.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16OTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLACGV( N, X, INCX )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 X( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, IOFF
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DCONJG
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( INCX.EQ.1 ) THEN
|
||||
DO 10 I = 1, N
|
||||
X( I ) = DCONJG( X( I ) )
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
IOFF = 1
|
||||
IF( INCX.LT.0 )
|
||||
$ IOFF = 1 - ( N-1 )*INCX
|
||||
DO 20 I = 1, N
|
||||
X( IOFF ) = DCONJG( X( IOFF ) )
|
||||
IOFF = IOFF + INCX
|
||||
20 CONTINUE
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of ZLACGV
|
||||
*
|
||||
END
|
||||
97
cs440-acg/ext/eigen/lapack/zladiv.f
Normal file
97
cs440-acg/ext/eigen/lapack/zladiv.f
Normal file
@@ -0,0 +1,97 @@
|
||||
*> \brief \b ZLADIV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZLADIV + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zladiv.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zladiv.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zladiv.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* COMPLEX*16 FUNCTION ZLADIV( X, Y )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX*16 X, Y
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLADIV := X / Y, where X and Y are complex. The computation of X / Y
|
||||
*> will not overflow on an intermediary step unless the results
|
||||
*> overflows.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX*16
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] Y
|
||||
*> \verbatim
|
||||
*> Y is COMPLEX*16
|
||||
*> The complex scalars X and Y.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16OTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
COMPLEX*16 FUNCTION ZLADIV( X, Y )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX*16 X, Y
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION ZI, ZR
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DLADIV
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DBLE, DCMPLX, DIMAG
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR,
|
||||
$ ZI )
|
||||
ZLADIV = DCMPLX( ZR, ZI )
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZLADIV
|
||||
*
|
||||
END
|
||||
232
cs440-acg/ext/eigen/lapack/zlarf.f
Normal file
232
cs440-acg/ext/eigen/lapack/zlarf.f
Normal file
@@ -0,0 +1,232 @@
|
||||
*> \brief \b ZLARF
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZLARF + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarf.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarf.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarf.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER SIDE
|
||||
* INTEGER INCV, LDC, M, N
|
||||
* COMPLEX*16 TAU
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLARF applies a complex elementary reflector H to a complex M-by-N
|
||||
*> matrix C, from either the left or the right. H is represented in the
|
||||
*> form
|
||||
*>
|
||||
*> H = I - tau * v * v**H
|
||||
*>
|
||||
*> where tau is a complex scalar and v is a complex vector.
|
||||
*>
|
||||
*> If tau = 0, then H is taken to be the unit matrix.
|
||||
*>
|
||||
*> To apply H**H, supply conjg(tau) instead
|
||||
*> tau.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> = 'L': form H * C
|
||||
*> = 'R': form C * H
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] V
|
||||
*> \verbatim
|
||||
*> V is COMPLEX*16 array, dimension
|
||||
*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
|
||||
*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
|
||||
*> The vector v in the representation of H. V is not used if
|
||||
*> TAU = 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCV
|
||||
*> \verbatim
|
||||
*> INCV is INTEGER
|
||||
*> The increment between elements of v. INCV <> 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TAU
|
||||
*> \verbatim
|
||||
*> TAU is COMPLEX*16
|
||||
*> The value tau in the representation of H.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is COMPLEX*16 array, dimension (LDC,N)
|
||||
*> On entry, the M-by-N matrix C.
|
||||
*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
|
||||
*> or C * H if SIDE = 'R'.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> The leading dimension of the array C. LDC >= max(1,M).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX*16 array, dimension
|
||||
*> (N) if SIDE = 'L'
|
||||
*> or (M) if SIDE = 'R'
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16OTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER SIDE
|
||||
INTEGER INCV, LDC, M, N
|
||||
COMPLEX*16 TAU
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ONE, ZERO
|
||||
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
|
||||
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
LOGICAL APPLYLEFT
|
||||
INTEGER I, LASTV, LASTC
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL ZGEMV, ZGERC
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
INTEGER ILAZLR, ILAZLC
|
||||
EXTERNAL LSAME, ILAZLR, ILAZLC
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
APPLYLEFT = LSAME( SIDE, 'L' )
|
||||
LASTV = 0
|
||||
LASTC = 0
|
||||
IF( TAU.NE.ZERO ) THEN
|
||||
* Set up variables for scanning V. LASTV begins pointing to the end
|
||||
* of V.
|
||||
IF( APPLYLEFT ) THEN
|
||||
LASTV = M
|
||||
ELSE
|
||||
LASTV = N
|
||||
END IF
|
||||
IF( INCV.GT.0 ) THEN
|
||||
I = 1 + (LASTV-1) * INCV
|
||||
ELSE
|
||||
I = 1
|
||||
END IF
|
||||
* Look for the last non-zero row in V.
|
||||
DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
|
||||
LASTV = LASTV - 1
|
||||
I = I - INCV
|
||||
END DO
|
||||
IF( APPLYLEFT ) THEN
|
||||
* Scan for the last non-zero column in C(1:lastv,:).
|
||||
LASTC = ILAZLC(LASTV, N, C, LDC)
|
||||
ELSE
|
||||
* Scan for the last non-zero row in C(:,1:lastv).
|
||||
LASTC = ILAZLR(M, LASTV, C, LDC)
|
||||
END IF
|
||||
END IF
|
||||
* Note that lastc.eq.0 renders the BLAS operations null; no special
|
||||
* case is needed at this level.
|
||||
IF( APPLYLEFT ) THEN
|
||||
*
|
||||
* Form H * C
|
||||
*
|
||||
IF( LASTV.GT.0 ) THEN
|
||||
*
|
||||
* w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1)
|
||||
*
|
||||
CALL ZGEMV( 'Conjugate transpose', LASTV, LASTC, ONE,
|
||||
$ C, LDC, V, INCV, ZERO, WORK, 1 )
|
||||
*
|
||||
* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**H
|
||||
*
|
||||
CALL ZGERC( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form C * H
|
||||
*
|
||||
IF( LASTV.GT.0 ) THEN
|
||||
*
|
||||
* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
|
||||
*
|
||||
CALL ZGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
|
||||
$ V, INCV, ZERO, WORK, 1 )
|
||||
*
|
||||
* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**H
|
||||
*
|
||||
CALL ZGERC( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
|
||||
END IF
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of ZLARF
|
||||
*
|
||||
END
|
||||
774
cs440-acg/ext/eigen/lapack/zlarfb.f
Normal file
774
cs440-acg/ext/eigen/lapack/zlarfb.f
Normal file
@@ -0,0 +1,774 @@
|
||||
*> \brief \b ZLARFB
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZLARFB + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarfb.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarfb.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarfb.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
|
||||
* T, LDT, C, LDC, WORK, LDWORK )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER DIRECT, SIDE, STOREV, TRANS
|
||||
* INTEGER K, LDC, LDT, LDV, LDWORK, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ),
|
||||
* $ WORK( LDWORK, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLARFB applies a complex block reflector H or its transpose H**H to a
|
||||
*> complex M-by-N matrix C, from either the left or the right.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> = 'L': apply H or H**H from the Left
|
||||
*> = 'R': apply H or H**H from the Right
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> = 'N': apply H (No transpose)
|
||||
*> = 'C': apply H**H (Conjugate transpose)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIRECT
|
||||
*> \verbatim
|
||||
*> DIRECT is CHARACTER*1
|
||||
*> Indicates how H is formed from a product of elementary
|
||||
*> reflectors
|
||||
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
|
||||
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] STOREV
|
||||
*> \verbatim
|
||||
*> STOREV is CHARACTER*1
|
||||
*> Indicates how the vectors which define the elementary
|
||||
*> reflectors are stored:
|
||||
*> = 'C': Columnwise
|
||||
*> = 'R': Rowwise
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The order of the matrix T (= the number of elementary
|
||||
*> reflectors whose product defines the block reflector).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] V
|
||||
*> \verbatim
|
||||
*> V is COMPLEX*16 array, dimension
|
||||
*> (LDV,K) if STOREV = 'C'
|
||||
*> (LDV,M) if STOREV = 'R' and SIDE = 'L'
|
||||
*> (LDV,N) if STOREV = 'R' and SIDE = 'R'
|
||||
*> See Further Details.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDV
|
||||
*> \verbatim
|
||||
*> LDV is INTEGER
|
||||
*> The leading dimension of the array V.
|
||||
*> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
|
||||
*> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
|
||||
*> if STOREV = 'R', LDV >= K.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] T
|
||||
*> \verbatim
|
||||
*> T is COMPLEX*16 array, dimension (LDT,K)
|
||||
*> The triangular K-by-K matrix T in the representation of the
|
||||
*> block reflector.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDT
|
||||
*> \verbatim
|
||||
*> LDT is INTEGER
|
||||
*> The leading dimension of the array T. LDT >= K.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is COMPLEX*16 array, dimension (LDC,N)
|
||||
*> On entry, the M-by-N matrix C.
|
||||
*> On exit, C is overwritten by H*C or H**H*C or C*H or C*H**H.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> The leading dimension of the array C. LDC >= max(1,M).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX*16 array, dimension (LDWORK,K)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDWORK
|
||||
*> \verbatim
|
||||
*> LDWORK is INTEGER
|
||||
*> The leading dimension of the array WORK.
|
||||
*> If SIDE = 'L', LDWORK >= max(1,N);
|
||||
*> if SIDE = 'R', LDWORK >= max(1,M).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16OTHERauxiliary
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> The shape of the matrix V and the storage of the vectors which define
|
||||
*> the H(i) is best illustrated by the following example with n = 5 and
|
||||
*> k = 3. The elements equal to 1 are not stored; the corresponding
|
||||
*> array elements are modified but restored on exit. The rest of the
|
||||
*> array is not used.
|
||||
*>
|
||||
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
|
||||
*>
|
||||
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
|
||||
*> ( v1 1 ) ( 1 v2 v2 v2 )
|
||||
*> ( v1 v2 1 ) ( 1 v3 v3 )
|
||||
*> ( v1 v2 v3 )
|
||||
*> ( v1 v2 v3 )
|
||||
*>
|
||||
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
|
||||
*>
|
||||
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
|
||||
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
|
||||
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
|
||||
*> ( 1 v3 )
|
||||
*> ( 1 )
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
|
||||
$ T, LDT, C, LDC, WORK, LDWORK )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER DIRECT, SIDE, STOREV, TRANS
|
||||
INTEGER K, LDC, LDT, LDV, LDWORK, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ),
|
||||
$ WORK( LDWORK, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ONE
|
||||
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
CHARACTER TRANST
|
||||
INTEGER I, J, LASTV, LASTC
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
INTEGER ILAZLR, ILAZLC
|
||||
EXTERNAL LSAME, ILAZLR, ILAZLC
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DCONJG
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( M.LE.0 .OR. N.LE.0 )
|
||||
$ RETURN
|
||||
*
|
||||
IF( LSAME( TRANS, 'N' ) ) THEN
|
||||
TRANST = 'C'
|
||||
ELSE
|
||||
TRANST = 'N'
|
||||
END IF
|
||||
*
|
||||
IF( LSAME( STOREV, 'C' ) ) THEN
|
||||
*
|
||||
IF( LSAME( DIRECT, 'F' ) ) THEN
|
||||
*
|
||||
* Let V = ( V1 ) (first K rows)
|
||||
* ( V2 )
|
||||
* where V1 is unit lower triangular.
|
||||
*
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
*
|
||||
* Form H * C or H**H * C where C = ( C1 )
|
||||
* ( C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILAZLR( M, K, V, LDV ) )
|
||||
LASTC = ILAZLC( LASTV, N, C, LDC )
|
||||
*
|
||||
* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK)
|
||||
*
|
||||
* W := C1**H
|
||||
*
|
||||
DO 10 J = 1, K
|
||||
CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
|
||||
CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
|
||||
10 CONTINUE
|
||||
*
|
||||
* W := W * V1
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C2**H *V2
|
||||
*
|
||||
CALL ZGEMM( 'Conjugate transpose', 'No transpose',
|
||||
$ LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC,
|
||||
$ V( K+1, 1 ), LDV, ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T**H or W * T
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - V * W**H
|
||||
*
|
||||
IF( M.GT.K ) THEN
|
||||
*
|
||||
* C2 := C2 - V2 * W**H
|
||||
*
|
||||
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
|
||||
$ LASTV-K, LASTC, K,
|
||||
$ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK,
|
||||
$ ONE, C( K+1, 1 ), LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V1**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W**H
|
||||
*
|
||||
DO 30 J = 1, K
|
||||
DO 20 I = 1, LASTC
|
||||
C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
|
||||
20 CONTINUE
|
||||
30 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
*
|
||||
* Form C * H or C * H**H where C = ( C1 C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILAZLR( N, K, V, LDV ) )
|
||||
LASTC = ILAZLR( M, LASTV, C, LDC )
|
||||
*
|
||||
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
|
||||
*
|
||||
* W := C1
|
||||
*
|
||||
DO 40 J = 1, K
|
||||
CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
|
||||
40 CONTINUE
|
||||
*
|
||||
* W := W * V1
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C2 * V2
|
||||
*
|
||||
CALL ZGEMM( 'No transpose', 'No transpose',
|
||||
$ LASTC, K, LASTV-K,
|
||||
$ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T or W * T**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - W * V**H
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C2 := C2 - W * V2**H
|
||||
*
|
||||
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
|
||||
$ LASTC, LASTV-K, K,
|
||||
$ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV,
|
||||
$ ONE, C( 1, K+1 ), LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V1**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W
|
||||
*
|
||||
DO 60 J = 1, K
|
||||
DO 50 I = 1, LASTC
|
||||
C( I, J ) = C( I, J ) - WORK( I, J )
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
END IF
|
||||
*
|
||||
ELSE
|
||||
*
|
||||
* Let V = ( V1 )
|
||||
* ( V2 ) (last K rows)
|
||||
* where V2 is unit upper triangular.
|
||||
*
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
*
|
||||
* Form H * C or H**H * C where C = ( C1 )
|
||||
* ( C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILAZLR( M, K, V, LDV ) )
|
||||
LASTC = ILAZLC( LASTV, N, C, LDC )
|
||||
*
|
||||
* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK)
|
||||
*
|
||||
* W := C2**H
|
||||
*
|
||||
DO 70 J = 1, K
|
||||
CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
|
||||
$ WORK( 1, J ), 1 )
|
||||
CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
|
||||
70 CONTINUE
|
||||
*
|
||||
* W := W * V2
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C1**H*V1
|
||||
*
|
||||
CALL ZGEMM( 'Conjugate transpose', 'No transpose',
|
||||
$ LASTC, K, LASTV-K,
|
||||
$ ONE, C, LDC, V, LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T**H or W * T
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - V * W**H
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C1 := C1 - V1 * W**H
|
||||
*
|
||||
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
|
||||
$ LASTV-K, LASTC, K,
|
||||
$ -ONE, V, LDV, WORK, LDWORK,
|
||||
$ ONE, C, LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V2**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
*
|
||||
* C2 := C2 - W**H
|
||||
*
|
||||
DO 90 J = 1, K
|
||||
DO 80 I = 1, LASTC
|
||||
C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
|
||||
$ DCONJG( WORK( I, J ) )
|
||||
80 CONTINUE
|
||||
90 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
*
|
||||
* Form C * H or C * H**H where C = ( C1 C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILAZLR( N, K, V, LDV ) )
|
||||
LASTC = ILAZLR( M, LASTV, C, LDC )
|
||||
*
|
||||
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
|
||||
*
|
||||
* W := C2
|
||||
*
|
||||
DO 100 J = 1, K
|
||||
CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1,
|
||||
$ WORK( 1, J ), 1 )
|
||||
100 CONTINUE
|
||||
*
|
||||
* W := W * V2
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C1 * V1
|
||||
*
|
||||
CALL ZGEMM( 'No transpose', 'No transpose',
|
||||
$ LASTC, K, LASTV-K,
|
||||
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T or W * T**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - W * V**H
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C1 := C1 - W * V1**H
|
||||
*
|
||||
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
|
||||
$ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
|
||||
$ ONE, C, LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V2**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
*
|
||||
* C2 := C2 - W
|
||||
*
|
||||
DO 120 J = 1, K
|
||||
DO 110 I = 1, LASTC
|
||||
C( I, LASTV-K+J ) = C( I, LASTV-K+J )
|
||||
$ - WORK( I, J )
|
||||
110 CONTINUE
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
ELSE IF( LSAME( STOREV, 'R' ) ) THEN
|
||||
*
|
||||
IF( LSAME( DIRECT, 'F' ) ) THEN
|
||||
*
|
||||
* Let V = ( V1 V2 ) (V1: first K columns)
|
||||
* where V1 is unit upper triangular.
|
||||
*
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
*
|
||||
* Form H * C or H**H * C where C = ( C1 )
|
||||
* ( C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILAZLC( K, M, V, LDV ) )
|
||||
LASTC = ILAZLC( LASTV, N, C, LDC )
|
||||
*
|
||||
* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
|
||||
*
|
||||
* W := C1**H
|
||||
*
|
||||
DO 130 J = 1, K
|
||||
CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
|
||||
CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
|
||||
130 CONTINUE
|
||||
*
|
||||
* W := W * V1**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C2**H*V2**H
|
||||
*
|
||||
CALL ZGEMM( 'Conjugate transpose',
|
||||
$ 'Conjugate transpose', LASTC, K, LASTV-K,
|
||||
$ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T**H or W * T
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - V**H * W**H
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C2 := C2 - V2**H * W**H
|
||||
*
|
||||
CALL ZGEMM( 'Conjugate transpose',
|
||||
$ 'Conjugate transpose', LASTV-K, LASTC, K,
|
||||
$ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
|
||||
$ ONE, C( K+1, 1 ), LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V1
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W**H
|
||||
*
|
||||
DO 150 J = 1, K
|
||||
DO 140 I = 1, LASTC
|
||||
C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
|
||||
140 CONTINUE
|
||||
150 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
*
|
||||
* Form C * H or C * H**H where C = ( C1 C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILAZLC( K, N, V, LDV ) )
|
||||
LASTC = ILAZLR( M, LASTV, C, LDC )
|
||||
*
|
||||
* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK)
|
||||
*
|
||||
* W := C1
|
||||
*
|
||||
DO 160 J = 1, K
|
||||
CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
|
||||
160 CONTINUE
|
||||
*
|
||||
* W := W * V1**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C2 * V2**H
|
||||
*
|
||||
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
|
||||
$ LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC,
|
||||
$ V( 1, K+1 ), LDV, ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T or W * T**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - W * V
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C2 := C2 - W * V2
|
||||
*
|
||||
CALL ZGEMM( 'No transpose', 'No transpose',
|
||||
$ LASTC, LASTV-K, K,
|
||||
$ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
|
||||
$ ONE, C( 1, K+1 ), LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V1
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W
|
||||
*
|
||||
DO 180 J = 1, K
|
||||
DO 170 I = 1, LASTC
|
||||
C( I, J ) = C( I, J ) - WORK( I, J )
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
*
|
||||
END IF
|
||||
*
|
||||
ELSE
|
||||
*
|
||||
* Let V = ( V1 V2 ) (V2: last K columns)
|
||||
* where V2 is unit lower triangular.
|
||||
*
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
*
|
||||
* Form H * C or H**H * C where C = ( C1 )
|
||||
* ( C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILAZLC( K, M, V, LDV ) )
|
||||
LASTC = ILAZLC( LASTV, N, C, LDC )
|
||||
*
|
||||
* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
|
||||
*
|
||||
* W := C2**H
|
||||
*
|
||||
DO 190 J = 1, K
|
||||
CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
|
||||
$ WORK( 1, J ), 1 )
|
||||
CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
|
||||
190 CONTINUE
|
||||
*
|
||||
* W := W * V2**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C1**H * V1**H
|
||||
*
|
||||
CALL ZGEMM( 'Conjugate transpose',
|
||||
$ 'Conjugate transpose', LASTC, K, LASTV-K,
|
||||
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T**H or W * T
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - V**H * W**H
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C1 := C1 - V1**H * W**H
|
||||
*
|
||||
CALL ZGEMM( 'Conjugate transpose',
|
||||
$ 'Conjugate transpose', LASTV-K, LASTC, K,
|
||||
$ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V2
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
*
|
||||
* C2 := C2 - W**H
|
||||
*
|
||||
DO 210 J = 1, K
|
||||
DO 200 I = 1, LASTC
|
||||
C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
|
||||
$ DCONJG( WORK( I, J ) )
|
||||
200 CONTINUE
|
||||
210 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
*
|
||||
* Form C * H or C * H**H where C = ( C1 C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILAZLC( K, N, V, LDV ) )
|
||||
LASTC = ILAZLR( M, LASTV, C, LDC )
|
||||
*
|
||||
* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK)
|
||||
*
|
||||
* W := C2
|
||||
*
|
||||
DO 220 J = 1, K
|
||||
CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1,
|
||||
$ WORK( 1, J ), 1 )
|
||||
220 CONTINUE
|
||||
*
|
||||
* W := W * V2**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C1 * V1**H
|
||||
*
|
||||
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
|
||||
$ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, ONE,
|
||||
$ WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T or W * T**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - W * V
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C1 := C1 - W * V1
|
||||
*
|
||||
CALL ZGEMM( 'No transpose', 'No transpose',
|
||||
$ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
|
||||
$ ONE, C, LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V2
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W
|
||||
*
|
||||
DO 240 J = 1, K
|
||||
DO 230 I = 1, LASTC
|
||||
C( I, LASTV-K+J ) = C( I, LASTV-K+J )
|
||||
$ - WORK( I, J )
|
||||
230 CONTINUE
|
||||
240 CONTINUE
|
||||
*
|
||||
END IF
|
||||
*
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZLARFB
|
||||
*
|
||||
END
|
||||
203
cs440-acg/ext/eigen/lapack/zlarfg.f
Normal file
203
cs440-acg/ext/eigen/lapack/zlarfg.f
Normal file
@@ -0,0 +1,203 @@
|
||||
*> \brief \b ZLARFG
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZLARFG + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarfg.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarfg.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarfg.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX, N
|
||||
* COMPLEX*16 ALPHA, TAU
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 X( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLARFG generates a complex elementary reflector H of order n, such
|
||||
*> that
|
||||
*>
|
||||
*> H**H * ( alpha ) = ( beta ), H**H * H = I.
|
||||
*> ( x ) ( 0 )
|
||||
*>
|
||||
*> where alpha and beta are scalars, with beta real, and x is an
|
||||
*> (n-1)-element complex vector. H is represented in the form
|
||||
*>
|
||||
*> H = I - tau * ( 1 ) * ( 1 v**H ) ,
|
||||
*> ( v )
|
||||
*>
|
||||
*> where tau is a complex scalar and v is a complex (n-1)-element
|
||||
*> vector. Note that H is not hermitian.
|
||||
*>
|
||||
*> If the elements of x are all zero and alpha is real, then tau = 0
|
||||
*> and H is taken to be the unit matrix.
|
||||
*>
|
||||
*> Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the elementary reflector.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX*16
|
||||
*> On entry, the value alpha.
|
||||
*> On exit, it is overwritten with the value beta.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX*16 array, dimension
|
||||
*> (1+(N-2)*abs(INCX))
|
||||
*> On entry, the vector x.
|
||||
*> On exit, it is overwritten with the vector v.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> The increment between elements of X. INCX > 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] TAU
|
||||
*> \verbatim
|
||||
*> TAU is COMPLEX*16
|
||||
*> The value tau.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16OTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX, N
|
||||
COMPLEX*16 ALPHA, TAU
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 X( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE, ZERO
|
||||
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER J, KNT
|
||||
DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2
|
||||
COMPLEX*16 ZLADIV
|
||||
EXTERNAL DLAMCH, DLAPY3, DZNRM2, ZLADIV
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, DBLE, DCMPLX, DIMAG, SIGN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL ZDSCAL, ZSCAL
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( N.LE.0 ) THEN
|
||||
TAU = ZERO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
XNORM = DZNRM2( N-1, X, INCX )
|
||||
ALPHR = DBLE( ALPHA )
|
||||
ALPHI = DIMAG( ALPHA )
|
||||
*
|
||||
IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
|
||||
*
|
||||
* H = I
|
||||
*
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
*
|
||||
* general case
|
||||
*
|
||||
BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
|
||||
SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
|
||||
RSAFMN = ONE / SAFMIN
|
||||
*
|
||||
KNT = 0
|
||||
IF( ABS( BETA ).LT.SAFMIN ) THEN
|
||||
*
|
||||
* XNORM, BETA may be inaccurate; scale X and recompute them
|
||||
*
|
||||
10 CONTINUE
|
||||
KNT = KNT + 1
|
||||
CALL ZDSCAL( N-1, RSAFMN, X, INCX )
|
||||
BETA = BETA*RSAFMN
|
||||
ALPHI = ALPHI*RSAFMN
|
||||
ALPHR = ALPHR*RSAFMN
|
||||
IF( ABS( BETA ).LT.SAFMIN )
|
||||
$ GO TO 10
|
||||
*
|
||||
* New BETA is at most 1, at least SAFMIN
|
||||
*
|
||||
XNORM = DZNRM2( N-1, X, INCX )
|
||||
ALPHA = DCMPLX( ALPHR, ALPHI )
|
||||
BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
|
||||
END IF
|
||||
TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
|
||||
ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA )
|
||||
CALL ZSCAL( N-1, ALPHA, X, INCX )
|
||||
*
|
||||
* If ALPHA is subnormal, it may lose relative accuracy
|
||||
*
|
||||
DO 20 J = 1, KNT
|
||||
BETA = BETA*SAFMIN
|
||||
20 CONTINUE
|
||||
ALPHA = BETA
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZLARFG
|
||||
*
|
||||
END
|
||||
327
cs440-acg/ext/eigen/lapack/zlarft.f
Normal file
327
cs440-acg/ext/eigen/lapack/zlarft.f
Normal file
@@ -0,0 +1,327 @@
|
||||
*> \brief \b ZLARFT
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZLARFT + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarft.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarft.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarft.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER DIRECT, STOREV
|
||||
* INTEGER K, LDT, LDV, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLARFT forms the triangular factor T of a complex block reflector H
|
||||
*> of order n, which is defined as a product of k elementary reflectors.
|
||||
*>
|
||||
*> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
|
||||
*>
|
||||
*> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
|
||||
*>
|
||||
*> If STOREV = 'C', the vector which defines the elementary reflector
|
||||
*> H(i) is stored in the i-th column of the array V, and
|
||||
*>
|
||||
*> H = I - V * T * V**H
|
||||
*>
|
||||
*> If STOREV = 'R', the vector which defines the elementary reflector
|
||||
*> H(i) is stored in the i-th row of the array V, and
|
||||
*>
|
||||
*> H = I - V**H * T * V
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] DIRECT
|
||||
*> \verbatim
|
||||
*> DIRECT is CHARACTER*1
|
||||
*> Specifies the order in which the elementary reflectors are
|
||||
*> multiplied to form the block reflector:
|
||||
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
|
||||
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] STOREV
|
||||
*> \verbatim
|
||||
*> STOREV is CHARACTER*1
|
||||
*> Specifies how the vectors which define the elementary
|
||||
*> reflectors are stored (see also Further Details):
|
||||
*> = 'C': columnwise
|
||||
*> = 'R': rowwise
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the block reflector H. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The order of the triangular factor T (= the number of
|
||||
*> elementary reflectors). K >= 1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] V
|
||||
*> \verbatim
|
||||
*> V is COMPLEX*16 array, dimension
|
||||
*> (LDV,K) if STOREV = 'C'
|
||||
*> (LDV,N) if STOREV = 'R'
|
||||
*> The matrix V. See further details.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDV
|
||||
*> \verbatim
|
||||
*> LDV is INTEGER
|
||||
*> The leading dimension of the array V.
|
||||
*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TAU
|
||||
*> \verbatim
|
||||
*> TAU is COMPLEX*16 array, dimension (K)
|
||||
*> TAU(i) must contain the scalar factor of the elementary
|
||||
*> reflector H(i).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] T
|
||||
*> \verbatim
|
||||
*> T is COMPLEX*16 array, dimension (LDT,K)
|
||||
*> The k by k triangular factor T of the block reflector.
|
||||
*> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
|
||||
*> lower triangular. The rest of the array is not used.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDT
|
||||
*> \verbatim
|
||||
*> LDT is INTEGER
|
||||
*> The leading dimension of the array T. LDT >= K.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date April 2012
|
||||
*
|
||||
*> \ingroup complex16OTHERauxiliary
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> The shape of the matrix V and the storage of the vectors which define
|
||||
*> the H(i) is best illustrated by the following example with n = 5 and
|
||||
*> k = 3. The elements equal to 1 are not stored.
|
||||
*>
|
||||
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
|
||||
*>
|
||||
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
|
||||
*> ( v1 1 ) ( 1 v2 v2 v2 )
|
||||
*> ( v1 v2 1 ) ( 1 v3 v3 )
|
||||
*> ( v1 v2 v3 )
|
||||
*> ( v1 v2 v3 )
|
||||
*>
|
||||
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
|
||||
*>
|
||||
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
|
||||
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
|
||||
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
|
||||
*> ( 1 v3 )
|
||||
*> ( 1 )
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.1) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* April 2012
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER DIRECT, STOREV
|
||||
INTEGER K, LDT, LDV, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ONE, ZERO
|
||||
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
|
||||
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J, PREVLASTV, LASTV
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL ZGEMV, ZLACGV, ZTRMV
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
IF( LSAME( DIRECT, 'F' ) ) THEN
|
||||
PREVLASTV = N
|
||||
DO I = 1, K
|
||||
PREVLASTV = MAX( PREVLASTV, I )
|
||||
IF( TAU( I ).EQ.ZERO ) THEN
|
||||
*
|
||||
* H(i) = I
|
||||
*
|
||||
DO J = 1, I
|
||||
T( J, I ) = ZERO
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* general case
|
||||
*
|
||||
IF( LSAME( STOREV, 'C' ) ) THEN
|
||||
* Skip any trailing zeros.
|
||||
DO LASTV = N, I+1, -1
|
||||
IF( V( LASTV, I ).NE.ZERO ) EXIT
|
||||
END DO
|
||||
DO J = 1, I-1
|
||||
T( J, I ) = -TAU( I ) * CONJG( V( I , J ) )
|
||||
END DO
|
||||
J = MIN( LASTV, PREVLASTV )
|
||||
*
|
||||
* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i)
|
||||
*
|
||||
CALL ZGEMV( 'Conjugate transpose', J-I, I-1,
|
||||
$ -TAU( I ), V( I+1, 1 ), LDV,
|
||||
$ V( I+1, I ), 1, ONE, T( 1, I ), 1 )
|
||||
ELSE
|
||||
* Skip any trailing zeros.
|
||||
DO LASTV = N, I+1, -1
|
||||
IF( V( I, LASTV ).NE.ZERO ) EXIT
|
||||
END DO
|
||||
DO J = 1, I-1
|
||||
T( J, I ) = -TAU( I ) * V( J , I )
|
||||
END DO
|
||||
J = MIN( LASTV, PREVLASTV )
|
||||
*
|
||||
* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H
|
||||
*
|
||||
CALL ZGEMM( 'N', 'C', I-1, 1, J-I, -TAU( I ),
|
||||
$ V( 1, I+1 ), LDV, V( I, I+1 ), LDV,
|
||||
$ ONE, T( 1, I ), LDT )
|
||||
END IF
|
||||
*
|
||||
* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
|
||||
*
|
||||
CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
|
||||
$ LDT, T( 1, I ), 1 )
|
||||
T( I, I ) = TAU( I )
|
||||
IF( I.GT.1 ) THEN
|
||||
PREVLASTV = MAX( PREVLASTV, LASTV )
|
||||
ELSE
|
||||
PREVLASTV = LASTV
|
||||
END IF
|
||||
END IF
|
||||
END DO
|
||||
ELSE
|
||||
PREVLASTV = 1
|
||||
DO I = K, 1, -1
|
||||
IF( TAU( I ).EQ.ZERO ) THEN
|
||||
*
|
||||
* H(i) = I
|
||||
*
|
||||
DO J = I, K
|
||||
T( J, I ) = ZERO
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* general case
|
||||
*
|
||||
IF( I.LT.K ) THEN
|
||||
IF( LSAME( STOREV, 'C' ) ) THEN
|
||||
* Skip any leading zeros.
|
||||
DO LASTV = 1, I-1
|
||||
IF( V( LASTV, I ).NE.ZERO ) EXIT
|
||||
END DO
|
||||
DO J = I+1, K
|
||||
T( J, I ) = -TAU( I ) * CONJG( V( N-K+I , J ) )
|
||||
END DO
|
||||
J = MAX( LASTV, PREVLASTV )
|
||||
*
|
||||
* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i)
|
||||
*
|
||||
CALL ZGEMV( 'Conjugate transpose', N-K+I-J, K-I,
|
||||
$ -TAU( I ), V( J, I+1 ), LDV, V( J, I ),
|
||||
$ 1, ONE, T( I+1, I ), 1 )
|
||||
ELSE
|
||||
* Skip any leading zeros.
|
||||
DO LASTV = 1, I-1
|
||||
IF( V( I, LASTV ).NE.ZERO ) EXIT
|
||||
END DO
|
||||
DO J = I+1, K
|
||||
T( J, I ) = -TAU( I ) * V( J, N-K+I )
|
||||
END DO
|
||||
J = MAX( LASTV, PREVLASTV )
|
||||
*
|
||||
* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H
|
||||
*
|
||||
CALL ZGEMM( 'N', 'C', K-I, 1, N-K+I-J, -TAU( I ),
|
||||
$ V( I+1, J ), LDV, V( I, J ), LDV,
|
||||
$ ONE, T( I+1, I ), LDT )
|
||||
END IF
|
||||
*
|
||||
* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
|
||||
*
|
||||
CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
|
||||
$ T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
|
||||
IF( I.GT.1 ) THEN
|
||||
PREVLASTV = MIN( PREVLASTV, LASTV )
|
||||
ELSE
|
||||
PREVLASTV = LASTV
|
||||
END IF
|
||||
END IF
|
||||
T( I, I ) = TAU( I )
|
||||
END IF
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of ZLARFT
|
||||
*
|
||||
END
|
||||
Reference in New Issue
Block a user