Squashed 'third_party/eigen/' content from commit 61d72f6
Change-Id: Iccc90fa0b55ab44037f018046d2fcffd90d9d025
git-subtree-dir: third_party/eigen
git-subtree-split: 61d72f6383cfa842868c53e30e087b0258177257
diff --git a/lapack/CMakeLists.txt b/lapack/CMakeLists.txt
new file mode 100644
index 0000000..9883d4c
--- /dev/null
+++ b/lapack/CMakeLists.txt
@@ -0,0 +1,449 @@
+
+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 5758ce55afcf79da98de8b9de1615ad5
+ 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()
+ add_subdirectory(testing/MATGEN)
+ add_subdirectory(testing/LIN)
+ add_subdirectory(testing/EIG)
+ 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()
+
diff --git a/lapack/cholesky.cpp b/lapack/cholesky.cpp
new file mode 100644
index 0000000..ea3bc12
--- /dev/null
+++ b/lapack/cholesky.cpp
@@ -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;
+}
diff --git a/lapack/clacgv.f b/lapack/clacgv.f
new file mode 100644
index 0000000..359eb07
--- /dev/null
+++ b/lapack/clacgv.f
@@ -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
diff --git a/lapack/cladiv.f b/lapack/cladiv.f
new file mode 100644
index 0000000..2807ac5
--- /dev/null
+++ b/lapack/cladiv.f
@@ -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
diff --git a/lapack/clarf.f b/lapack/clarf.f
new file mode 100644
index 0000000..ca0328f
--- /dev/null
+++ b/lapack/clarf.f
@@ -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
diff --git a/lapack/clarfb.f b/lapack/clarfb.f
new file mode 100644
index 0000000..40bbdf4
--- /dev/null
+++ b/lapack/clarfb.f
@@ -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
diff --git a/lapack/clarfg.f b/lapack/clarfg.f
new file mode 100644
index 0000000..d64f396
--- /dev/null
+++ b/lapack/clarfg.f
@@ -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
diff --git a/lapack/clarft.f b/lapack/clarft.f
new file mode 100644
index 0000000..981447f
--- /dev/null
+++ b/lapack/clarft.f
@@ -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
diff --git a/lapack/complex_double.cpp b/lapack/complex_double.cpp
new file mode 100644
index 0000000..424d2b8
--- /dev/null
+++ b/lapack/complex_double.cpp
@@ -0,0 +1,17 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// Copyright (C) 2009-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/.
+
+#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"
diff --git a/lapack/complex_single.cpp b/lapack/complex_single.cpp
new file mode 100644
index 0000000..c0b2d29
--- /dev/null
+++ b/lapack/complex_single.cpp
@@ -0,0 +1,17 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// Copyright (C) 2009-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/.
+
+#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"
diff --git a/lapack/dladiv.f b/lapack/dladiv.f
new file mode 100644
index 0000000..090a906
--- /dev/null
+++ b/lapack/dladiv.f
@@ -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
diff --git a/lapack/dlamch.f b/lapack/dlamch.f
new file mode 100644
index 0000000..eb307e5
--- /dev/null
+++ b/lapack/dlamch.f
@@ -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
+*
+************************************************************************
diff --git a/lapack/dlapy2.f b/lapack/dlapy2.f
new file mode 100644
index 0000000..e6a62bf
--- /dev/null
+++ b/lapack/dlapy2.f
@@ -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
diff --git a/lapack/dlapy3.f b/lapack/dlapy3.f
new file mode 100644
index 0000000..ae9844f
--- /dev/null
+++ b/lapack/dlapy3.f
@@ -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
diff --git a/lapack/dlarf.f b/lapack/dlarf.f
new file mode 100644
index 0000000..2a82ff4
--- /dev/null
+++ b/lapack/dlarf.f
@@ -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
diff --git a/lapack/dlarfb.f b/lapack/dlarfb.f
new file mode 100644
index 0000000..206d3b2
--- /dev/null
+++ b/lapack/dlarfb.f
@@ -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
diff --git a/lapack/dlarfg.f b/lapack/dlarfg.f
new file mode 100644
index 0000000..458ad2e
--- /dev/null
+++ b/lapack/dlarfg.f
@@ -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
diff --git a/lapack/dlarft.f b/lapack/dlarft.f
new file mode 100644
index 0000000..4b75504
--- /dev/null
+++ b/lapack/dlarft.f
@@ -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
diff --git a/lapack/double.cpp b/lapack/double.cpp
new file mode 100644
index 0000000..d86549e
--- /dev/null
+++ b/lapack/double.cpp
@@ -0,0 +1,17 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// Copyright (C) 2009-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/.
+
+#define SCALAR double
+#define SCALAR_SUFFIX d
+#define SCALAR_SUFFIX_UP "D"
+#define ISCOMPLEX 0
+
+#include "cholesky.cpp"
+#include "lu.cpp"
+#include "eigenvalues.cpp"
diff --git a/lapack/dsecnd_NONE.f b/lapack/dsecnd_NONE.f
new file mode 100644
index 0000000..61a8dff
--- /dev/null
+++ b/lapack/dsecnd_NONE.f
@@ -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
diff --git a/lapack/eigenvalues.cpp b/lapack/eigenvalues.cpp
new file mode 100644
index 0000000..a1526eb
--- /dev/null
+++ b/lapack/eigenvalues.cpp
@@ -0,0 +1,79 @@
+// 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 "common.h"
+#include <Eigen/Eigenvalues>
+
+// computes an LU factorization of a general M-by-N matrix A using partial pivoting with row interchanges
+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 nb = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 )
+// LWKOPT = MAX( 1, ( NB+2 )*N )
+// WORK( 1 ) = LWKOPT
+// *
+// IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY )
+// $ INFO = -8
+// END IF
+// *
+// IF( INFO.NE.0 ) THEN
+// CALL XERBLA( 'SSYEV ', -INFO )
+// RETURN
+// ELSE IF( LQUERY ) THEN
+// RETURN
+// END IF
+
+ 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)
+ {
+ vector(w,*n).setZero();
+ if(computeVectors)
+ matrix(a,*n,*n,*lda).setIdentity();
+ //*info = 1;
+ return 0;
+ }
+
+ vector(w,*n) = eig.eigenvalues();
+ if(computeVectors)
+ matrix(a,*n,*n,*lda) = eig.eigenvectors();
+
+ return 0;
+}
diff --git a/lapack/ilaclc.f b/lapack/ilaclc.f
new file mode 100644
index 0000000..4ceb61c
--- /dev/null
+++ b/lapack/ilaclc.f
@@ -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
diff --git a/lapack/ilaclr.f b/lapack/ilaclr.f
new file mode 100644
index 0000000..d8ab09c
--- /dev/null
+++ b/lapack/ilaclr.f
@@ -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
diff --git a/lapack/iladlc.f b/lapack/iladlc.f
new file mode 100644
index 0000000..f84bd83
--- /dev/null
+++ b/lapack/iladlc.f
@@ -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
diff --git a/lapack/iladlr.f b/lapack/iladlr.f
new file mode 100644
index 0000000..2114c61
--- /dev/null
+++ b/lapack/iladlr.f
@@ -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
diff --git a/lapack/ilaslc.f b/lapack/ilaslc.f
new file mode 100644
index 0000000..e3db0f4
--- /dev/null
+++ b/lapack/ilaslc.f
@@ -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
diff --git a/lapack/ilaslr.f b/lapack/ilaslr.f
new file mode 100644
index 0000000..48b73f4
--- /dev/null
+++ b/lapack/ilaslr.f
@@ -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
diff --git a/lapack/ilazlc.f b/lapack/ilazlc.f
new file mode 100644
index 0000000..15b1490
--- /dev/null
+++ b/lapack/ilazlc.f
@@ -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
diff --git a/lapack/ilazlr.f b/lapack/ilazlr.f
new file mode 100644
index 0000000..b2ab943
--- /dev/null
+++ b/lapack/ilazlr.f
@@ -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
diff --git a/lapack/lapack_common.h b/lapack/lapack_common.h
new file mode 100644
index 0000000..e558c14
--- /dev/null
+++ b/lapack/lapack_common.h
@@ -0,0 +1,23 @@
+// 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/.
+
+#ifndef EIGEN_LAPACK_COMMON_H
+#define EIGEN_LAPACK_COMMON_H
+
+#include "../blas/common.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;
+
+
+
+#endif // EIGEN_LAPACK_COMMON_H
diff --git a/lapack/lu.cpp b/lapack/lu.cpp
new file mode 100644
index 0000000..90cebe0
--- /dev/null
+++ b/lapack/lu.cpp
@@ -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;
+}
diff --git a/lapack/second_NONE.f b/lapack/second_NONE.f
new file mode 100644
index 0000000..d3e6d33
--- /dev/null
+++ b/lapack/second_NONE.f
@@ -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
diff --git a/lapack/single.cpp b/lapack/single.cpp
new file mode 100644
index 0000000..a64ed44
--- /dev/null
+++ b/lapack/single.cpp
@@ -0,0 +1,17 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// Copyright (C) 2009-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/.
+
+#define SCALAR float
+#define SCALAR_SUFFIX s
+#define SCALAR_SUFFIX_UP "S"
+#define ISCOMPLEX 0
+
+#include "cholesky.cpp"
+#include "lu.cpp"
+#include "eigenvalues.cpp"
diff --git a/lapack/sladiv.f b/lapack/sladiv.f
new file mode 100644
index 0000000..da3afa3
--- /dev/null
+++ b/lapack/sladiv.f
@@ -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
diff --git a/lapack/slamch.f b/lapack/slamch.f
new file mode 100644
index 0000000..4bffad0
--- /dev/null
+++ b/lapack/slamch.f
@@ -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
+*
+************************************************************************
diff --git a/lapack/slapy2.f b/lapack/slapy2.f
new file mode 100644
index 0000000..1f6b1ca
--- /dev/null
+++ b/lapack/slapy2.f
@@ -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
diff --git a/lapack/slapy3.f b/lapack/slapy3.f
new file mode 100644
index 0000000..aa2f5bf
--- /dev/null
+++ b/lapack/slapy3.f
@@ -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
diff --git a/lapack/slarf.f b/lapack/slarf.f
new file mode 100644
index 0000000..8a8ff30
--- /dev/null
+++ b/lapack/slarf.f
@@ -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
diff --git a/lapack/slarfb.f b/lapack/slarfb.f
new file mode 100644
index 0000000..eb95990
--- /dev/null
+++ b/lapack/slarfb.f
@@ -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
diff --git a/lapack/slarfg.f b/lapack/slarfg.f
new file mode 100644
index 0000000..4f10ffc
--- /dev/null
+++ b/lapack/slarfg.f
@@ -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
diff --git a/lapack/slarft.f b/lapack/slarft.f
new file mode 100644
index 0000000..30b0668
--- /dev/null
+++ b/lapack/slarft.f
@@ -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
diff --git a/lapack/zlacgv.f b/lapack/zlacgv.f
new file mode 100644
index 0000000..16c2e2e
--- /dev/null
+++ b/lapack/zlacgv.f
@@ -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
diff --git a/lapack/zladiv.f b/lapack/zladiv.f
new file mode 100644
index 0000000..aa71db1
--- /dev/null
+++ b/lapack/zladiv.f
@@ -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
diff --git a/lapack/zlarf.f b/lapack/zlarf.f
new file mode 100644
index 0000000..53f314d
--- /dev/null
+++ b/lapack/zlarf.f
@@ -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
diff --git a/lapack/zlarfb.f b/lapack/zlarfb.f
new file mode 100644
index 0000000..30fc4b9
--- /dev/null
+++ b/lapack/zlarfb.f
@@ -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
diff --git a/lapack/zlarfg.f b/lapack/zlarfg.f
new file mode 100644
index 0000000..a90ae9f
--- /dev/null
+++ b/lapack/zlarfg.f
@@ -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
diff --git a/lapack/zlarft.f b/lapack/zlarft.f
new file mode 100644
index 0000000..6a6151f
--- /dev/null
+++ b/lapack/zlarft.f
@@ -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