From b2da3ca3e9acd2bee8270357550b9aba9b95eed8 Mon Sep 17 00:00:00 2001 From: Christoph Junghans Date: Thu, 17 May 2018 17:23:54 -0600 Subject: [PATCH 1/9] cmake: add DOWNLOAD_MSCG option --- cmake/CMakeLists.txt | 46 ++++++++++++++++++++---------------- cmake/Modules/FindMSCG.cmake | 22 +++++++++++++++++ 2 files changed, 48 insertions(+), 20 deletions(-) create mode 100644 cmake/Modules/FindMSCG.cmake diff --git a/cmake/CMakeLists.txt b/cmake/CMakeLists.txt index 7ce7ca23e1..ae8f88226d 100644 --- a/cmake/CMakeLists.txt +++ b/cmake/CMakeLists.txt @@ -153,7 +153,7 @@ if(PKG_MEAM) enable_language(C) endif() -if(PKG_KOKKOS OR PKG_MSCG) +if(PKG_KOKKOS) # starting with CMake 3.1 this is all you have to do to enforce C++11 set(CMAKE_CXX_STANDARD 11) # C++11... set(CMAKE_CXX_STANDARD_REQUIRED ON) #...is required... @@ -397,27 +397,33 @@ if(PKG_KIM) endif() if(PKG_MSCG) - find_package(GSL REQUIRED) - set(LAMMPS_LIB_MSCG_BIN_DIR ${LAMMPS_LIB_BINARY_DIR}/mscg) - set(MSCG_TARBALL ${LAMMPS_LIB_MSCG_BIN_DIR}/MS-CG-master.zip) - set(LAMMPS_LIB_MSCG_BIN_DIR ${LAMMPS_LIB_MSCG_BIN_DIR}/MSCG-release-master/src) - if(NOT EXISTS ${LAMMPS_LIB_MSCG_BIN_DIR}) - if(NOT EXISTS ${MSCG_TARBALL}) - message(STATUS "Downloading ${MSCG_TARBALL}") - file(DOWNLOAD - https://github.com/uchicago-voth/MSCG-release/archive/master.zip - ${MSCG_TARBALL} SHOW_PROGRESS) #EXPECTED_MD5 cannot be due due to master + option(DOWNLOAD_MSCG "Download latte (instead of using the system's one)" OFF) + if(DOWNLOAD_MSCG) + include(ExternalProject) + if(NOT LAPACK_FOUND) + set(EXTRA_MSCG_OPTS "-DLAPACK_LIBRARIES=${CMAKE_CURRENT_BINARY_DIR}/liblinalg.a") + endif() + ExternalProject_Add(mscg_build + URL https://github.com//uchicago-voth/MSCG-release/archive/1.7.3.1.tar.gz + URL_MD5 8c45e269ee13f60b303edd7823866a91 + SOURCE_SUBDIR src/CMake + CMAKE_ARGS -DCMAKE_INSTALL_PREFIX= -DCMAKE_POSITION_INDEPENDENT_CODE=${CMAKE_POSITION_INDEPENDENT_CODE} ${EXTRA_MSCG_OPTS} + ) + ExternalProject_get_property(mscg_build INSTALL_DIR) + set(MSCG_LIBRARIES ${INSTALL_DIR}/${CMAKE_INSTALL_LIBDIR}/libmxcg.a) + set(MSCG_INCLUDE_DIRS ${INSTALL_DIR}/include) + list(APPEND LAMMPS_DEPS mscg_build) + if(NOT LAPACK_FOUND) + add_dependencies(mscg_build linalg) + endif() + else() + find_package(MSCG) + if(NOT MSCG_FOUND) + message(FATAL_ERROR "MSCG not found, help CMake to find it by setting MSCG_LIBRARY and MSCG_INCLUDE_DIRS, or set DOWNLOAD_MSCG=ON to download it") endif() - message(STATUS "Unpacking ${MSCG_TARBALL}") - execute_process(COMMAND ${CMAKE_COMMAND} -E tar xvf ${MSCG_TARBALL} - WORKING_DIRECTORY ${LAMMPS_LIB_BINARY_DIR}/mscg) endif() - file(GLOB MSCG_SOURCES ${LAMMPS_LIB_MSCG_BIN_DIR}/*.cpp) - add_library(mscg STATIC ${MSCG_SOURCES}) - list(APPEND LAMMPS_LINK_LIBS mscg) - target_compile_options(mscg PRIVATE -DDIMENSION=3 -D_exclude_gromacs=1) - target_include_directories(mscg PUBLIC ${LAMMPS_LIB_MSCG_BIN_DIR}) - target_link_libraries(mscg ${GSL_LIBRARIES} ${LAPACK_LIBRARIES}) + list(APPEND LAMMPS_LINK_LIBS ${MSCG_LIBRARIES}) + include_directories(${MSCG_INCLUDE_DIRS}) endif() if(PKG_COMPRESS) diff --git a/cmake/Modules/FindMSCG.cmake b/cmake/Modules/FindMSCG.cmake new file mode 100644 index 0000000000..311ff78038 --- /dev/null +++ b/cmake/Modules/FindMSCG.cmake @@ -0,0 +1,22 @@ +# - Find mscg +# Find the native MSCG headers and libraries. +# +# MSCG_INCLUDE_DIRS - where to find mscg.h, etc. +# MSCG_LIBRARIES - List of libraries when using mscg. +# MSCG_FOUND - True if mscg found. +# + +find_path(MSCG_INCLUDE_DIR mscg.h PATH_SUFFIXES mscg) + +find_library(MSCG_LIBRARY NAMES mscg) + +set(MSCG_LIBRARIES ${MSCG_LIBRARY}) +set(MSCG_INCLUDE_DIRS ${MSCG_INCLUDE_DIR}) + +include(FindPackageHandleStandardArgs) +# handle the QUIETLY and REQUIRED arguments and set MSCG_FOUND to TRUE +# if all listed variables are TRUE + +find_package_handle_standard_args(MSCG DEFAULT_MSG MSCG_LIBRARY MSCG_INCLUDE_DIR) + +mark_as_advanced(MSCG_INCLUDE_DIR MSCG_LIBRARY ) From 68dd7d4f2b5100ccde1691fc63fe0a52acd809ee Mon Sep 17 00:00:00 2001 From: Christoph Junghans Date: Thu, 17 May 2018 17:43:16 -0600 Subject: [PATCH 2/9] cmake: fix 2 typos in MSCG build --- cmake/CMakeLists.txt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cmake/CMakeLists.txt b/cmake/CMakeLists.txt index ae8f88226d..8110c4c9b4 100644 --- a/cmake/CMakeLists.txt +++ b/cmake/CMakeLists.txt @@ -410,8 +410,8 @@ if(PKG_MSCG) CMAKE_ARGS -DCMAKE_INSTALL_PREFIX= -DCMAKE_POSITION_INDEPENDENT_CODE=${CMAKE_POSITION_INDEPENDENT_CODE} ${EXTRA_MSCG_OPTS} ) ExternalProject_get_property(mscg_build INSTALL_DIR) - set(MSCG_LIBRARIES ${INSTALL_DIR}/${CMAKE_INSTALL_LIBDIR}/libmxcg.a) - set(MSCG_INCLUDE_DIRS ${INSTALL_DIR}/include) + set(MSCG_LIBRARIES ${INSTALL_DIR}/${CMAKE_INSTALL_LIBDIR}/libmscg.a) + set(MSCG_INCLUDE_DIRS ${INSTALL_DIR}/include/mscg) list(APPEND LAMMPS_DEPS mscg_build) if(NOT LAPACK_FOUND) add_dependencies(mscg_build linalg) From 9e82c86fbdfbdb7a8e83ba3b8584e39f194b3f76 Mon Sep 17 00:00:00 2001 From: Christoph Junghans Date: Thu, 17 May 2018 20:01:33 -0600 Subject: [PATCH 3/9] cmake: minor improvement for MSCG --- cmake/CMakeLists.txt | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/cmake/CMakeLists.txt b/cmake/CMakeLists.txt index 8110c4c9b4..5517c0c490 100644 --- a/cmake/CMakeLists.txt +++ b/cmake/CMakeLists.txt @@ -397,6 +397,7 @@ if(PKG_KIM) endif() if(PKG_MSCG) + find_package(GSL REQUIRED) option(DOWNLOAD_MSCG "Download latte (instead of using the system's one)" OFF) if(DOWNLOAD_MSCG) include(ExternalProject) @@ -404,14 +405,16 @@ if(PKG_MSCG) set(EXTRA_MSCG_OPTS "-DLAPACK_LIBRARIES=${CMAKE_CURRENT_BINARY_DIR}/liblinalg.a") endif() ExternalProject_Add(mscg_build - URL https://github.com//uchicago-voth/MSCG-release/archive/1.7.3.1.tar.gz + URL https://github.com/uchicago-voth/MSCG-release/archive/1.7.3.1.tar.gz URL_MD5 8c45e269ee13f60b303edd7823866a91 SOURCE_SUBDIR src/CMake CMAKE_ARGS -DCMAKE_INSTALL_PREFIX= -DCMAKE_POSITION_INDEPENDENT_CODE=${CMAKE_POSITION_INDEPENDENT_CODE} ${EXTRA_MSCG_OPTS} + BUILD_COMMAND make mscg INSTALL_COMMAND "" ) - ExternalProject_get_property(mscg_build INSTALL_DIR) - set(MSCG_LIBRARIES ${INSTALL_DIR}/${CMAKE_INSTALL_LIBDIR}/libmscg.a) - set(MSCG_INCLUDE_DIRS ${INSTALL_DIR}/include/mscg) + ExternalProject_get_property(mscg_build BINARY_DIR) + set(MSCG_LIBRARIES ${BINARY_DIR}/libmscg.a) + ExternalProject_get_property(mscg_build SOURCE_DIR) + set(MSCG_INCLUDE_DIRS ${SOURCE_DIR}/src) list(APPEND LAMMPS_DEPS mscg_build) if(NOT LAPACK_FOUND) add_dependencies(mscg_build linalg) @@ -422,7 +425,7 @@ if(PKG_MSCG) message(FATAL_ERROR "MSCG not found, help CMake to find it by setting MSCG_LIBRARY and MSCG_INCLUDE_DIRS, or set DOWNLOAD_MSCG=ON to download it") endif() endif() - list(APPEND LAMMPS_LINK_LIBS ${MSCG_LIBRARIES}) + list(APPEND LAMMPS_LINK_LIBS ${MSCG_LIBRARIES} ${GSL_LIBRARIES} ${LAPACK_LIBRARIES}) include_directories(${MSCG_INCLUDE_DIRS}) endif() From 6944973484f445f937ec7c5c90c0cdc3207fb423 Mon Sep 17 00:00:00 2001 From: Christoph Junghans Date: Thu, 17 May 2018 20:07:43 -0600 Subject: [PATCH 4/9] cmake: don't build Eigen3 for USER-SMD --- cmake/CMakeLists.txt | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/cmake/CMakeLists.txt b/cmake/CMakeLists.txt index 5517c0c490..8ee629c5b4 100644 --- a/cmake/CMakeLists.txt +++ b/cmake/CMakeLists.txt @@ -336,13 +336,10 @@ if(PKG_USER-SMD) ExternalProject_Add(Eigen3_build URL http://bitbucket.org/eigen/eigen/get/3.3.4.tar.gz URL_MD5 1a47e78efe365a97de0c022d127607c3 - CMAKE_ARGS -DCMAKE_INSTALL_PREFIX= -DEIGEN_TEST_NOQT=ON - -DCMAKE_DISABLE_FIND_PACKAGE_LAPACK=ON -DCMAKE_DISABLE_FIND_PACKAGE_Cholmod=ON -DCMAKE_DISABLE_FIND_PACKAGE_Umfpack=ON -DCMAKE_DISABLE_FIND_PACKAGE_SuperLU=ON - -DCMAKE_DISABLE_FIND_PACKAGE_PASTIX=ON -DCMAKE_DISABLE_FIND_PACKAGE_SPQR=ON -DCMAKE_DISABLE_FIND_PACKAGE_Boost=ON -DCMAKE_DISABLE_FIND_PACKAGE_CUDA=ON - -DCMAKE_DISABLE_FIND_PACKAGE_FFTW=ON -DCMAKE_DISABLE_FIND_PACKAGE_MPFR=ON -DCMAKE_DISABLE_FIND_PACKAGE_OpenGL=ON - ) - ExternalProject_get_property(Eigen3_build INSTALL_DIR) - set(EIGEN3_INCLUDE_DIR ${INSTALL_DIR}/include/eigen3) + CONFIGURE_COMMAND "" BUILD_COMMAND "" INSTALL_COMMAND "" + ) + ExternalProject_get_property(Eigen3_build SOURCE_DIR) + set(EIGEN3_INCLUDE_DIR ${SOURCE_DIR}) list(APPEND LAMMPS_DEPS Eigen3_build) else() find_package(Eigen3) From 6997aedf30d9c20f03e60f813cc63bb0ff0edf2a Mon Sep 17 00:00:00 2001 From: Christoph Junghans Date: Fri, 18 May 2018 15:06:54 -0600 Subject: [PATCH 5/9] cmake: avoid warning of missing include dir --- cmake/CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/cmake/CMakeLists.txt b/cmake/CMakeLists.txt index 8ee629c5b4..5b52a7d6e6 100644 --- a/cmake/CMakeLists.txt +++ b/cmake/CMakeLists.txt @@ -414,6 +414,7 @@ if(PKG_MSCG) set(MSCG_INCLUDE_DIRS ${SOURCE_DIR}/src) list(APPEND LAMMPS_DEPS mscg_build) if(NOT LAPACK_FOUND) + file(MAKE_DIRECTORY ${MSCG_INCLUDE_DIRS}) add_dependencies(mscg_build linalg) endif() else() From 858c211fdc30b83b72dc1059eb6f71f7cbc98e73 Mon Sep 17 00:00:00 2001 From: Christoph Junghans Date: Fri, 18 May 2018 15:08:08 -0600 Subject: [PATCH 6/9] linalg: add functions needed for MSCG --- lib/linalg/dgelsd.f | 629 +++++++++++++++++++++++++ lib/linalg/dgelss.f | 747 ++++++++++++++++++++++++++++++ lib/linalg/dlals0.f | 499 ++++++++++++++++++++ lib/linalg/dlalsa.f | 493 ++++++++++++++++++++ lib/linalg/dlalsd.f | 523 +++++++++++++++++++++ lib/linalg/dlasd4.f | 1061 +++++++++++++++++++++++++++++++++++++++++++ lib/linalg/dlasd5.f | 231 ++++++++++ lib/linalg/dlasd6.f | 443 ++++++++++++++++++ lib/linalg/dlasd7.f | 580 +++++++++++++++++++++++ lib/linalg/dlasd8.f | 342 ++++++++++++++ lib/linalg/dlasda.f | 514 +++++++++++++++++++++ lib/linalg/dlasdq.f | 413 +++++++++++++++++ lib/linalg/dlasdt.f | 172 +++++++ 13 files changed, 6647 insertions(+) create mode 100644 lib/linalg/dgelsd.f create mode 100644 lib/linalg/dgelss.f create mode 100644 lib/linalg/dlals0.f create mode 100644 lib/linalg/dlalsa.f create mode 100644 lib/linalg/dlalsd.f create mode 100644 lib/linalg/dlasd4.f create mode 100644 lib/linalg/dlasd5.f create mode 100644 lib/linalg/dlasd6.f create mode 100644 lib/linalg/dlasd7.f create mode 100644 lib/linalg/dlasd8.f create mode 100644 lib/linalg/dlasda.f create mode 100644 lib/linalg/dlasdq.f create mode 100644 lib/linalg/dlasdt.f diff --git a/lib/linalg/dgelsd.f b/lib/linalg/dgelsd.f new file mode 100644 index 0000000000..f2cfd63376 --- /dev/null +++ b/lib/linalg/dgelsd.f @@ -0,0 +1,629 @@ +*> \brief DGELSD computes the minimum-norm solution to a linear least squares problem for GE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGELSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, +* WORK, LWORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK +* DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGELSD computes the minimum-norm solution to a real linear least +*> squares problem: +*> minimize 2-norm(| b - A*x |) +*> using the singular value decomposition (SVD) of A. A is an M-by-N +*> matrix which may be rank-deficient. +*> +*> Several right hand side vectors b and solution vectors x can be +*> handled in a single call; they are stored as the columns of the +*> M-by-NRHS right hand side matrix B and the N-by-NRHS solution +*> matrix X. +*> +*> The problem is solved in three steps: +*> (1) Reduce the coefficient matrix A to bidiagonal form with +*> Householder transformations, reducing the original problem +*> into a "bidiagonal least squares problem" (BLS) +*> (2) Solve the BLS using a divide and conquer approach. +*> (3) Apply back all the Householder transformations to solve +*> the original least squares problem. +*> +*> The effective rank of A is determined by treating as zero those +*> singular values which are less than RCOND times the largest singular +*> value. +*> +*> The divide and conquer algorithm makes very mild assumptions about +*> floating point arithmetic. It will work on machines with a guard +*> digit in add/subtract, or on those binary machines without guard +*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or +*> Cray-2. It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, A has been destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the M-by-NRHS right hand side matrix B. +*> On exit, B is overwritten by the N-by-NRHS solution +*> matrix X. If m >= n and RANK = n, the residual +*> sum-of-squares for the solution in the i-th column is given +*> by the sum of squares of elements n+1:m in that column. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,max(M,N)). +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (min(M,N)) +*> The singular values of A in decreasing order. +*> The condition number of A in the 2-norm = S(1)/S(min(m,n)). +*> \endverbatim +*> +*> \param[in] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> RCOND is used to determine the effective rank of A. +*> Singular values S(i) <= RCOND*S(1) are treated as zero. +*> If RCOND < 0, machine precision is used instead. +*> \endverbatim +*> +*> \param[out] RANK +*> \verbatim +*> RANK is INTEGER +*> The effective rank of A, i.e., the number of singular values +*> which are greater than RCOND*S(1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK must be at least 1. +*> The exact minimum amount of workspace needed depends on M, +*> N and NRHS. As long as LWORK is at least +*> 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2, +*> if M is greater than or equal to N or +*> 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2, +*> if M is less than N, the code will execute correctly. +*> SMLSIZ is returned by ILAENV and is equal to the maximum +*> size of the subproblems at the bottom of the computation +*> tree (usually about 25), and +*> NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) +*> For good performance, LWORK should generally be larger. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> LIWORK >= max(1, 3 * MINMN * NLVL + 11 * MINMN), +*> where MINMN = MIN( M,N ). +*> On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: the algorithm for computing the SVD failed to converge; +*> if INFO = i, i off-diagonal elements of an intermediate +*> bidiagonal form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2017 +* +*> \ingroup doubleGEsolve +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Ren-Cang Li, Computer Science Division, University of +*> California at Berkeley, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +* +* ===================================================================== + SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, + $ WORK, LWORK, IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2017 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ, + $ LDWORK, LIWORK, MAXMN, MAXWRK, MINMN, MINWRK, + $ MM, MNTHR, NLVL, NWORK, SMLSIZ, WLALSD + DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM +* .. +* .. External Subroutines .. + EXTERNAL DGEBRD, DGELQF, DGEQRF, DLABAD, DLACPY, DLALSD, + $ DLASCL, DLASET, DORMBR, DORMLQ, DORMQR, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL ILAENV, DLAMCH, DLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, INT, LOG, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments. +* + INFO = 0 + MINMN = MIN( M, N ) + MAXMN = MAX( M, N ) + MNTHR = ILAENV( 6, 'DGELSD', ' ', M, N, NRHS, -1 ) + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN + INFO = -7 + END IF +* + SMLSIZ = ILAENV( 9, 'DGELSD', ' ', 0, 0, 0, 0 ) +* +* Compute workspace. +* (Note: Comments in the code beginning "Workspace:" describe the +* minimal amount of workspace needed at that point in the code, +* as well as the preferred amount for good performance. +* NB refers to the optimal block size for the immediately +* following subroutine, as returned by ILAENV.) +* + MINWRK = 1 + LIWORK = 1 + MINMN = MAX( 1, MINMN ) + NLVL = MAX( INT( LOG( DBLE( MINMN ) / DBLE( SMLSIZ+1 ) ) / + $ LOG( TWO ) ) + 1, 0 ) +* + IF( INFO.EQ.0 ) THEN + MAXWRK = 0 + LIWORK = 3*MINMN*NLVL + 11*MINMN + MM = M + IF( M.GE.N .AND. M.GE.MNTHR ) THEN +* +* Path 1a - overdetermined, with many more rows than columns. +* + MM = N + MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'DGEQRF', ' ', M, N, + $ -1, -1 ) ) + MAXWRK = MAX( MAXWRK, N+NRHS* + $ ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, -1 ) ) + END IF + IF( M.GE.N ) THEN +* +* Path 1 - overdetermined or exactly determined. +* + MAXWRK = MAX( MAXWRK, 3*N+( MM+N )* + $ ILAENV( 1, 'DGEBRD', ' ', MM, N, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*N+NRHS* + $ ILAENV( 1, 'DORMBR', 'QLT', MM, NRHS, N, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*N+( N-1 )* + $ ILAENV( 1, 'DORMBR', 'PLN', N, NRHS, N, -1 ) ) + WLALSD = 9*N+2*N*SMLSIZ+8*N*NLVL+N*NRHS+(SMLSIZ+1)**2 + MAXWRK = MAX( MAXWRK, 3*N+WLALSD ) + MINWRK = MAX( 3*N+MM, 3*N+NRHS, 3*N+WLALSD ) + END IF + IF( N.GT.M ) THEN + WLALSD = 9*M+2*M*SMLSIZ+8*M*NLVL+M*NRHS+(SMLSIZ+1)**2 + IF( N.GE.MNTHR ) THEN +* +* Path 2a - underdetermined, with many more columns +* than rows. +* + MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) + MAXWRK = MAX( MAXWRK, M*M+4*M+2*M* + $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, M*M+4*M+NRHS* + $ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 ) ) + MAXWRK = MAX( MAXWRK, M*M+4*M+( M-1 )* + $ ILAENV( 1, 'DORMBR', 'PLN', M, NRHS, M, -1 ) ) + IF( NRHS.GT.1 ) THEN + MAXWRK = MAX( MAXWRK, M*M+M+M*NRHS ) + ELSE + MAXWRK = MAX( MAXWRK, M*M+2*M ) + END IF + MAXWRK = MAX( MAXWRK, M+NRHS* + $ ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, -1 ) ) + MAXWRK = MAX( MAXWRK, M*M+4*M+WLALSD ) +! XXX: Ensure the Path 2a case below is triggered. The workspace +! calculation should use queries for all routines eventually. + MAXWRK = MAX( MAXWRK, + $ 4*M+M*M+MAX( M, 2*M-4, NRHS, N-3*M ) ) + ELSE +* +* Path 2 - remaining underdetermined cases. +* + MAXWRK = 3*M + ( N+M )*ILAENV( 1, 'DGEBRD', ' ', M, N, + $ -1, -1 ) + MAXWRK = MAX( MAXWRK, 3*M+NRHS* + $ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, N, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*M+M* + $ ILAENV( 1, 'DORMBR', 'PLN', N, NRHS, M, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*M+WLALSD ) + END IF + MINWRK = MAX( 3*M+NRHS, 3*M+M, 3*M+WLALSD ) + END IF + MINWRK = MIN( MINWRK, MAXWRK ) + WORK( 1 ) = MAXWRK + IWORK( 1 ) = LIWORK + + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGELSD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + GO TO 10 + END IF +* +* Quick return if possible. +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + RANK = 0 + RETURN + END IF +* +* Get machine parameters. +* + EPS = DLAMCH( 'P' ) + SFMIN = DLAMCH( 'S' ) + SMLNUM = SFMIN / EPS + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +* +* Scale A if max entry outside range [SMLNUM,BIGNUM]. +* + ANRM = DLANGE( 'M', M, N, A, LDA, WORK ) + IASCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM. +* + CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) + IASCL = 1 + ELSE IF( ANRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM. +* + CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) + IASCL = 2 + ELSE IF( ANRM.EQ.ZERO ) THEN +* +* Matrix all zero. Return zero solution. +* + CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) + CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 ) + RANK = 0 + GO TO 10 + END IF +* +* Scale B if max entry outside range [SMLNUM,BIGNUM]. +* + BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK ) + IBSCL = 0 + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM. +* + CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO ) + IBSCL = 1 + ELSE IF( BNRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM. +* + CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO ) + IBSCL = 2 + END IF +* +* If M < N make sure certain entries of B are zero. +* + IF( M.LT.N ) + $ CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB ) +* +* Overdetermined case. +* + IF( M.GE.N ) THEN +* +* Path 1 - overdetermined or exactly determined. +* + MM = M + IF( M.GE.MNTHR ) THEN +* +* Path 1a - overdetermined, with many more rows than columns. +* + MM = N + ITAU = 1 + NWORK = ITAU + N +* +* Compute A=Q*R. +* (Workspace: need 2*N, prefer N+N*NB) +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), + $ LWORK-NWORK+1, INFO ) +* +* Multiply B by transpose(Q). +* (Workspace: need N+NRHS, prefer N+NRHS*NB) +* + CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B, + $ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) +* +* Zero out below R. +* + IF( N.GT.1 ) THEN + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA ) + END IF + END IF +* + IE = 1 + ITAUQ = IE + N + ITAUP = ITAUQ + N + NWORK = ITAUP + N +* +* Bidiagonalize R in A. +* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) +* + CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, + $ INFO ) +* +* Multiply B by transpose of left bidiagonalizing vectors of R. +* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) +* + CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ), + $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) +* +* Solve the bidiagonal least squares problem. +* + CALL DLALSD( 'U', SMLSIZ, N, NRHS, S, WORK( IE ), B, LDB, + $ RCOND, RANK, WORK( NWORK ), IWORK, INFO ) + IF( INFO.NE.0 ) THEN + GO TO 10 + END IF +* +* Multiply B by right bidiagonalizing vectors of R. +* + CALL DORMBR( 'P', 'L', 'N', N, NRHS, N, A, LDA, WORK( ITAUP ), + $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) +* + ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+ + $ MAX( M, 2*M-4, NRHS, N-3*M, WLALSD ) ) THEN +* +* Path 2a - underdetermined, with many more columns than rows +* and sufficient workspace for an efficient algorithm. +* + LDWORK = M + IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ), + $ M*LDA+M+M*NRHS, 4*M+M*LDA+WLALSD ) )LDWORK = LDA + ITAU = 1 + NWORK = M + 1 +* +* Compute A=L*Q. +* (Workspace: need 2*M, prefer M+M*NB) +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), + $ LWORK-NWORK+1, INFO ) + IL = NWORK +* +* Copy L to WORK(IL), zeroing out above its diagonal. +* + CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK ) + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ), + $ LDWORK ) + IE = IL + LDWORK*M + ITAUQ = IE + M + ITAUP = ITAUQ + M + NWORK = ITAUP + M +* +* Bidiagonalize L in WORK(IL). +* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) +* + CALL DGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), + $ LWORK-NWORK+1, INFO ) +* +* Multiply B by transpose of left bidiagonalizing vectors of L. +* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) +* + CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK, + $ WORK( ITAUQ ), B, LDB, WORK( NWORK ), + $ LWORK-NWORK+1, INFO ) +* +* Solve the bidiagonal least squares problem. +* + CALL DLALSD( 'U', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB, + $ RCOND, RANK, WORK( NWORK ), IWORK, INFO ) + IF( INFO.NE.0 ) THEN + GO TO 10 + END IF +* +* Multiply B by right bidiagonalizing vectors of L. +* + CALL DORMBR( 'P', 'L', 'N', M, NRHS, M, WORK( IL ), LDWORK, + $ WORK( ITAUP ), B, LDB, WORK( NWORK ), + $ LWORK-NWORK+1, INFO ) +* +* Zero out below first M rows of B. +* + CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB ) + NWORK = ITAU + M +* +* Multiply transpose(Q) by B. +* (Workspace: need M+NRHS, prefer M+NRHS*NB) +* + CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B, + $ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) +* + ELSE +* +* Path 2 - remaining underdetermined cases. +* + IE = 1 + ITAUQ = IE + M + ITAUP = ITAUQ + M + NWORK = ITAUP + M +* +* Bidiagonalize A. +* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) +* + CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, + $ INFO ) +* +* Multiply B by transpose of left bidiagonalizing vectors. +* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) +* + CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ), + $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) +* +* Solve the bidiagonal least squares problem. +* + CALL DLALSD( 'L', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB, + $ RCOND, RANK, WORK( NWORK ), IWORK, INFO ) + IF( INFO.NE.0 ) THEN + GO TO 10 + END IF +* +* Multiply B by right bidiagonalizing vectors of A. +* + CALL DORMBR( 'P', 'L', 'N', N, NRHS, M, A, LDA, WORK( ITAUP ), + $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) +* + END IF +* +* Undo scaling. +* + IF( IASCL.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO ) + CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, + $ INFO ) + ELSE IF( IASCL.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO ) + CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, + $ INFO ) + END IF + IF( IBSCL.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO ) + ELSE IF( IBSCL.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO ) + END IF +* + 10 CONTINUE + WORK( 1 ) = MAXWRK + IWORK( 1 ) = LIWORK + RETURN +* +* End of DGELSD +* + END diff --git a/lib/linalg/dgelss.f b/lib/linalg/dgelss.f new file mode 100644 index 0000000000..674a7ba784 --- /dev/null +++ b/lib/linalg/dgelss.f @@ -0,0 +1,747 @@ +*> \brief DGELSS solves overdetermined or underdetermined systems for GE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGELSS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK +* DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGELSS computes the minimum norm solution to a real linear least +*> squares problem: +*> +*> Minimize 2-norm(| b - A*x |). +*> +*> using the singular value decomposition (SVD) of A. A is an M-by-N +*> matrix which may be rank-deficient. +*> +*> Several right hand side vectors b and solution vectors x can be +*> handled in a single call; they are stored as the columns of the +*> M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix +*> X. +*> +*> The effective rank of A is determined by treating as zero those +*> singular values which are less than RCOND times the largest singular +*> value. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrices B and X. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the first min(m,n) rows of A are overwritten with +*> its right singular vectors, stored rowwise. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the M-by-NRHS right hand side matrix B. +*> On exit, B is overwritten by the N-by-NRHS solution +*> matrix X. If m >= n and RANK = n, the residual +*> sum-of-squares for the solution in the i-th column is given +*> by the sum of squares of elements n+1:m in that column. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,max(M,N)). +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (min(M,N)) +*> The singular values of A in decreasing order. +*> The condition number of A in the 2-norm = S(1)/S(min(m,n)). +*> \endverbatim +*> +*> \param[in] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> RCOND is used to determine the effective rank of A. +*> Singular values S(i) <= RCOND*S(1) are treated as zero. +*> If RCOND < 0, machine precision is used instead. +*> \endverbatim +*> +*> \param[out] RANK +*> \verbatim +*> RANK is INTEGER +*> The effective rank of A, i.e., the number of singular values +*> which are greater than RCOND*S(1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 1, and also: +*> LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS ) +*> For good performance, LWORK should generally be larger. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: the algorithm for computing the SVD failed to converge; +*> if INFO = i, i off-diagonal elements of an intermediate +*> bidiagonal form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEsolve +* +* ===================================================================== + SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, + $ WORK, LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER BDSPAC, BL, CHUNK, I, IASCL, IBSCL, IE, IL, + $ ITAU, ITAUP, ITAUQ, IWORK, LDWORK, MAXMN, + $ MAXWRK, MINMN, MINWRK, MM, MNTHR + INTEGER LWORK_DGEQRF, LWORK_DORMQR, LWORK_DGEBRD, + $ LWORK_DORMBR, LWORK_DORGBR, LWORK_DORMLQ, + $ LWORK_DGELQF + DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM, THR +* .. +* .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DBDSQR, DCOPY, DGEBRD, DGELQF, DGEMM, DGEMV, + $ DGEQRF, DLABAD, DLACPY, DLASCL, DLASET, DORGBR, + $ DORMBR, DORMLQ, DORMQR, DRSCL, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL ILAENV, DLAMCH, DLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + MINMN = MIN( M, N ) + MAXMN = MAX( M, N ) + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* (Note: Comments in the code beginning "Workspace:" describe the +* minimal amount of workspace needed at that point in the code, +* as well as the preferred amount for good performance. +* NB refers to the optimal block size for the immediately +* following subroutine, as returned by ILAENV.) +* + IF( INFO.EQ.0 ) THEN + MINWRK = 1 + MAXWRK = 1 + IF( MINMN.GT.0 ) THEN + MM = M + MNTHR = ILAENV( 6, 'DGELSS', ' ', M, N, NRHS, -1 ) + IF( M.GE.N .AND. M.GE.MNTHR ) THEN +* +* Path 1a - overdetermined, with many more rows than +* columns +* +* Compute space needed for DGEQRF + CALL DGEQRF( M, N, A, LDA, DUM(1), DUM(1), -1, INFO ) + LWORK_DGEQRF=DUM(1) +* Compute space needed for DORMQR + CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, DUM(1), B, + $ LDB, DUM(1), -1, INFO ) + LWORK_DORMQR=DUM(1) + MM = N + MAXWRK = MAX( MAXWRK, N + LWORK_DGEQRF ) + MAXWRK = MAX( MAXWRK, N + LWORK_DORMQR ) + END IF + IF( M.GE.N ) THEN +* +* Path 1 - overdetermined or exactly determined +* +* Compute workspace needed for DBDSQR +* + BDSPAC = MAX( 1, 5*N ) +* Compute space needed for DGEBRD + CALL DGEBRD( MM, N, A, LDA, S, DUM(1), DUM(1), + $ DUM(1), DUM(1), -1, INFO ) + LWORK_DGEBRD=DUM(1) +* Compute space needed for DORMBR + CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, DUM(1), + $ B, LDB, DUM(1), -1, INFO ) + LWORK_DORMBR=DUM(1) +* Compute space needed for DORGBR + CALL DORGBR( 'P', N, N, N, A, LDA, DUM(1), + $ DUM(1), -1, INFO ) + LWORK_DORGBR=DUM(1) +* Compute total workspace needed + MAXWRK = MAX( MAXWRK, 3*N + LWORK_DGEBRD ) + MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORMBR ) + MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR ) + MAXWRK = MAX( MAXWRK, BDSPAC ) + MAXWRK = MAX( MAXWRK, N*NRHS ) + MINWRK = MAX( 3*N + MM, 3*N + NRHS, BDSPAC ) + MAXWRK = MAX( MINWRK, MAXWRK ) + END IF + IF( N.GT.M ) THEN +* +* Compute workspace needed for DBDSQR +* + BDSPAC = MAX( 1, 5*M ) + MINWRK = MAX( 3*M+NRHS, 3*M+N, BDSPAC ) + IF( N.GE.MNTHR ) THEN +* +* Path 2a - underdetermined, with many more columns +* than rows +* +* Compute space needed for DGELQF + CALL DGELQF( M, N, A, LDA, DUM(1), DUM(1), + $ -1, INFO ) + LWORK_DGELQF=DUM(1) +* Compute space needed for DGEBRD + CALL DGEBRD( M, M, A, LDA, S, DUM(1), DUM(1), + $ DUM(1), DUM(1), -1, INFO ) + LWORK_DGEBRD=DUM(1) +* Compute space needed for DORMBR + CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, + $ DUM(1), B, LDB, DUM(1), -1, INFO ) + LWORK_DORMBR=DUM(1) +* Compute space needed for DORGBR + CALL DORGBR( 'P', M, M, M, A, LDA, DUM(1), + $ DUM(1), -1, INFO ) + LWORK_DORGBR=DUM(1) +* Compute space needed for DORMLQ + CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, DUM(1), + $ B, LDB, DUM(1), -1, INFO ) + LWORK_DORMLQ=DUM(1) +* Compute total workspace needed + MAXWRK = M + LWORK_DGELQF + MAXWRK = MAX( MAXWRK, M*M + 4*M + LWORK_DGEBRD ) + MAXWRK = MAX( MAXWRK, M*M + 4*M + LWORK_DORMBR ) + MAXWRK = MAX( MAXWRK, M*M + 4*M + LWORK_DORGBR ) + MAXWRK = MAX( MAXWRK, M*M + M + BDSPAC ) + IF( NRHS.GT.1 ) THEN + MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS ) + ELSE + MAXWRK = MAX( MAXWRK, M*M + 2*M ) + END IF + MAXWRK = MAX( MAXWRK, M + LWORK_DORMLQ ) + ELSE +* +* Path 2 - underdetermined +* +* Compute space needed for DGEBRD + CALL DGEBRD( M, N, A, LDA, S, DUM(1), DUM(1), + $ DUM(1), DUM(1), -1, INFO ) + LWORK_DGEBRD=DUM(1) +* Compute space needed for DORMBR + CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, A, LDA, + $ DUM(1), B, LDB, DUM(1), -1, INFO ) + LWORK_DORMBR=DUM(1) +* Compute space needed for DORGBR + CALL DORGBR( 'P', M, N, M, A, LDA, DUM(1), + $ DUM(1), -1, INFO ) + LWORK_DORGBR=DUM(1) + MAXWRK = 3*M + LWORK_DGEBRD + MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORMBR ) + MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR ) + MAXWRK = MAX( MAXWRK, BDSPAC ) + MAXWRK = MAX( MAXWRK, N*NRHS ) + END IF + END IF + MAXWRK = MAX( MINWRK, MAXWRK ) + END IF + WORK( 1 ) = MAXWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) + $ INFO = -12 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGELSS', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + RANK = 0 + RETURN + END IF +* +* Get machine parameters +* + EPS = DLAMCH( 'P' ) + SFMIN = DLAMCH( 'S' ) + SMLNUM = SFMIN / EPS + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = DLANGE( 'M', M, N, A, LDA, WORK ) + IASCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM +* + CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) + IASCL = 1 + ELSE IF( ANRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM +* + CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) + IASCL = 2 + ELSE IF( ANRM.EQ.ZERO ) THEN +* +* Matrix all zero. Return zero solution. +* + CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) + CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, MINMN ) + RANK = 0 + GO TO 70 + END IF +* +* Scale B if max element outside range [SMLNUM,BIGNUM] +* + BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK ) + IBSCL = 0 + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM +* + CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO ) + IBSCL = 1 + ELSE IF( BNRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM +* + CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO ) + IBSCL = 2 + END IF +* +* Overdetermined case +* + IF( M.GE.N ) THEN +* +* Path 1 - overdetermined or exactly determined +* + MM = M + IF( M.GE.MNTHR ) THEN +* +* Path 1a - overdetermined, with many more rows than columns +* + MM = N + ITAU = 1 + IWORK = ITAU + N +* +* Compute A=Q*R +* (Workspace: need 2*N, prefer N+N*NB) +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), + $ LWORK-IWORK+1, INFO ) +* +* Multiply B by transpose(Q) +* (Workspace: need N+NRHS, prefer N+NRHS*NB) +* + CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B, + $ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) +* +* Zero out below R +* + IF( N.GT.1 ) + $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA ) + END IF +* + IE = 1 + ITAUQ = IE + N + ITAUP = ITAUQ + N + IWORK = ITAUP + N +* +* Bidiagonalize R in A +* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) +* + CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, + $ INFO ) +* +* Multiply B by transpose of left bidiagonalizing vectors of R +* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) +* + CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ), + $ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) +* +* Generate right bidiagonalizing vectors of R in A +* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* + CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, INFO ) + IWORK = IE + N +* +* Perform bidiagonal QR iteration +* multiply B by transpose of left singular vectors +* compute right singular vectors in A +* (Workspace: need BDSPAC) +* + CALL DBDSQR( 'U', N, N, 0, NRHS, S, WORK( IE ), A, LDA, DUM, + $ 1, B, LDB, WORK( IWORK ), INFO ) + IF( INFO.NE.0 ) + $ GO TO 70 +* +* Multiply B by reciprocals of singular values +* + THR = MAX( RCOND*S( 1 ), SFMIN ) + IF( RCOND.LT.ZERO ) + $ THR = MAX( EPS*S( 1 ), SFMIN ) + RANK = 0 + DO 10 I = 1, N + IF( S( I ).GT.THR ) THEN + CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB ) + RANK = RANK + 1 + ELSE + CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) + END IF + 10 CONTINUE +* +* Multiply B by right singular vectors +* (Workspace: need N, prefer N*NRHS) +* + IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN + CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, A, LDA, B, LDB, ZERO, + $ WORK, LDB ) + CALL DLACPY( 'G', N, NRHS, WORK, LDB, B, LDB ) + ELSE IF( NRHS.GT.1 ) THEN + CHUNK = LWORK / N + DO 20 I = 1, NRHS, CHUNK + BL = MIN( NRHS-I+1, CHUNK ) + CALL DGEMM( 'T', 'N', N, BL, N, ONE, A, LDA, B( 1, I ), + $ LDB, ZERO, WORK, N ) + CALL DLACPY( 'G', N, BL, WORK, N, B( 1, I ), LDB ) + 20 CONTINUE + ELSE + CALL DGEMV( 'T', N, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 ) + CALL DCOPY( N, WORK, 1, B, 1 ) + END IF +* + ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+ + $ MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN +* +* Path 2a - underdetermined, with many more columns than rows +* and sufficient workspace for an efficient algorithm +* + LDWORK = M + IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ), + $ M*LDA+M+M*NRHS ) )LDWORK = LDA + ITAU = 1 + IWORK = M + 1 +* +* Compute A=L*Q +* (Workspace: need 2*M, prefer M+M*NB) +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), + $ LWORK-IWORK+1, INFO ) + IL = IWORK +* +* Copy L to WORK(IL), zeroing out above it +* + CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK ) + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ), + $ LDWORK ) + IE = IL + LDWORK*M + ITAUQ = IE + M + ITAUP = ITAUQ + M + IWORK = ITAUP + M +* +* Bidiagonalize L in WORK(IL) +* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) +* + CALL DGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), WORK( IWORK ), + $ LWORK-IWORK+1, INFO ) +* +* Multiply B by transpose of left bidiagonalizing vectors of L +* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) +* + CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK, + $ WORK( ITAUQ ), B, LDB, WORK( IWORK ), + $ LWORK-IWORK+1, INFO ) +* +* Generate right bidiagonalizing vectors of R in WORK(IL) +* (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB) +* + CALL DORGBR( 'P', M, M, M, WORK( IL ), LDWORK, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, INFO ) + IWORK = IE + M +* +* Perform bidiagonal QR iteration, +* computing right singular vectors of L in WORK(IL) and +* multiplying B by transpose of left singular vectors +* (Workspace: need M*M+M+BDSPAC) +* + CALL DBDSQR( 'U', M, M, 0, NRHS, S, WORK( IE ), WORK( IL ), + $ LDWORK, A, LDA, B, LDB, WORK( IWORK ), INFO ) + IF( INFO.NE.0 ) + $ GO TO 70 +* +* Multiply B by reciprocals of singular values +* + THR = MAX( RCOND*S( 1 ), SFMIN ) + IF( RCOND.LT.ZERO ) + $ THR = MAX( EPS*S( 1 ), SFMIN ) + RANK = 0 + DO 30 I = 1, M + IF( S( I ).GT.THR ) THEN + CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB ) + RANK = RANK + 1 + ELSE + CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) + END IF + 30 CONTINUE + IWORK = IE +* +* Multiply B by right singular vectors of L in WORK(IL) +* (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS) +* + IF( LWORK.GE.LDB*NRHS+IWORK-1 .AND. NRHS.GT.1 ) THEN + CALL DGEMM( 'T', 'N', M, NRHS, M, ONE, WORK( IL ), LDWORK, + $ B, LDB, ZERO, WORK( IWORK ), LDB ) + CALL DLACPY( 'G', M, NRHS, WORK( IWORK ), LDB, B, LDB ) + ELSE IF( NRHS.GT.1 ) THEN + CHUNK = ( LWORK-IWORK+1 ) / M + DO 40 I = 1, NRHS, CHUNK + BL = MIN( NRHS-I+1, CHUNK ) + CALL DGEMM( 'T', 'N', M, BL, M, ONE, WORK( IL ), LDWORK, + $ B( 1, I ), LDB, ZERO, WORK( IWORK ), M ) + CALL DLACPY( 'G', M, BL, WORK( IWORK ), M, B( 1, I ), + $ LDB ) + 40 CONTINUE + ELSE + CALL DGEMV( 'T', M, M, ONE, WORK( IL ), LDWORK, B( 1, 1 ), + $ 1, ZERO, WORK( IWORK ), 1 ) + CALL DCOPY( M, WORK( IWORK ), 1, B( 1, 1 ), 1 ) + END IF +* +* Zero out below first M rows of B +* + CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB ) + IWORK = ITAU + M +* +* Multiply transpose(Q) by B +* (Workspace: need M+NRHS, prefer M+NRHS*NB) +* + CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B, + $ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) +* + ELSE +* +* Path 2 - remaining underdetermined cases +* + IE = 1 + ITAUQ = IE + M + ITAUP = ITAUQ + M + IWORK = ITAUP + M +* +* Bidiagonalize A +* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) +* + CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, + $ INFO ) +* +* Multiply B by transpose of left bidiagonalizing vectors +* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) +* + CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ), + $ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) +* +* Generate right bidiagonalizing vectors in A +* (Workspace: need 4*M, prefer 3*M+M*NB) +* + CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), + $ WORK( IWORK ), LWORK-IWORK+1, INFO ) + IWORK = IE + M +* +* Perform bidiagonal QR iteration, +* computing right singular vectors of A in A and +* multiplying B by transpose of left singular vectors +* (Workspace: need BDSPAC) +* + CALL DBDSQR( 'L', M, N, 0, NRHS, S, WORK( IE ), A, LDA, DUM, + $ 1, B, LDB, WORK( IWORK ), INFO ) + IF( INFO.NE.0 ) + $ GO TO 70 +* +* Multiply B by reciprocals of singular values +* + THR = MAX( RCOND*S( 1 ), SFMIN ) + IF( RCOND.LT.ZERO ) + $ THR = MAX( EPS*S( 1 ), SFMIN ) + RANK = 0 + DO 50 I = 1, M + IF( S( I ).GT.THR ) THEN + CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB ) + RANK = RANK + 1 + ELSE + CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) + END IF + 50 CONTINUE +* +* Multiply B by right singular vectors of A +* (Workspace: need N, prefer N*NRHS) +* + IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN + CALL DGEMM( 'T', 'N', N, NRHS, M, ONE, A, LDA, B, LDB, ZERO, + $ WORK, LDB ) + CALL DLACPY( 'F', N, NRHS, WORK, LDB, B, LDB ) + ELSE IF( NRHS.GT.1 ) THEN + CHUNK = LWORK / N + DO 60 I = 1, NRHS, CHUNK + BL = MIN( NRHS-I+1, CHUNK ) + CALL DGEMM( 'T', 'N', N, BL, M, ONE, A, LDA, B( 1, I ), + $ LDB, ZERO, WORK, N ) + CALL DLACPY( 'F', N, BL, WORK, N, B( 1, I ), LDB ) + 60 CONTINUE + ELSE + CALL DGEMV( 'T', M, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 ) + CALL DCOPY( N, WORK, 1, B, 1 ) + END IF + END IF +* +* Undo scaling +* + IF( IASCL.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO ) + CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, + $ INFO ) + ELSE IF( IASCL.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO ) + CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, + $ INFO ) + END IF + IF( IBSCL.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO ) + ELSE IF( IBSCL.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO ) + END IF +* + 70 CONTINUE + WORK( 1 ) = MAXWRK + RETURN +* +* End of DGELSS +* + END diff --git a/lib/linalg/dlals0.f b/lib/linalg/dlals0.f new file mode 100644 index 0000000000..d4cff166d6 --- /dev/null +++ b/lib/linalg/dlals0.f @@ -0,0 +1,499 @@ +*> \brief \b DLALS0 applies back multiplying factors in solving the least squares problem using divide and conquer SVD approach. Used by sgelsd. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLALS0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, +* PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, +* POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL, +* $ LDGNUM, NL, NR, NRHS, SQRE +* DOUBLE PRECISION C, S +* .. +* .. Array Arguments .. +* INTEGER GIVCOL( LDGCOL, * ), PERM( * ) +* DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), DIFL( * ), +* $ DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ), +* $ POLES( LDGNUM, * ), WORK( * ), Z( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLALS0 applies back the multiplying factors of either the left or the +*> right singular vector matrix of a diagonal matrix appended by a row +*> to the right hand side matrix B in solving the least squares problem +*> using the divide-and-conquer SVD approach. +*> +*> For the left singular vector matrix, three types of orthogonal +*> matrices are involved: +*> +*> (1L) Givens rotations: the number of such rotations is GIVPTR; the +*> pairs of columns/rows they were applied to are stored in GIVCOL; +*> and the C- and S-values of these rotations are stored in GIVNUM. +*> +*> (2L) Permutation. The (NL+1)-st row of B is to be moved to the first +*> row, and for J=2:N, PERM(J)-th row of B is to be moved to the +*> J-th row. +*> +*> (3L) The left singular vector matrix of the remaining matrix. +*> +*> For the right singular vector matrix, four types of orthogonal +*> matrices are involved: +*> +*> (1R) The right singular vector matrix of the remaining matrix. +*> +*> (2R) If SQRE = 1, one extra Givens rotation to generate the right +*> null space. +*> +*> (3R) The inverse transformation of (2L). +*> +*> (4R) The inverse transformation of (1L). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ICOMPQ +*> \verbatim +*> ICOMPQ is INTEGER +*> Specifies whether singular vectors are to be computed in +*> factored form: +*> = 0: Left singular vector matrix. +*> = 1: Right singular vector matrix. +*> \endverbatim +*> +*> \param[in] NL +*> \verbatim +*> NL is INTEGER +*> The row dimension of the upper block. NL >= 1. +*> \endverbatim +*> +*> \param[in] NR +*> \verbatim +*> NR is INTEGER +*> The row dimension of the lower block. NR >= 1. +*> \endverbatim +*> +*> \param[in] SQRE +*> \verbatim +*> SQRE is INTEGER +*> = 0: the lower block is an NR-by-NR square matrix. +*> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. +*> +*> The bidiagonal matrix has row dimension N = NL + NR + 1, +*> and column dimension M = N + SQRE. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of columns of B and BX. NRHS must be at least 1. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension ( LDB, NRHS ) +*> On input, B contains the right hand sides of the least +*> squares problem in rows 1 through M. On output, B contains +*> the solution X in rows 1 through N. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B. LDB must be at least +*> max(1,MAX( M, N ) ). +*> \endverbatim +*> +*> \param[out] BX +*> \verbatim +*> BX is DOUBLE PRECISION array, dimension ( LDBX, NRHS ) +*> \endverbatim +*> +*> \param[in] LDBX +*> \verbatim +*> LDBX is INTEGER +*> The leading dimension of BX. +*> \endverbatim +*> +*> \param[in] PERM +*> \verbatim +*> PERM is INTEGER array, dimension ( N ) +*> The permutations (from deflation and sorting) applied +*> to the two blocks. +*> \endverbatim +*> +*> \param[in] GIVPTR +*> \verbatim +*> GIVPTR is INTEGER +*> The number of Givens rotations which took place in this +*> subproblem. +*> \endverbatim +*> +*> \param[in] GIVCOL +*> \verbatim +*> GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) +*> Each pair of numbers indicates a pair of rows/columns +*> involved in a Givens rotation. +*> \endverbatim +*> +*> \param[in] LDGCOL +*> \verbatim +*> LDGCOL is INTEGER +*> The leading dimension of GIVCOL, must be at least N. +*> \endverbatim +*> +*> \param[in] GIVNUM +*> \verbatim +*> GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) +*> Each number indicates the C or S value used in the +*> corresponding Givens rotation. +*> \endverbatim +*> +*> \param[in] LDGNUM +*> \verbatim +*> LDGNUM is INTEGER +*> The leading dimension of arrays DIFR, POLES and +*> GIVNUM, must be at least K. +*> \endverbatim +*> +*> \param[in] POLES +*> \verbatim +*> POLES is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) +*> On entry, POLES(1:K, 1) contains the new singular +*> values obtained from solving the secular equation, and +*> POLES(1:K, 2) is an array containing the poles in the secular +*> equation. +*> \endverbatim +*> +*> \param[in] DIFL +*> \verbatim +*> DIFL is DOUBLE PRECISION array, dimension ( K ). +*> On entry, DIFL(I) is the distance between I-th updated +*> (undeflated) singular value and the I-th (undeflated) old +*> singular value. +*> \endverbatim +*> +*> \param[in] DIFR +*> \verbatim +*> DIFR is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ). +*> On entry, DIFR(I, 1) contains the distances between I-th +*> updated (undeflated) singular value and the I+1-th +*> (undeflated) old singular value. And DIFR(I, 2) is the +*> normalizing factor for the I-th right singular vector. +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension ( K ) +*> Contain the components of the deflation-adjusted updating row +*> vector. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> Contains the dimension of the non-deflated matrix, +*> This is the order of the related secular equation. 1 <= K <=N. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION +*> C contains garbage if SQRE =0 and the C-value of a Givens +*> rotation related to the right null space if SQRE = 1. +*> \endverbatim +*> +*> \param[in] S +*> \verbatim +*> S is DOUBLE PRECISION +*> S contains garbage if SQRE =0 and the S-value of a Givens +*> rotation related to the right null space if SQRE = 1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension ( K ) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Ren-Cang Li, Computer Science Division, University of +*> California at Berkeley, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +* +* ===================================================================== + SUBROUTINE DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, + $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, + $ POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL, + $ LDGNUM, NL, NR, NRHS, SQRE + DOUBLE PRECISION C, S +* .. +* .. Array Arguments .. + INTEGER GIVCOL( LDGCOL, * ), PERM( * ) + DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), DIFL( * ), + $ DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ), + $ POLES( LDGNUM, * ), WORK( * ), Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO, NEGONE + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, NEGONE = -1.0D0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, M, N, NLP1 + DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DLACPY, DLASCL, DROT, DSCAL, + $ XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3, DNRM2 + EXTERNAL DLAMC3, DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + N = NL + NR + 1 +* + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( NL.LT.1 ) THEN + INFO = -2 + ELSE IF( NR.LT.1 ) THEN + INFO = -3 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -4 + ELSE IF( NRHS.LT.1 ) THEN + INFO = -5 + ELSE IF( LDB.LT.N ) THEN + INFO = -7 + ELSE IF( LDBX.LT.N ) THEN + INFO = -9 + ELSE IF( GIVPTR.LT.0 ) THEN + INFO = -11 + ELSE IF( LDGCOL.LT.N ) THEN + INFO = -13 + ELSE IF( LDGNUM.LT.N ) THEN + INFO = -15 + ELSE IF( K.LT.1 ) THEN + INFO = -20 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLALS0', -INFO ) + RETURN + END IF +* + M = N + SQRE + NLP1 = NL + 1 +* + IF( ICOMPQ.EQ.0 ) THEN +* +* Apply back orthogonal transformations from the left. +* +* Step (1L): apply back the Givens rotations performed. +* + DO 10 I = 1, GIVPTR + CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB, + $ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ), + $ GIVNUM( I, 1 ) ) + 10 CONTINUE +* +* Step (2L): permute rows of B. +* + CALL DCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX ) + DO 20 I = 2, N + CALL DCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX ) + 20 CONTINUE +* +* Step (3L): apply the inverse of the left singular vector +* matrix to BX. +* + IF( K.EQ.1 ) THEN + CALL DCOPY( NRHS, BX, LDBX, B, LDB ) + IF( Z( 1 ).LT.ZERO ) THEN + CALL DSCAL( NRHS, NEGONE, B, LDB ) + END IF + ELSE + DO 50 J = 1, K + DIFLJ = DIFL( J ) + DJ = POLES( J, 1 ) + DSIGJ = -POLES( J, 2 ) + IF( J.LT.K ) THEN + DIFRJ = -DIFR( J, 1 ) + DSIGJP = -POLES( J+1, 2 ) + END IF + IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) ) + $ THEN + WORK( J ) = ZERO + ELSE + WORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ / + $ ( POLES( J, 2 )+DJ ) + END IF + DO 30 I = 1, J - 1 + IF( ( Z( I ).EQ.ZERO ) .OR. + $ ( POLES( I, 2 ).EQ.ZERO ) ) THEN + WORK( I ) = ZERO + ELSE + WORK( I ) = POLES( I, 2 )*Z( I ) / + $ ( DLAMC3( POLES( I, 2 ), DSIGJ )- + $ DIFLJ ) / ( POLES( I, 2 )+DJ ) + END IF + 30 CONTINUE + DO 40 I = J + 1, K + IF( ( Z( I ).EQ.ZERO ) .OR. + $ ( POLES( I, 2 ).EQ.ZERO ) ) THEN + WORK( I ) = ZERO + ELSE + WORK( I ) = POLES( I, 2 )*Z( I ) / + $ ( DLAMC3( POLES( I, 2 ), DSIGJP )+ + $ DIFRJ ) / ( POLES( I, 2 )+DJ ) + END IF + 40 CONTINUE + WORK( 1 ) = NEGONE + TEMP = DNRM2( K, WORK, 1 ) + CALL DGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO, + $ B( J, 1 ), LDB ) + CALL DLASCL( 'G', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ), + $ LDB, INFO ) + 50 CONTINUE + END IF +* +* Move the deflated rows of BX to B also. +* + IF( K.LT.MAX( M, N ) ) + $ CALL DLACPY( 'A', N-K, NRHS, BX( K+1, 1 ), LDBX, + $ B( K+1, 1 ), LDB ) + ELSE +* +* Apply back the right orthogonal transformations. +* +* Step (1R): apply back the new right singular vector matrix +* to B. +* + IF( K.EQ.1 ) THEN + CALL DCOPY( NRHS, B, LDB, BX, LDBX ) + ELSE + DO 80 J = 1, K + DSIGJ = POLES( J, 2 ) + IF( Z( J ).EQ.ZERO ) THEN + WORK( J ) = ZERO + ELSE + WORK( J ) = -Z( J ) / DIFL( J ) / + $ ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 ) + END IF + DO 60 I = 1, J - 1 + IF( Z( J ).EQ.ZERO ) THEN + WORK( I ) = ZERO + ELSE + WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I+1, + $ 2 ) )-DIFR( I, 1 ) ) / + $ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 ) + END IF + 60 CONTINUE + DO 70 I = J + 1, K + IF( Z( J ).EQ.ZERO ) THEN + WORK( I ) = ZERO + ELSE + WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I, + $ 2 ) )-DIFL( I ) ) / + $ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 ) + END IF + 70 CONTINUE + CALL DGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO, + $ BX( J, 1 ), LDBX ) + 80 CONTINUE + END IF +* +* Step (2R): if SQRE = 1, apply back the rotation that is +* related to the right null space of the subproblem. +* + IF( SQRE.EQ.1 ) THEN + CALL DCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX ) + CALL DROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S ) + END IF + IF( K.LT.MAX( M, N ) ) + $ CALL DLACPY( 'A', N-K, NRHS, B( K+1, 1 ), LDB, BX( K+1, 1 ), + $ LDBX ) +* +* Step (3R): permute rows of B. +* + CALL DCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB ) + IF( SQRE.EQ.1 ) THEN + CALL DCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB ) + END IF + DO 90 I = 2, N + CALL DCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB ) + 90 CONTINUE +* +* Step (4R): apply back the Givens rotations performed. +* + DO 100 I = GIVPTR, 1, -1 + CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB, + $ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ), + $ -GIVNUM( I, 1 ) ) + 100 CONTINUE + END IF +* + RETURN +* +* End of DLALS0 +* + END diff --git a/lib/linalg/dlalsa.f b/lib/linalg/dlalsa.f new file mode 100644 index 0000000000..b643f11c0b --- /dev/null +++ b/lib/linalg/dlalsa.f @@ -0,0 +1,493 @@ +*> \brief \b DLALSA computes the SVD of the coefficient matrix in compact form. Used by sgelsd. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLALSA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, +* LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, +* GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, +* IWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS, +* $ SMLSIZ +* .. +* .. Array Arguments .. +* INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), +* $ K( * ), PERM( LDGCOL, * ) +* DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), C( * ), +* $ DIFL( LDU, * ), DIFR( LDU, * ), +* $ GIVNUM( LDU, * ), POLES( LDU, * ), S( * ), +* $ U( LDU, * ), VT( LDU, * ), WORK( * ), +* $ Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLALSA is an itermediate step in solving the least squares problem +*> by computing the SVD of the coefficient matrix in compact form (The +*> singular vectors are computed as products of simple orthorgonal +*> matrices.). +*> +*> If ICOMPQ = 0, DLALSA applies the inverse of the left singular vector +*> matrix of an upper bidiagonal matrix to the right hand side; and if +*> ICOMPQ = 1, DLALSA applies the right singular vector matrix to the +*> right hand side. The singular vector matrices were generated in +*> compact form by DLALSA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ICOMPQ +*> \verbatim +*> ICOMPQ is INTEGER +*> Specifies whether the left or the right singular vector +*> matrix is involved. +*> = 0: Left singular vector matrix +*> = 1: Right singular vector matrix +*> \endverbatim +*> +*> \param[in] SMLSIZ +*> \verbatim +*> SMLSIZ is INTEGER +*> The maximum size of the subproblems at the bottom of the +*> computation tree. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The row and column dimensions of the upper bidiagonal matrix. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of columns of B and BX. NRHS must be at least 1. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension ( LDB, NRHS ) +*> On input, B contains the right hand sides of the least +*> squares problem in rows 1 through M. +*> On output, B contains the solution X in rows 1 through N. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B in the calling subprogram. +*> LDB must be at least max(1,MAX( M, N ) ). +*> \endverbatim +*> +*> \param[out] BX +*> \verbatim +*> BX is DOUBLE PRECISION array, dimension ( LDBX, NRHS ) +*> On exit, the result of applying the left or right singular +*> vector matrix to B. +*> \endverbatim +*> +*> \param[in] LDBX +*> \verbatim +*> LDBX is INTEGER +*> The leading dimension of BX. +*> \endverbatim +*> +*> \param[in] U +*> \verbatim +*> U is DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ). +*> On entry, U contains the left singular vector matrices of all +*> subproblems at the bottom level. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER, LDU = > N. +*> The leading dimension of arrays U, VT, DIFL, DIFR, +*> POLES, GIVNUM, and Z. +*> \endverbatim +*> +*> \param[in] VT +*> \verbatim +*> VT is DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ). +*> On entry, VT**T contains the right singular vector matrices of +*> all subproblems at the bottom level. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER array, dimension ( N ). +*> \endverbatim +*> +*> \param[in] DIFL +*> \verbatim +*> DIFL is DOUBLE PRECISION array, dimension ( LDU, NLVL ). +*> where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1. +*> \endverbatim +*> +*> \param[in] DIFR +*> \verbatim +*> DIFR is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). +*> On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record +*> distances between singular values on the I-th level and +*> singular values on the (I -1)-th level, and DIFR(*, 2 * I) +*> record the normalizing factors of the right singular vectors +*> matrices of subproblems on I-th level. +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension ( LDU, NLVL ). +*> On entry, Z(1, I) contains the components of the deflation- +*> adjusted updating row vector for subproblems on the I-th +*> level. +*> \endverbatim +*> +*> \param[in] POLES +*> \verbatim +*> POLES is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). +*> On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old +*> singular values involved in the secular equations on the I-th +*> level. +*> \endverbatim +*> +*> \param[in] GIVPTR +*> \verbatim +*> GIVPTR is INTEGER array, dimension ( N ). +*> On entry, GIVPTR( I ) records the number of Givens +*> rotations performed on the I-th problem on the computation +*> tree. +*> \endverbatim +*> +*> \param[in] GIVCOL +*> \verbatim +*> GIVCOL is INTEGER array, dimension ( LDGCOL, 2 * NLVL ). +*> On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the +*> locations of Givens rotations performed on the I-th level on +*> the computation tree. +*> \endverbatim +*> +*> \param[in] LDGCOL +*> \verbatim +*> LDGCOL is INTEGER, LDGCOL = > N. +*> The leading dimension of arrays GIVCOL and PERM. +*> \endverbatim +*> +*> \param[in] PERM +*> \verbatim +*> PERM is INTEGER array, dimension ( LDGCOL, NLVL ). +*> On entry, PERM(*, I) records permutations done on the I-th +*> level of the computation tree. +*> \endverbatim +*> +*> \param[in] GIVNUM +*> \verbatim +*> GIVNUM is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). +*> On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S- +*> values of Givens rotations performed on the I-th level on the +*> computation tree. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension ( N ). +*> On entry, if the I-th subproblem is not square, +*> C( I ) contains the C-value of a Givens rotation related to +*> the right null space of the I-th subproblem. +*> \endverbatim +*> +*> \param[in] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension ( N ). +*> On entry, if the I-th subproblem is not square, +*> S( I ) contains the S-value of a Givens rotation related to +*> the right null space of the I-th subproblem. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2017 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Ren-Cang Li, Computer Science Division, University of +*> California at Berkeley, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +* +* ===================================================================== + SUBROUTINE DLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, + $ LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, + $ GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, + $ IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2017 +* +* .. Scalar Arguments .. + INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS, + $ SMLSIZ +* .. +* .. Array Arguments .. + INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), + $ K( * ), PERM( LDGCOL, * ) + DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), C( * ), + $ DIFL( LDU, * ), DIFR( LDU, * ), + $ GIVNUM( LDU, * ), POLES( LDU, * ), S( * ), + $ U( LDU, * ), VT( LDU, * ), WORK( * ), + $ Z( LDU, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + INTEGER I, I1, IC, IM1, INODE, J, LF, LL, LVL, LVL2, + $ ND, NDB1, NDIML, NDIMR, NL, NLF, NLP1, NLVL, + $ NR, NRF, NRP1, SQRE +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLALS0, DLASDT, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( SMLSIZ.LT.3 ) THEN + INFO = -2 + ELSE IF( N.LT.SMLSIZ ) THEN + INFO = -3 + ELSE IF( NRHS.LT.1 ) THEN + INFO = -4 + ELSE IF( LDB.LT.N ) THEN + INFO = -6 + ELSE IF( LDBX.LT.N ) THEN + INFO = -8 + ELSE IF( LDU.LT.N ) THEN + INFO = -10 + ELSE IF( LDGCOL.LT.N ) THEN + INFO = -19 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLALSA', -INFO ) + RETURN + END IF +* +* Book-keeping and setting up the computation tree. +* + INODE = 1 + NDIML = INODE + N + NDIMR = NDIML + N +* + CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ), + $ IWORK( NDIMR ), SMLSIZ ) +* +* The following code applies back the left singular vector factors. +* For applying back the right singular vector factors, go to 50. +* + IF( ICOMPQ.EQ.1 ) THEN + GO TO 50 + END IF +* +* The nodes on the bottom level of the tree were solved +* by DLASDQ. The corresponding left and right singular vector +* matrices are in explicit form. First apply back the left +* singular vector matrices. +* + NDB1 = ( ND+1 ) / 2 + DO 10 I = NDB1, ND +* +* IC : center row of each node +* NL : number of rows of left subproblem +* NR : number of rows of right subproblem +* NLF: starting row of the left subproblem +* NRF: starting row of the right subproblem +* + I1 = I - 1 + IC = IWORK( INODE+I1 ) + NL = IWORK( NDIML+I1 ) + NR = IWORK( NDIMR+I1 ) + NLF = IC - NL + NRF = IC + 1 + CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU, + $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX ) + CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU, + $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX ) + 10 CONTINUE +* +* Next copy the rows of B that correspond to unchanged rows +* in the bidiagonal matrix to BX. +* + DO 20 I = 1, ND + IC = IWORK( INODE+I-1 ) + CALL DCOPY( NRHS, B( IC, 1 ), LDB, BX( IC, 1 ), LDBX ) + 20 CONTINUE +* +* Finally go through the left singular vector matrices of all +* the other subproblems bottom-up on the tree. +* + J = 2**NLVL + SQRE = 0 +* + DO 40 LVL = NLVL, 1, -1 + LVL2 = 2*LVL - 1 +* +* find the first node LF and last node LL on +* the current level LVL +* + IF( LVL.EQ.1 ) THEN + LF = 1 + LL = 1 + ELSE + LF = 2**( LVL-1 ) + LL = 2*LF - 1 + END IF + DO 30 I = LF, LL + IM1 = I - 1 + IC = IWORK( INODE+IM1 ) + NL = IWORK( NDIML+IM1 ) + NR = IWORK( NDIMR+IM1 ) + NLF = IC - NL + NRF = IC + 1 + J = J - 1 + CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, BX( NLF, 1 ), LDBX, + $ B( NLF, 1 ), LDB, PERM( NLF, LVL ), + $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL, + $ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ), + $ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ), + $ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK, + $ INFO ) + 30 CONTINUE + 40 CONTINUE + GO TO 90 +* +* ICOMPQ = 1: applying back the right singular vector factors. +* + 50 CONTINUE +* +* First now go through the right singular vector matrices of all +* the tree nodes top-down. +* + J = 0 + DO 70 LVL = 1, NLVL + LVL2 = 2*LVL - 1 +* +* Find the first node LF and last node LL on +* the current level LVL. +* + IF( LVL.EQ.1 ) THEN + LF = 1 + LL = 1 + ELSE + LF = 2**( LVL-1 ) + LL = 2*LF - 1 + END IF + DO 60 I = LL, LF, -1 + IM1 = I - 1 + IC = IWORK( INODE+IM1 ) + NL = IWORK( NDIML+IM1 ) + NR = IWORK( NDIMR+IM1 ) + NLF = IC - NL + NRF = IC + 1 + IF( I.EQ.LL ) THEN + SQRE = 0 + ELSE + SQRE = 1 + END IF + J = J + 1 + CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B( NLF, 1 ), LDB, + $ BX( NLF, 1 ), LDBX, PERM( NLF, LVL ), + $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL, + $ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ), + $ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ), + $ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK, + $ INFO ) + 60 CONTINUE + 70 CONTINUE +* +* The nodes on the bottom level of the tree were solved +* by DLASDQ. The corresponding right singular vector +* matrices are in explicit form. Apply them back. +* + NDB1 = ( ND+1 ) / 2 + DO 80 I = NDB1, ND + I1 = I - 1 + IC = IWORK( INODE+I1 ) + NL = IWORK( NDIML+I1 ) + NR = IWORK( NDIMR+I1 ) + NLP1 = NL + 1 + IF( I.EQ.ND ) THEN + NRP1 = NR + ELSE + NRP1 = NR + 1 + END IF + NLF = IC - NL + NRF = IC + 1 + CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU, + $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX ) + CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU, + $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX ) + 80 CONTINUE +* + 90 CONTINUE +* + RETURN +* +* End of DLALSA +* + END diff --git a/lib/linalg/dlalsd.f b/lib/linalg/dlalsd.f new file mode 100644 index 0000000000..510e0455a6 --- /dev/null +++ b/lib/linalg/dlalsd.f @@ -0,0 +1,523 @@ +*> \brief \b DLALSD uses the singular value decomposition of A to solve the least squares problem. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLALSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, +* RANK, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ +* DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLALSD uses the singular value decomposition of A to solve the least +*> squares problem of finding X to minimize the Euclidean norm of each +*> column of A*X-B, where A is N-by-N upper bidiagonal, and X and B +*> are N-by-NRHS. The solution X overwrites B. +*> +*> The singular values of A smaller than RCOND times the largest +*> singular value are treated as zero in solving the least squares +*> problem; in this case a minimum norm solution is returned. +*> The actual singular values are returned in D in ascending order. +*> +*> This code makes very mild assumptions about floating point +*> arithmetic. It will work on machines with a guard digit in +*> add/subtract, or on those binary machines without guard digits +*> which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. +*> It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': D and E define an upper bidiagonal matrix. +*> = 'L': D and E define a lower bidiagonal matrix. +*> \endverbatim +*> +*> \param[in] SMLSIZ +*> \verbatim +*> SMLSIZ is INTEGER +*> The maximum size of the subproblems at the bottom of the +*> computation tree. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The dimension of the bidiagonal matrix. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of columns of B. NRHS must be at least 1. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry D contains the main diagonal of the bidiagonal +*> matrix. On exit, if INFO = 0, D contains its singular values. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> Contains the super-diagonal entries of the bidiagonal matrix. +*> On exit, E has been destroyed. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On input, B contains the right hand sides of the least +*> squares problem. On output, B contains the solution X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B in the calling subprogram. +*> LDB must be at least max(1,N). +*> \endverbatim +*> +*> \param[in] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The singular values of A less than or equal to RCOND times +*> the largest singular value are treated as zero in solving +*> the least squares problem. If RCOND is negative, +*> machine precision is used instead. +*> For example, if diag(S)*X=B were the least squares problem, +*> where diag(S) is a diagonal matrix of singular values, the +*> solution would be X(i) = B(i) / S(i) if S(i) is greater than +*> RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to +*> RCOND*max(S). +*> \endverbatim +*> +*> \param[out] RANK +*> \verbatim +*> RANK is INTEGER +*> The number of singular values of A greater than RCOND times +*> the largest singular value. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension at least +*> (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2), +*> where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1). +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension at least +*> (3*N*NLVL + 11*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: The algorithm failed to compute a singular value while +*> working on the submatrix lying in rows and columns +*> INFO/(N+1) through MOD(INFO,N+1). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Ren-Cang Li, Computer Science Division, University of +*> California at Berkeley, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +* +* ===================================================================== + SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, + $ RANK, WORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +* .. +* .. Local Scalars .. + INTEGER BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM, + $ GIVPTR, I, ICMPQ1, ICMPQ2, IWK, J, K, NLVL, + $ NM1, NSIZE, NSUB, NWORK, PERM, POLES, S, SIZEI, + $ SMLSZP, SQRE, ST, ST1, U, VT, Z + DOUBLE PRECISION CS, EPS, ORGNRM, R, RCND, SN, TOL +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DLANST + EXTERNAL IDAMAX, DLAMCH, DLANST +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLACPY, DLALSA, DLARTG, DLASCL, + $ DLASDA, DLASDQ, DLASET, DLASRT, DROT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, LOG, SIGN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.1 ) THEN + INFO = -4 + ELSE IF( ( LDB.LT.1 ) .OR. ( LDB.LT.N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLALSD', -INFO ) + RETURN + END IF +* + EPS = DLAMCH( 'Epsilon' ) +* +* Set up the tolerance. +* + IF( ( RCOND.LE.ZERO ) .OR. ( RCOND.GE.ONE ) ) THEN + RCND = EPS + ELSE + RCND = RCOND + END IF +* + RANK = 0 +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + RETURN + ELSE IF( N.EQ.1 ) THEN + IF( D( 1 ).EQ.ZERO ) THEN + CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B, LDB ) + ELSE + RANK = 1 + CALL DLASCL( 'G', 0, 0, D( 1 ), ONE, 1, NRHS, B, LDB, INFO ) + D( 1 ) = ABS( D( 1 ) ) + END IF + RETURN + END IF +* +* Rotate the matrix if it is lower bidiagonal. +* + IF( UPLO.EQ.'L' ) THEN + DO 10 I = 1, N - 1 + CALL DLARTG( D( I ), E( I ), CS, SN, R ) + D( I ) = R + E( I ) = SN*D( I+1 ) + D( I+1 ) = CS*D( I+1 ) + IF( NRHS.EQ.1 ) THEN + CALL DROT( 1, B( I, 1 ), 1, B( I+1, 1 ), 1, CS, SN ) + ELSE + WORK( I*2-1 ) = CS + WORK( I*2 ) = SN + END IF + 10 CONTINUE + IF( NRHS.GT.1 ) THEN + DO 30 I = 1, NRHS + DO 20 J = 1, N - 1 + CS = WORK( J*2-1 ) + SN = WORK( J*2 ) + CALL DROT( 1, B( J, I ), 1, B( J+1, I ), 1, CS, SN ) + 20 CONTINUE + 30 CONTINUE + END IF + END IF +* +* Scale. +* + NM1 = N - 1 + ORGNRM = DLANST( 'M', N, D, E ) + IF( ORGNRM.EQ.ZERO ) THEN + CALL DLASET( 'A', N, NRHS, ZERO, ZERO, B, LDB ) + RETURN + END IF +* + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO ) + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, INFO ) +* +* If N is smaller than the minimum divide size SMLSIZ, then solve +* the problem with another solver. +* + IF( N.LE.SMLSIZ ) THEN + NWORK = 1 + N*N + CALL DLASET( 'A', N, N, ZERO, ONE, WORK, N ) + CALL DLASDQ( 'U', 0, N, N, 0, NRHS, D, E, WORK, N, WORK, N, B, + $ LDB, WORK( NWORK ), INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) ) + DO 40 I = 1, N + IF( D( I ).LE.TOL ) THEN + CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) + ELSE + CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, B( I, 1 ), + $ LDB, INFO ) + RANK = RANK + 1 + END IF + 40 CONTINUE + CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO, + $ WORK( NWORK ), N ) + CALL DLACPY( 'A', N, NRHS, WORK( NWORK ), N, B, LDB ) +* +* Unscale. +* + CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) + CALL DLASRT( 'D', N, D, INFO ) + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO ) +* + RETURN + END IF +* +* Book-keeping and setting up some constants. +* + NLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1 +* + SMLSZP = SMLSIZ + 1 +* + U = 1 + VT = 1 + SMLSIZ*N + DIFL = VT + SMLSZP*N + DIFR = DIFL + NLVL*N + Z = DIFR + NLVL*N*2 + C = Z + NLVL*N + S = C + N + POLES = S + N + GIVNUM = POLES + 2*NLVL*N + BX = GIVNUM + 2*NLVL*N + NWORK = BX + N*NRHS +* + SIZEI = 1 + N + K = SIZEI + N + GIVPTR = K + N + PERM = GIVPTR + N + GIVCOL = PERM + NLVL*N + IWK = GIVCOL + NLVL*N*2 +* + ST = 1 + SQRE = 0 + ICMPQ1 = 1 + ICMPQ2 = 0 + NSUB = 0 +* + DO 50 I = 1, N + IF( ABS( D( I ) ).LT.EPS ) THEN + D( I ) = SIGN( EPS, D( I ) ) + END IF + 50 CONTINUE +* + DO 60 I = 1, NM1 + IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN + NSUB = NSUB + 1 + IWORK( NSUB ) = ST +* +* Subproblem found. First determine its size and then +* apply divide and conquer on it. +* + IF( I.LT.NM1 ) THEN +* +* A subproblem with E(I) small for I < NM1. +* + NSIZE = I - ST + 1 + IWORK( SIZEI+NSUB-1 ) = NSIZE + ELSE IF( ABS( E( I ) ).GE.EPS ) THEN +* +* A subproblem with E(NM1) not too small but I = NM1. +* + NSIZE = N - ST + 1 + IWORK( SIZEI+NSUB-1 ) = NSIZE + ELSE +* +* A subproblem with E(NM1) small. This implies an +* 1-by-1 subproblem at D(N), which is not solved +* explicitly. +* + NSIZE = I - ST + 1 + IWORK( SIZEI+NSUB-1 ) = NSIZE + NSUB = NSUB + 1 + IWORK( NSUB ) = N + IWORK( SIZEI+NSUB-1 ) = 1 + CALL DCOPY( NRHS, B( N, 1 ), LDB, WORK( BX+NM1 ), N ) + END IF + ST1 = ST - 1 + IF( NSIZE.EQ.1 ) THEN +* +* This is a 1-by-1 subproblem and is not solved +* explicitly. +* + CALL DCOPY( NRHS, B( ST, 1 ), LDB, WORK( BX+ST1 ), N ) + ELSE IF( NSIZE.LE.SMLSIZ ) THEN +* +* This is a small subproblem and is solved by DLASDQ. +* + CALL DLASET( 'A', NSIZE, NSIZE, ZERO, ONE, + $ WORK( VT+ST1 ), N ) + CALL DLASDQ( 'U', 0, NSIZE, NSIZE, 0, NRHS, D( ST ), + $ E( ST ), WORK( VT+ST1 ), N, WORK( NWORK ), + $ N, B( ST, 1 ), LDB, WORK( NWORK ), INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + CALL DLACPY( 'A', NSIZE, NRHS, B( ST, 1 ), LDB, + $ WORK( BX+ST1 ), N ) + ELSE +* +* A large problem. Solve it using divide and conquer. +* + CALL DLASDA( ICMPQ1, SMLSIZ, NSIZE, SQRE, D( ST ), + $ E( ST ), WORK( U+ST1 ), N, WORK( VT+ST1 ), + $ IWORK( K+ST1 ), WORK( DIFL+ST1 ), + $ WORK( DIFR+ST1 ), WORK( Z+ST1 ), + $ WORK( POLES+ST1 ), IWORK( GIVPTR+ST1 ), + $ IWORK( GIVCOL+ST1 ), N, IWORK( PERM+ST1 ), + $ WORK( GIVNUM+ST1 ), WORK( C+ST1 ), + $ WORK( S+ST1 ), WORK( NWORK ), IWORK( IWK ), + $ INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + BXST = BX + ST1 + CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, B( ST, 1 ), + $ LDB, WORK( BXST ), N, WORK( U+ST1 ), N, + $ WORK( VT+ST1 ), IWORK( K+ST1 ), + $ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ), + $ WORK( Z+ST1 ), WORK( POLES+ST1 ), + $ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N, + $ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ), + $ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ), + $ IWORK( IWK ), INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + END IF + ST = I + 1 + END IF + 60 CONTINUE +* +* Apply the singular values and treat the tiny ones as zero. +* + TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) ) +* + DO 70 I = 1, N +* +* Some of the elements in D can be negative because 1-by-1 +* subproblems were not solved explicitly. +* + IF( ABS( D( I ) ).LE.TOL ) THEN + CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, WORK( BX+I-1 ), N ) + ELSE + RANK = RANK + 1 + CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, + $ WORK( BX+I-1 ), N, INFO ) + END IF + D( I ) = ABS( D( I ) ) + 70 CONTINUE +* +* Now apply back the right singular vectors. +* + ICMPQ2 = 1 + DO 80 I = 1, NSUB + ST = IWORK( I ) + ST1 = ST - 1 + NSIZE = IWORK( SIZEI+I-1 ) + BXST = BX + ST1 + IF( NSIZE.EQ.1 ) THEN + CALL DCOPY( NRHS, WORK( BXST ), N, B( ST, 1 ), LDB ) + ELSE IF( NSIZE.LE.SMLSIZ ) THEN + CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE, + $ WORK( VT+ST1 ), N, WORK( BXST ), N, ZERO, + $ B( ST, 1 ), LDB ) + ELSE + CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, WORK( BXST ), N, + $ B( ST, 1 ), LDB, WORK( U+ST1 ), N, + $ WORK( VT+ST1 ), IWORK( K+ST1 ), + $ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ), + $ WORK( Z+ST1 ), WORK( POLES+ST1 ), + $ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N, + $ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ), + $ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ), + $ IWORK( IWK ), INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + END IF + 80 CONTINUE +* +* Unscale and sort the singular values. +* + CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) + CALL DLASRT( 'D', N, D, INFO ) + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO ) +* + RETURN +* +* End of DLALSD +* + END diff --git a/lib/linalg/dlasd4.f b/lib/linalg/dlasd4.f new file mode 100644 index 0000000000..8b4a8762c8 --- /dev/null +++ b/lib/linalg/dlasd4.f @@ -0,0 +1,1061 @@ +*> \brief \b DLASD4 computes the square root of the i-th updated eigenvalue of a positive symmetric rank-one modification to a positive diagonal matrix. Used by dbdsdc. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASD4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER I, INFO, N +* DOUBLE PRECISION RHO, SIGMA +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), DELTA( * ), WORK( * ), Z( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This subroutine computes the square root of the I-th updated +*> eigenvalue of a positive symmetric rank-one modification to +*> a positive diagonal matrix whose entries are given as the squares +*> of the corresponding entries in the array d, and that +*> +*> 0 <= D(i) < D(j) for i < j +*> +*> and that RHO > 0. This is arranged by the calling routine, and is +*> no loss in generality. The rank-one modified system is thus +*> +*> diag( D ) * diag( D ) + RHO * Z * Z_transpose. +*> +*> where we assume the Euclidean norm of Z is 1. +*> +*> The method consists of approximating the rational functions in the +*> secular equation by simpler interpolating rational functions. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The length of all arrays. +*> \endverbatim +*> +*> \param[in] I +*> \verbatim +*> I is INTEGER +*> The index of the eigenvalue to be computed. 1 <= I <= N. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension ( N ) +*> The original eigenvalues. It is assumed that they are in +*> order, 0 <= D(I) < D(J) for I < J. +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension ( N ) +*> The components of the updating vector. +*> \endverbatim +*> +*> \param[out] DELTA +*> \verbatim +*> DELTA is DOUBLE PRECISION array, dimension ( N ) +*> If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th +*> component. If N = 1, then DELTA(1) = 1. The vector DELTA +*> contains the information necessary to construct the +*> (singular) eigenvectors. +*> \endverbatim +*> +*> \param[in] RHO +*> \verbatim +*> RHO is DOUBLE PRECISION +*> The scalar in the symmetric updating formula. +*> \endverbatim +*> +*> \param[out] SIGMA +*> \verbatim +*> SIGMA is DOUBLE PRECISION +*> The computed sigma_I, the I-th updated eigenvalue. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension ( N ) +*> If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th +*> component. If N = 1, then WORK( 1 ) = 1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> > 0: if INFO = 1, the updating process failed. +*> \endverbatim +* +*> \par Internal Parameters: +* ========================= +*> +*> \verbatim +*> Logical variable ORGATI (origin-at-i?) is used for distinguishing +*> whether D(i) or D(i+1) is treated as the origin. +*> +*> ORGATI = .true. origin at i +*> ORGATI = .false. origin at i+1 +*> +*> Logical variable SWTCH3 (switch-for-3-poles?) is for noting +*> if we are working with THREE poles! +*> +*> MAXIT is the maximum number of iterations allowed for each +*> eigenvalue. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Ren-Cang Li, Computer Science Division, University of California +*> at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER I, INFO, N + DOUBLE PRECISION RHO, SIGMA +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), DELTA( * ), WORK( * ), Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER MAXIT + PARAMETER ( MAXIT = 400 ) + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ THREE = 3.0D+0, FOUR = 4.0D+0, EIGHT = 8.0D+0, + $ TEN = 10.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ORGATI, SWTCH, SWTCH3, GEOMAVG + INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER + DOUBLE PRECISION A, B, C, DELSQ, DELSQ2, SQ2, DPHI, DPSI, DTIIM, + $ DTIIP, DTIPSQ, DTISQ, DTNSQ, DTNSQ1, DW, EPS, + $ ERRETM, ETA, PHI, PREW, PSI, RHOINV, SGLB, + $ SGUB, TAU, TAU2, TEMP, TEMP1, TEMP2, W +* .. +* .. Local Arrays .. + DOUBLE PRECISION DD( 3 ), ZZ( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DLAED6, DLASD5 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Since this routine is called in an inner loop, we do no argument +* checking. +* +* Quick return for N=1 and 2. +* + INFO = 0 + IF( N.EQ.1 ) THEN +* +* Presumably, I=1 upon entry +* + SIGMA = SQRT( D( 1 )*D( 1 )+RHO*Z( 1 )*Z( 1 ) ) + DELTA( 1 ) = ONE + WORK( 1 ) = ONE + RETURN + END IF + IF( N.EQ.2 ) THEN + CALL DLASD5( I, D, Z, DELTA, RHO, SIGMA, WORK ) + RETURN + END IF +* +* Compute machine epsilon +* + EPS = DLAMCH( 'Epsilon' ) + RHOINV = ONE / RHO + TAU2= ZERO +* +* The case I = N +* + IF( I.EQ.N ) THEN +* +* Initialize some basic variables +* + II = N - 1 + NITER = 1 +* +* Calculate initial guess +* + TEMP = RHO / TWO +* +* If ||Z||_2 is not one, then TEMP should be set to +* RHO * ||Z||_2^2 / TWO +* + TEMP1 = TEMP / ( D( N )+SQRT( D( N )*D( N )+TEMP ) ) + DO 10 J = 1, N + WORK( J ) = D( J ) + D( N ) + TEMP1 + DELTA( J ) = ( D( J )-D( N ) ) - TEMP1 + 10 CONTINUE +* + PSI = ZERO + DO 20 J = 1, N - 2 + PSI = PSI + Z( J )*Z( J ) / ( DELTA( J )*WORK( J ) ) + 20 CONTINUE +* + C = RHOINV + PSI + W = C + Z( II )*Z( II ) / ( DELTA( II )*WORK( II ) ) + + $ Z( N )*Z( N ) / ( DELTA( N )*WORK( N ) ) +* + IF( W.LE.ZERO ) THEN + TEMP1 = SQRT( D( N )*D( N )+RHO ) + TEMP = Z( N-1 )*Z( N-1 ) / ( ( D( N-1 )+TEMP1 )* + $ ( D( N )-D( N-1 )+RHO / ( D( N )+TEMP1 ) ) ) + + $ Z( N )*Z( N ) / RHO +* +* The following TAU2 is to approximate +* SIGMA_n^2 - D( N )*D( N ) +* + IF( C.LE.TEMP ) THEN + TAU = RHO + ELSE + DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) ) + A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) + B = Z( N )*Z( N )*DELSQ + IF( A.LT.ZERO ) THEN + TAU2 = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) + ELSE + TAU2 = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) + END IF + TAU = TAU2 / ( D( N )+SQRT( D( N )*D( N )+TAU2 ) ) + END IF +* +* It can be proved that +* D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU2 <= D(N)^2+RHO +* + ELSE + DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) ) + A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) + B = Z( N )*Z( N )*DELSQ +* +* The following TAU2 is to approximate +* SIGMA_n^2 - D( N )*D( N ) +* + IF( A.LT.ZERO ) THEN + TAU2 = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) + ELSE + TAU2 = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) + END IF + TAU = TAU2 / ( D( N )+SQRT( D( N )*D( N )+TAU2 ) ) + +* +* It can be proved that +* D(N)^2 < D(N)^2+TAU2 < SIGMA(N)^2 < D(N)^2+RHO/2 +* + END IF +* +* The following TAU is to approximate SIGMA_n - D( N ) +* +* TAU = TAU2 / ( D( N )+SQRT( D( N )*D( N )+TAU2 ) ) +* + SIGMA = D( N ) + TAU + DO 30 J = 1, N + DELTA( J ) = ( D( J )-D( N ) ) - TAU + WORK( J ) = D( J ) + D( N ) + TAU + 30 CONTINUE +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 40 J = 1, II + TEMP = Z( J ) / ( DELTA( J )*WORK( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 40 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + TEMP = Z( N ) / ( DELTA( N )*WORK( N ) ) + PHI = Z( N )*TEMP + DPHI = TEMP*TEMP + ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +* $ + ABS( TAU2 )*( DPSI+DPHI ) +* + W = RHOINV + PHI + PSI +* +* Test for convergence +* + IF( ABS( W ).LE.EPS*ERRETM ) THEN + GO TO 240 + END IF +* +* Calculate the new step +* + NITER = NITER + 1 + DTNSQ1 = WORK( N-1 )*DELTA( N-1 ) + DTNSQ = WORK( N )*DELTA( N ) + C = W - DTNSQ1*DPSI - DTNSQ*DPHI + A = ( DTNSQ+DTNSQ1 )*W - DTNSQ*DTNSQ1*( DPSI+DPHI ) + B = DTNSQ*DTNSQ1*W + IF( C.LT.ZERO ) + $ C = ABS( C ) + IF( C.EQ.ZERO ) THEN + ETA = RHO - SIGMA*SIGMA + ELSE IF( A.GE.ZERO ) THEN + ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF +* +* Note, eta should be positive if w is negative, and +* eta should be negative otherwise. However, +* if for some reason caused by roundoff, eta*w > 0, +* we simply use one Newton step instead. This way +* will guarantee eta*w < 0. +* + IF( W*ETA.GT.ZERO ) + $ ETA = -W / ( DPSI+DPHI ) + TEMP = ETA - DTNSQ + IF( TEMP.GT.RHO ) + $ ETA = RHO + DTNSQ +* + ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) ) + TAU = TAU + ETA + SIGMA = SIGMA + ETA +* + DO 50 J = 1, N + DELTA( J ) = DELTA( J ) - ETA + WORK( J ) = WORK( J ) + ETA + 50 CONTINUE +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 60 J = 1, II + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 60 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + TAU2 = WORK( N )*DELTA( N ) + TEMP = Z( N ) / TAU2 + PHI = Z( N )*TEMP + DPHI = TEMP*TEMP + ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +* $ + ABS( TAU2 )*( DPSI+DPHI ) +* + W = RHOINV + PHI + PSI +* +* Main loop to update the values of the array DELTA +* + ITER = NITER + 1 +* + DO 90 NITER = ITER, MAXIT +* +* Test for convergence +* + IF( ABS( W ).LE.EPS*ERRETM ) THEN + GO TO 240 + END IF +* +* Calculate the new step +* + DTNSQ1 = WORK( N-1 )*DELTA( N-1 ) + DTNSQ = WORK( N )*DELTA( N ) + C = W - DTNSQ1*DPSI - DTNSQ*DPHI + A = ( DTNSQ+DTNSQ1 )*W - DTNSQ1*DTNSQ*( DPSI+DPHI ) + B = DTNSQ1*DTNSQ*W + IF( A.GE.ZERO ) THEN + ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF +* +* Note, eta should be positive if w is negative, and +* eta should be negative otherwise. However, +* if for some reason caused by roundoff, eta*w > 0, +* we simply use one Newton step instead. This way +* will guarantee eta*w < 0. +* + IF( W*ETA.GT.ZERO ) + $ ETA = -W / ( DPSI+DPHI ) + TEMP = ETA - DTNSQ + IF( TEMP.LE.ZERO ) + $ ETA = ETA / TWO +* + ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) ) + TAU = TAU + ETA + SIGMA = SIGMA + ETA +* + DO 70 J = 1, N + DELTA( J ) = DELTA( J ) - ETA + WORK( J ) = WORK( J ) + ETA + 70 CONTINUE +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 80 J = 1, II + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 80 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + TAU2 = WORK( N )*DELTA( N ) + TEMP = Z( N ) / TAU2 + PHI = Z( N )*TEMP + DPHI = TEMP*TEMP + ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +* $ + ABS( TAU2 )*( DPSI+DPHI ) +* + W = RHOINV + PHI + PSI + 90 CONTINUE +* +* Return with INFO = 1, NITER = MAXIT and not converged +* + INFO = 1 + GO TO 240 +* +* End for the case I = N +* + ELSE +* +* The case for I < N +* + NITER = 1 + IP1 = I + 1 +* +* Calculate initial guess +* + DELSQ = ( D( IP1 )-D( I ) )*( D( IP1 )+D( I ) ) + DELSQ2 = DELSQ / TWO + SQ2=SQRT( ( D( I )*D( I )+D( IP1 )*D( IP1 ) ) / TWO ) + TEMP = DELSQ2 / ( D( I )+SQ2 ) + DO 100 J = 1, N + WORK( J ) = D( J ) + D( I ) + TEMP + DELTA( J ) = ( D( J )-D( I ) ) - TEMP + 100 CONTINUE +* + PSI = ZERO + DO 110 J = 1, I - 1 + PSI = PSI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) ) + 110 CONTINUE +* + PHI = ZERO + DO 120 J = N, I + 2, -1 + PHI = PHI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) ) + 120 CONTINUE + C = RHOINV + PSI + PHI + W = C + Z( I )*Z( I ) / ( WORK( I )*DELTA( I ) ) + + $ Z( IP1 )*Z( IP1 ) / ( WORK( IP1 )*DELTA( IP1 ) ) +* + GEOMAVG = .FALSE. + IF( W.GT.ZERO ) THEN +* +* d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2 +* +* We choose d(i) as origin. +* + ORGATI = .TRUE. + II = I + SGLB = ZERO + SGUB = DELSQ2 / ( D( I )+SQ2 ) + A = C*DELSQ + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 ) + B = Z( I )*Z( I )*DELSQ + IF( A.GT.ZERO ) THEN + TAU2 = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + ELSE + TAU2 = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + END IF +* +* TAU2 now is an estimation of SIGMA^2 - D( I )^2. The +* following, however, is the corresponding estimation of +* SIGMA - D( I ). +* + TAU = TAU2 / ( D( I )+SQRT( D( I )*D( I )+TAU2 ) ) + TEMP = SQRT(EPS) + IF( (D(I).LE.TEMP*D(IP1)).AND.(ABS(Z(I)).LE.TEMP) + $ .AND.(D(I).GT.ZERO) ) THEN + TAU = MIN( TEN*D(I), SGUB ) + GEOMAVG = .TRUE. + END IF + ELSE +* +* (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2 +* +* We choose d(i+1) as origin. +* + ORGATI = .FALSE. + II = IP1 + SGLB = -DELSQ2 / ( D( II )+SQ2 ) + SGUB = ZERO + A = C*DELSQ - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 ) + B = Z( IP1 )*Z( IP1 )*DELSQ + IF( A.LT.ZERO ) THEN + TAU2 = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) ) + ELSE + TAU2 = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C ) + END IF +* +* TAU2 now is an estimation of SIGMA^2 - D( IP1 )^2. The +* following, however, is the corresponding estimation of +* SIGMA - D( IP1 ). +* + TAU = TAU2 / ( D( IP1 )+SQRT( ABS( D( IP1 )*D( IP1 )+ + $ TAU2 ) ) ) + END IF +* + SIGMA = D( II ) + TAU + DO 130 J = 1, N + WORK( J ) = D( J ) + D( II ) + TAU + DELTA( J ) = ( D( J )-D( II ) ) - TAU + 130 CONTINUE + IIM1 = II - 1 + IIP1 = II + 1 +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 150 J = 1, IIM1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 150 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + DPHI = ZERO + PHI = ZERO + DO 160 J = N, IIP1, -1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PHI = PHI + Z( J )*TEMP + DPHI = DPHI + TEMP*TEMP + ERRETM = ERRETM + PHI + 160 CONTINUE +* + W = RHOINV + PHI + PSI +* +* W is the value of the secular function with +* its ii-th element removed. +* + SWTCH3 = .FALSE. + IF( ORGATI ) THEN + IF( W.LT.ZERO ) + $ SWTCH3 = .TRUE. + ELSE + IF( W.GT.ZERO ) + $ SWTCH3 = .TRUE. + END IF + IF( II.EQ.1 .OR. II.EQ.N ) + $ SWTCH3 = .FALSE. +* + TEMP = Z( II ) / ( WORK( II )*DELTA( II ) ) + DW = DPSI + DPHI + TEMP*TEMP + TEMP = Z( II )*TEMP + W = W + TEMP + ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + $ + THREE*ABS( TEMP ) +* $ + ABS( TAU2 )*DW +* +* Test for convergence +* + IF( ABS( W ).LE.EPS*ERRETM ) THEN + GO TO 240 + END IF +* + IF( W.LE.ZERO ) THEN + SGLB = MAX( SGLB, TAU ) + ELSE + SGUB = MIN( SGUB, TAU ) + END IF +* +* Calculate the new step +* + NITER = NITER + 1 + IF( .NOT.SWTCH3 ) THEN + DTIPSQ = WORK( IP1 )*DELTA( IP1 ) + DTISQ = WORK( I )*DELTA( I ) + IF( ORGATI ) THEN + C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2 + ELSE + C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2 + END IF + A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW + B = DTIPSQ*DTISQ*W + IF( C.EQ.ZERO ) THEN + IF( A.EQ.ZERO ) THEN + IF( ORGATI ) THEN + A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*( DPSI+DPHI ) + ELSE + A = Z( IP1 )*Z( IP1 ) + DTISQ*DTISQ*( DPSI+DPHI ) + END IF + END IF + ETA = B / A + ELSE IF( A.LE.ZERO ) THEN + ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + ELSE +* +* Interpolation using THREE most relevant poles +* + DTIIM = WORK( IIM1 )*DELTA( IIM1 ) + DTIIP = WORK( IIP1 )*DELTA( IIP1 ) + TEMP = RHOINV + PSI + PHI + IF( ORGATI ) THEN + TEMP1 = Z( IIM1 ) / DTIIM + TEMP1 = TEMP1*TEMP1 + C = ( TEMP - DTIIP*( DPSI+DPHI ) ) - + $ ( D( IIM1 )-D( IIP1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1 + ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) + IF( DPSI.LT.TEMP1 ) THEN + ZZ( 3 ) = DTIIP*DTIIP*DPHI + ELSE + ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI ) + END IF + ELSE + TEMP1 = Z( IIP1 ) / DTIIP + TEMP1 = TEMP1*TEMP1 + C = ( TEMP - DTIIM*( DPSI+DPHI ) ) - + $ ( D( IIP1 )-D( IIM1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1 + IF( DPHI.LT.TEMP1 ) THEN + ZZ( 1 ) = DTIIM*DTIIM*DPSI + ELSE + ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) ) + END IF + ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) + END IF + ZZ( 2 ) = Z( II )*Z( II ) + DD( 1 ) = DTIIM + DD( 2 ) = DELTA( II )*WORK( II ) + DD( 3 ) = DTIIP + CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO ) +* + IF( INFO.NE.0 ) THEN +* +* If INFO is not 0, i.e., DLAED6 failed, switch back +* to 2 pole interpolation. +* + SWTCH3 = .FALSE. + INFO = 0 + DTIPSQ = WORK( IP1 )*DELTA( IP1 ) + DTISQ = WORK( I )*DELTA( I ) + IF( ORGATI ) THEN + C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2 + ELSE + C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2 + END IF + A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW + B = DTIPSQ*DTISQ*W + IF( C.EQ.ZERO ) THEN + IF( A.EQ.ZERO ) THEN + IF( ORGATI ) THEN + A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*( DPSI+DPHI ) + ELSE + A = Z( IP1 )*Z( IP1 ) + DTISQ*DTISQ*( DPSI+DPHI) + END IF + END IF + ETA = B / A + ELSE IF( A.LE.ZERO ) THEN + ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + END IF + END IF +* +* Note, eta should be positive if w is negative, and +* eta should be negative otherwise. However, +* if for some reason caused by roundoff, eta*w > 0, +* we simply use one Newton step instead. This way +* will guarantee eta*w < 0. +* + IF( W*ETA.GE.ZERO ) + $ ETA = -W / DW +* + ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) ) + TEMP = TAU + ETA + IF( TEMP.GT.SGUB .OR. TEMP.LT.SGLB ) THEN + IF( W.LT.ZERO ) THEN + ETA = ( SGUB-TAU ) / TWO + ELSE + ETA = ( SGLB-TAU ) / TWO + END IF + IF( GEOMAVG ) THEN + IF( W .LT. ZERO ) THEN + IF( TAU .GT. ZERO ) THEN + ETA = SQRT(SGUB*TAU)-TAU + END IF + ELSE + IF( SGLB .GT. ZERO ) THEN + ETA = SQRT(SGLB*TAU)-TAU + END IF + END IF + END IF + END IF +* + PREW = W +* + TAU = TAU + ETA + SIGMA = SIGMA + ETA +* + DO 170 J = 1, N + WORK( J ) = WORK( J ) + ETA + DELTA( J ) = DELTA( J ) - ETA + 170 CONTINUE +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 180 J = 1, IIM1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 180 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + DPHI = ZERO + PHI = ZERO + DO 190 J = N, IIP1, -1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PHI = PHI + Z( J )*TEMP + DPHI = DPHI + TEMP*TEMP + ERRETM = ERRETM + PHI + 190 CONTINUE +* + TAU2 = WORK( II )*DELTA( II ) + TEMP = Z( II ) / TAU2 + DW = DPSI + DPHI + TEMP*TEMP + TEMP = Z( II )*TEMP + W = RHOINV + PHI + PSI + TEMP + ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + $ + THREE*ABS( TEMP ) +* $ + ABS( TAU2 )*DW +* + SWTCH = .FALSE. + IF( ORGATI ) THEN + IF( -W.GT.ABS( PREW ) / TEN ) + $ SWTCH = .TRUE. + ELSE + IF( W.GT.ABS( PREW ) / TEN ) + $ SWTCH = .TRUE. + END IF +* +* Main loop to update the values of the array DELTA and WORK +* + ITER = NITER + 1 +* + DO 230 NITER = ITER, MAXIT +* +* Test for convergence +* + IF( ABS( W ).LE.EPS*ERRETM ) THEN +* $ .OR. (SGUB-SGLB).LE.EIGHT*ABS(SGUB+SGLB) ) THEN + GO TO 240 + END IF +* + IF( W.LE.ZERO ) THEN + SGLB = MAX( SGLB, TAU ) + ELSE + SGUB = MIN( SGUB, TAU ) + END IF +* +* Calculate the new step +* + IF( .NOT.SWTCH3 ) THEN + DTIPSQ = WORK( IP1 )*DELTA( IP1 ) + DTISQ = WORK( I )*DELTA( I ) + IF( .NOT.SWTCH ) THEN + IF( ORGATI ) THEN + C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2 + ELSE + C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2 + END IF + ELSE + TEMP = Z( II ) / ( WORK( II )*DELTA( II ) ) + IF( ORGATI ) THEN + DPSI = DPSI + TEMP*TEMP + ELSE + DPHI = DPHI + TEMP*TEMP + END IF + C = W - DTISQ*DPSI - DTIPSQ*DPHI + END IF + A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW + B = DTIPSQ*DTISQ*W + IF( C.EQ.ZERO ) THEN + IF( A.EQ.ZERO ) THEN + IF( .NOT.SWTCH ) THEN + IF( ORGATI ) THEN + A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ* + $ ( DPSI+DPHI ) + ELSE + A = Z( IP1 )*Z( IP1 ) + + $ DTISQ*DTISQ*( DPSI+DPHI ) + END IF + ELSE + A = DTISQ*DTISQ*DPSI + DTIPSQ*DTIPSQ*DPHI + END IF + END IF + ETA = B / A + ELSE IF( A.LE.ZERO ) THEN + ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + ELSE +* +* Interpolation using THREE most relevant poles +* + DTIIM = WORK( IIM1 )*DELTA( IIM1 ) + DTIIP = WORK( IIP1 )*DELTA( IIP1 ) + TEMP = RHOINV + PSI + PHI + IF( SWTCH ) THEN + C = TEMP - DTIIM*DPSI - DTIIP*DPHI + ZZ( 1 ) = DTIIM*DTIIM*DPSI + ZZ( 3 ) = DTIIP*DTIIP*DPHI + ELSE + IF( ORGATI ) THEN + TEMP1 = Z( IIM1 ) / DTIIM + TEMP1 = TEMP1*TEMP1 + TEMP2 = ( D( IIM1 )-D( IIP1 ) )* + $ ( D( IIM1 )+D( IIP1 ) )*TEMP1 + C = TEMP - DTIIP*( DPSI+DPHI ) - TEMP2 + ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) + IF( DPSI.LT.TEMP1 ) THEN + ZZ( 3 ) = DTIIP*DTIIP*DPHI + ELSE + ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI ) + END IF + ELSE + TEMP1 = Z( IIP1 ) / DTIIP + TEMP1 = TEMP1*TEMP1 + TEMP2 = ( D( IIP1 )-D( IIM1 ) )* + $ ( D( IIM1 )+D( IIP1 ) )*TEMP1 + C = TEMP - DTIIM*( DPSI+DPHI ) - TEMP2 + IF( DPHI.LT.TEMP1 ) THEN + ZZ( 1 ) = DTIIM*DTIIM*DPSI + ELSE + ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) ) + END IF + ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) + END IF + END IF + DD( 1 ) = DTIIM + DD( 2 ) = DELTA( II )*WORK( II ) + DD( 3 ) = DTIIP + CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO ) +* + IF( INFO.NE.0 ) THEN +* +* If INFO is not 0, i.e., DLAED6 failed, switch +* back to two pole interpolation +* + SWTCH3 = .FALSE. + INFO = 0 + DTIPSQ = WORK( IP1 )*DELTA( IP1 ) + DTISQ = WORK( I )*DELTA( I ) + IF( .NOT.SWTCH ) THEN + IF( ORGATI ) THEN + C = W - DTIPSQ*DW + DELSQ*( Z( I )/DTISQ )**2 + ELSE + C = W - DTISQ*DW - DELSQ*( Z( IP1 )/DTIPSQ )**2 + END IF + ELSE + TEMP = Z( II ) / ( WORK( II )*DELTA( II ) ) + IF( ORGATI ) THEN + DPSI = DPSI + TEMP*TEMP + ELSE + DPHI = DPHI + TEMP*TEMP + END IF + C = W - DTISQ*DPSI - DTIPSQ*DPHI + END IF + A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW + B = DTIPSQ*DTISQ*W + IF( C.EQ.ZERO ) THEN + IF( A.EQ.ZERO ) THEN + IF( .NOT.SWTCH ) THEN + IF( ORGATI ) THEN + A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ* + $ ( DPSI+DPHI ) + ELSE + A = Z( IP1 )*Z( IP1 ) + + $ DTISQ*DTISQ*( DPSI+DPHI ) + END IF + ELSE + A = DTISQ*DTISQ*DPSI + DTIPSQ*DTIPSQ*DPHI + END IF + END IF + ETA = B / A + ELSE IF( A.LE.ZERO ) THEN + ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + END IF + END IF +* +* Note, eta should be positive if w is negative, and +* eta should be negative otherwise. However, +* if for some reason caused by roundoff, eta*w > 0, +* we simply use one Newton step instead. This way +* will guarantee eta*w < 0. +* + IF( W*ETA.GE.ZERO ) + $ ETA = -W / DW +* + ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) ) + TEMP=TAU+ETA + IF( TEMP.GT.SGUB .OR. TEMP.LT.SGLB ) THEN + IF( W.LT.ZERO ) THEN + ETA = ( SGUB-TAU ) / TWO + ELSE + ETA = ( SGLB-TAU ) / TWO + END IF + IF( GEOMAVG ) THEN + IF( W .LT. ZERO ) THEN + IF( TAU .GT. ZERO ) THEN + ETA = SQRT(SGUB*TAU)-TAU + END IF + ELSE + IF( SGLB .GT. ZERO ) THEN + ETA = SQRT(SGLB*TAU)-TAU + END IF + END IF + END IF + END IF +* + PREW = W +* + TAU = TAU + ETA + SIGMA = SIGMA + ETA +* + DO 200 J = 1, N + WORK( J ) = WORK( J ) + ETA + DELTA( J ) = DELTA( J ) - ETA + 200 CONTINUE +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 210 J = 1, IIM1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 210 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + DPHI = ZERO + PHI = ZERO + DO 220 J = N, IIP1, -1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PHI = PHI + Z( J )*TEMP + DPHI = DPHI + TEMP*TEMP + ERRETM = ERRETM + PHI + 220 CONTINUE +* + TAU2 = WORK( II )*DELTA( II ) + TEMP = Z( II ) / TAU2 + DW = DPSI + DPHI + TEMP*TEMP + TEMP = Z( II )*TEMP + W = RHOINV + PHI + PSI + TEMP + ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + $ + THREE*ABS( TEMP ) +* $ + ABS( TAU2 )*DW +* + IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN ) + $ SWTCH = .NOT.SWTCH +* + 230 CONTINUE +* +* Return with INFO = 1, NITER = MAXIT and not converged +* + INFO = 1 +* + END IF +* + 240 CONTINUE + RETURN +* +* End of DLASD4 +* + END diff --git a/lib/linalg/dlasd5.f b/lib/linalg/dlasd5.f new file mode 100644 index 0000000000..4896ba6b97 --- /dev/null +++ b/lib/linalg/dlasd5.f @@ -0,0 +1,231 @@ +*> \brief \b DLASD5 computes the square root of the i-th eigenvalue of a positive symmetric rank-one modification of a 2-by-2 diagonal matrix. Used by sbdsdc. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASD5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK ) +* +* .. Scalar Arguments .. +* INTEGER I +* DOUBLE PRECISION DSIGMA, RHO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This subroutine computes the square root of the I-th eigenvalue +*> of a positive symmetric rank-one modification of a 2-by-2 diagonal +*> matrix +*> +*> diag( D ) * diag( D ) + RHO * Z * transpose(Z) . +*> +*> The diagonal entries in the array D are assumed to satisfy +*> +*> 0 <= D(i) < D(j) for i < j . +*> +*> We also assume RHO > 0 and that the Euclidean norm of the vector +*> Z is one. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] I +*> \verbatim +*> I is INTEGER +*> The index of the eigenvalue to be computed. I = 1 or I = 2. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension ( 2 ) +*> The original eigenvalues. We assume 0 <= D(1) < D(2). +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension ( 2 ) +*> The components of the updating vector. +*> \endverbatim +*> +*> \param[out] DELTA +*> \verbatim +*> DELTA is DOUBLE PRECISION array, dimension ( 2 ) +*> Contains (D(j) - sigma_I) in its j-th component. +*> The vector DELTA contains the information necessary +*> to construct the eigenvectors. +*> \endverbatim +*> +*> \param[in] RHO +*> \verbatim +*> RHO is DOUBLE PRECISION +*> The scalar in the symmetric updating formula. +*> \endverbatim +*> +*> \param[out] DSIGMA +*> \verbatim +*> DSIGMA is DOUBLE PRECISION +*> The computed sigma_I, the I-th updated eigenvalue. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension ( 2 ) +*> WORK contains (D(j) + sigma_I) in its j-th component. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Ren-Cang Li, Computer Science Division, University of California +*> at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER I + DOUBLE PRECISION DSIGMA, RHO +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ THREE = 3.0D+0, FOUR = 4.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION B, C, DEL, DELSQ, TAU, W +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +* .. +* .. Executable Statements .. +* + DEL = D( 2 ) - D( 1 ) + DELSQ = DEL*( D( 2 )+D( 1 ) ) + IF( I.EQ.1 ) THEN + W = ONE + FOUR*RHO*( Z( 2 )*Z( 2 ) / ( D( 1 )+THREE*D( 2 ) )- + $ Z( 1 )*Z( 1 ) / ( THREE*D( 1 )+D( 2 ) ) ) / DEL + IF( W.GT.ZERO ) THEN + B = DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) + C = RHO*Z( 1 )*Z( 1 )*DELSQ +* +* B > ZERO, always +* +* The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 ) +* + TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) ) +* +* The following TAU is DSIGMA - D( 1 ) +* + TAU = TAU / ( D( 1 )+SQRT( D( 1 )*D( 1 )+TAU ) ) + DSIGMA = D( 1 ) + TAU + DELTA( 1 ) = -TAU + DELTA( 2 ) = DEL - TAU + WORK( 1 ) = TWO*D( 1 ) + TAU + WORK( 2 ) = ( D( 1 )+TAU ) + D( 2 ) +* DELTA( 1 ) = -Z( 1 ) / TAU +* DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) + ELSE + B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) + C = RHO*Z( 2 )*Z( 2 )*DELSQ +* +* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) +* + IF( B.GT.ZERO ) THEN + TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) ) + ELSE + TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO + END IF +* +* The following TAU is DSIGMA - D( 2 ) +* + TAU = TAU / ( D( 2 )+SQRT( ABS( D( 2 )*D( 2 )+TAU ) ) ) + DSIGMA = D( 2 ) + TAU + DELTA( 1 ) = -( DEL+TAU ) + DELTA( 2 ) = -TAU + WORK( 1 ) = D( 1 ) + TAU + D( 2 ) + WORK( 2 ) = TWO*D( 2 ) + TAU +* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) +* DELTA( 2 ) = -Z( 2 ) / TAU + END IF +* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) +* DELTA( 1 ) = DELTA( 1 ) / TEMP +* DELTA( 2 ) = DELTA( 2 ) / TEMP + ELSE +* +* Now I=2 +* + B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) + C = RHO*Z( 2 )*Z( 2 )*DELSQ +* +* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) +* + IF( B.GT.ZERO ) THEN + TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO + ELSE + TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) ) + END IF +* +* The following TAU is DSIGMA - D( 2 ) +* + TAU = TAU / ( D( 2 )+SQRT( D( 2 )*D( 2 )+TAU ) ) + DSIGMA = D( 2 ) + TAU + DELTA( 1 ) = -( DEL+TAU ) + DELTA( 2 ) = -TAU + WORK( 1 ) = D( 1 ) + TAU + D( 2 ) + WORK( 2 ) = TWO*D( 2 ) + TAU +* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) +* DELTA( 2 ) = -Z( 2 ) / TAU +* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) +* DELTA( 1 ) = DELTA( 1 ) / TEMP +* DELTA( 2 ) = DELTA( 2 ) / TEMP + END IF + RETURN +* +* End of DLASD5 +* + END diff --git a/lib/linalg/dlasd6.f b/lib/linalg/dlasd6.f new file mode 100644 index 0000000000..5cab78a070 --- /dev/null +++ b/lib/linalg/dlasd6.f @@ -0,0 +1,443 @@ +*> \brief \b DLASD6 computes the SVD of an updated upper bidiagonal matrix obtained by merging two smaller ones by appending a row. Used by sbdsdc. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASD6 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, +* IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, +* LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, +* IWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, +* $ NR, SQRE +* DOUBLE PRECISION ALPHA, BETA, C, S +* .. +* .. Array Arguments .. +* INTEGER GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ), +* $ PERM( * ) +* DOUBLE PRECISION D( * ), DIFL( * ), DIFR( * ), +* $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ), +* $ VF( * ), VL( * ), WORK( * ), Z( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASD6 computes the SVD of an updated upper bidiagonal matrix B +*> obtained by merging two smaller ones by appending a row. This +*> routine is used only for the problem which requires all singular +*> values and optionally singular vector matrices in factored form. +*> B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE. +*> A related subroutine, DLASD1, handles the case in which all singular +*> values and singular vectors of the bidiagonal matrix are desired. +*> +*> DLASD6 computes the SVD as follows: +*> +*> ( D1(in) 0 0 0 ) +*> B = U(in) * ( Z1**T a Z2**T b ) * VT(in) +*> ( 0 0 D2(in) 0 ) +*> +*> = U(out) * ( D(out) 0) * VT(out) +*> +*> where Z**T = (Z1**T a Z2**T b) = u**T VT**T, and u is a vector of dimension M +*> with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros +*> elsewhere; and the entry b is empty if SQRE = 0. +*> +*> The singular values of B can be computed using D1, D2, the first +*> components of all the right singular vectors of the lower block, and +*> the last components of all the right singular vectors of the upper +*> block. These components are stored and updated in VF and VL, +*> respectively, in DLASD6. Hence U and VT are not explicitly +*> referenced. +*> +*> The singular values are stored in D. The algorithm consists of two +*> stages: +*> +*> The first stage consists of deflating the size of the problem +*> when there are multiple singular values or if there is a zero +*> in the Z vector. For each such occurrence the dimension of the +*> secular equation problem is reduced by one. This stage is +*> performed by the routine DLASD7. +*> +*> The second stage consists of calculating the updated +*> singular values. This is done by finding the roots of the +*> secular equation via the routine DLASD4 (as called by DLASD8). +*> This routine also updates VF and VL and computes the distances +*> between the updated singular values and the old singular +*> values. +*> +*> DLASD6 is called from DLASDA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ICOMPQ +*> \verbatim +*> ICOMPQ is INTEGER +*> Specifies whether singular vectors are to be computed in +*> factored form: +*> = 0: Compute singular values only. +*> = 1: Compute singular vectors in factored form as well. +*> \endverbatim +*> +*> \param[in] NL +*> \verbatim +*> NL is INTEGER +*> The row dimension of the upper block. NL >= 1. +*> \endverbatim +*> +*> \param[in] NR +*> \verbatim +*> NR is INTEGER +*> The row dimension of the lower block. NR >= 1. +*> \endverbatim +*> +*> \param[in] SQRE +*> \verbatim +*> SQRE is INTEGER +*> = 0: the lower block is an NR-by-NR square matrix. +*> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. +*> +*> The bidiagonal matrix has row dimension N = NL + NR + 1, +*> and column dimension M = N + SQRE. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension ( NL+NR+1 ). +*> On entry D(1:NL,1:NL) contains the singular values of the +*> upper block, and D(NL+2:N) contains the singular values +*> of the lower block. On exit D(1:N) contains the singular +*> values of the modified matrix. +*> \endverbatim +*> +*> \param[in,out] VF +*> \verbatim +*> VF is DOUBLE PRECISION array, dimension ( M ) +*> On entry, VF(1:NL+1) contains the first components of all +*> right singular vectors of the upper block; and VF(NL+2:M) +*> contains the first components of all right singular vectors +*> of the lower block. On exit, VF contains the first components +*> of all right singular vectors of the bidiagonal matrix. +*> \endverbatim +*> +*> \param[in,out] VL +*> \verbatim +*> VL is DOUBLE PRECISION array, dimension ( M ) +*> On entry, VL(1:NL+1) contains the last components of all +*> right singular vectors of the upper block; and VL(NL+2:M) +*> contains the last components of all right singular vectors of +*> the lower block. On exit, VL contains the last components of +*> all right singular vectors of the bidiagonal matrix. +*> \endverbatim +*> +*> \param[in,out] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION +*> Contains the diagonal element associated with the added row. +*> \endverbatim +*> +*> \param[in,out] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION +*> Contains the off-diagonal element associated with the added +*> row. +*> \endverbatim +*> +*> \param[in,out] IDXQ +*> \verbatim +*> IDXQ is INTEGER array, dimension ( N ) +*> This contains the permutation which will reintegrate the +*> subproblem just solved back into sorted order, i.e. +*> D( IDXQ( I = 1, N ) ) will be in ascending order. +*> \endverbatim +*> +*> \param[out] PERM +*> \verbatim +*> PERM is INTEGER array, dimension ( N ) +*> The permutations (from deflation and sorting) to be applied +*> to each block. Not referenced if ICOMPQ = 0. +*> \endverbatim +*> +*> \param[out] GIVPTR +*> \verbatim +*> GIVPTR is INTEGER +*> The number of Givens rotations which took place in this +*> subproblem. Not referenced if ICOMPQ = 0. +*> \endverbatim +*> +*> \param[out] GIVCOL +*> \verbatim +*> GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) +*> Each pair of numbers indicates a pair of columns to take place +*> in a Givens rotation. Not referenced if ICOMPQ = 0. +*> \endverbatim +*> +*> \param[in] LDGCOL +*> \verbatim +*> LDGCOL is INTEGER +*> leading dimension of GIVCOL, must be at least N. +*> \endverbatim +*> +*> \param[out] GIVNUM +*> \verbatim +*> GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) +*> Each number indicates the C or S value to be used in the +*> corresponding Givens rotation. Not referenced if ICOMPQ = 0. +*> \endverbatim +*> +*> \param[in] LDGNUM +*> \verbatim +*> LDGNUM is INTEGER +*> The leading dimension of GIVNUM and POLES, must be at least N. +*> \endverbatim +*> +*> \param[out] POLES +*> \verbatim +*> POLES is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) +*> On exit, POLES(1,*) is an array containing the new singular +*> values obtained from solving the secular equation, and +*> POLES(2,*) is an array containing the poles in the secular +*> equation. Not referenced if ICOMPQ = 0. +*> \endverbatim +*> +*> \param[out] DIFL +*> \verbatim +*> DIFL is DOUBLE PRECISION array, dimension ( N ) +*> On exit, DIFL(I) is the distance between I-th updated +*> (undeflated) singular value and the I-th (undeflated) old +*> singular value. +*> \endverbatim +*> +*> \param[out] DIFR +*> \verbatim +*> DIFR is DOUBLE PRECISION array, +*> dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and +*> dimension ( K ) if ICOMPQ = 0. +*> On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not +*> defined and will not be referenced. +*> +*> If ICOMPQ = 1, DIFR(1:K,2) is an array containing the +*> normalizing factors for the right singular vector matrix. +*> +*> See DLASD8 for details on DIFL and DIFR. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension ( M ) +*> The first elements of this array contain the components +*> of the deflation-adjusted updating row vector. +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> Contains the dimension of the non-deflated matrix, +*> This is the order of the related secular equation. 1 <= K <=N. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION +*> C contains garbage if SQRE =0 and the C-value of a Givens +*> rotation related to the right null space if SQRE = 1. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION +*> S contains garbage if SQRE =0 and the S-value of a Givens +*> rotation related to the right null space if SQRE = 1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension ( 4 * M ) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension ( 3 * N ) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = 1, a singular value did not converge +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Huan Ren, Computer Science Division, University of +*> California at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, + $ IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, + $ LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, + $ IWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, + $ NR, SQRE + DOUBLE PRECISION ALPHA, BETA, C, S +* .. +* .. Array Arguments .. + INTEGER GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ), + $ PERM( * ) + DOUBLE PRECISION D( * ), DIFL( * ), DIFR( * ), + $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ), + $ VF( * ), VL( * ), WORK( * ), Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IDX, IDXC, IDXP, ISIGMA, IVFW, IVLW, IW, M, + $ N, N1, N2 + DOUBLE PRECISION ORGNRM +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLAMRG, DLASCL, DLASD7, DLASD8, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + N = NL + NR + 1 + M = N + SQRE +* + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( NL.LT.1 ) THEN + INFO = -2 + ELSE IF( NR.LT.1 ) THEN + INFO = -3 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -4 + ELSE IF( LDGCOL.LT.N ) THEN + INFO = -14 + ELSE IF( LDGNUM.LT.N ) THEN + INFO = -16 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD6', -INFO ) + RETURN + END IF +* +* The following values are for bookkeeping purposes only. They are +* integer pointers which indicate the portion of the workspace +* used by a particular array in DLASD7 and DLASD8. +* + ISIGMA = 1 + IW = ISIGMA + N + IVFW = IW + M + IVLW = IVFW + M +* + IDX = 1 + IDXC = IDX + N + IDXP = IDXC + N +* +* Scale. +* + ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) ) + D( NL+1 ) = ZERO + DO 10 I = 1, N + IF( ABS( D( I ) ).GT.ORGNRM ) THEN + ORGNRM = ABS( D( I ) ) + END IF + 10 CONTINUE + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO ) + ALPHA = ALPHA / ORGNRM + BETA = BETA / ORGNRM +* +* Sort and Deflate singular values. +* + CALL DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, WORK( IW ), VF, + $ WORK( IVFW ), VL, WORK( IVLW ), ALPHA, BETA, + $ WORK( ISIGMA ), IWORK( IDX ), IWORK( IDXP ), IDXQ, + $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S, + $ INFO ) +* +* Solve Secular Equation, compute DIFL, DIFR, and update VF, VL. +* + CALL DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDGNUM, + $ WORK( ISIGMA ), WORK( IW ), INFO ) +* +* Report the possible convergence failure. +* + IF( INFO.NE.0 ) THEN + RETURN + END IF +* +* Save the poles if ICOMPQ = 1. +* + IF( ICOMPQ.EQ.1 ) THEN + CALL DCOPY( K, D, 1, POLES( 1, 1 ), 1 ) + CALL DCOPY( K, WORK( ISIGMA ), 1, POLES( 1, 2 ), 1 ) + END IF +* +* Unscale. +* + CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) +* +* Prepare the IDXQ sorting permutation. +* + N1 = K + N2 = N - K + CALL DLAMRG( N1, N2, D, 1, -1, IDXQ ) +* + RETURN +* +* End of DLASD6 +* + END diff --git a/lib/linalg/dlasd7.f b/lib/linalg/dlasd7.f new file mode 100644 index 0000000000..e0ddedeb57 --- /dev/null +++ b/lib/linalg/dlasd7.f @@ -0,0 +1,580 @@ +*> \brief \b DLASD7 merges the two sets of singular values together into a single sorted set. Then it tries to deflate the size of the problem. Used by sbdsdc. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASD7 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, +* VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, +* PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, +* C, S, INFO ) +* +* .. Scalar Arguments .. +* INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, +* $ NR, SQRE +* DOUBLE PRECISION ALPHA, BETA, C, S +* .. +* .. Array Arguments .. +* INTEGER GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ), +* $ IDXQ( * ), PERM( * ) +* DOUBLE PRECISION D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ), +* $ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ), +* $ ZW( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASD7 merges the two sets of singular values together into a single +*> sorted set. Then it tries to deflate the size of the problem. There +*> are two ways in which deflation can occur: when two or more singular +*> values are close together or if there is a tiny entry in the Z +*> vector. For each such occurrence the order of the related +*> secular equation problem is reduced by one. +*> +*> DLASD7 is called from DLASD6. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ICOMPQ +*> \verbatim +*> ICOMPQ is INTEGER +*> Specifies whether singular vectors are to be computed +*> in compact form, as follows: +*> = 0: Compute singular values only. +*> = 1: Compute singular vectors of upper +*> bidiagonal matrix in compact form. +*> \endverbatim +*> +*> \param[in] NL +*> \verbatim +*> NL is INTEGER +*> The row dimension of the upper block. NL >= 1. +*> \endverbatim +*> +*> \param[in] NR +*> \verbatim +*> NR is INTEGER +*> The row dimension of the lower block. NR >= 1. +*> \endverbatim +*> +*> \param[in] SQRE +*> \verbatim +*> SQRE is INTEGER +*> = 0: the lower block is an NR-by-NR square matrix. +*> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. +*> +*> The bidiagonal matrix has +*> N = NL + NR + 1 rows and +*> M = N + SQRE >= N columns. +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> Contains the dimension of the non-deflated matrix, this is +*> the order of the related secular equation. 1 <= K <=N. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension ( N ) +*> On entry D contains the singular values of the two submatrices +*> to be combined. On exit D contains the trailing (N-K) updated +*> singular values (those which were deflated) sorted into +*> increasing order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension ( M ) +*> On exit Z contains the updating row vector in the secular +*> equation. +*> \endverbatim +*> +*> \param[out] ZW +*> \verbatim +*> ZW is DOUBLE PRECISION array, dimension ( M ) +*> Workspace for Z. +*> \endverbatim +*> +*> \param[in,out] VF +*> \verbatim +*> VF is DOUBLE PRECISION array, dimension ( M ) +*> On entry, VF(1:NL+1) contains the first components of all +*> right singular vectors of the upper block; and VF(NL+2:M) +*> contains the first components of all right singular vectors +*> of the lower block. On exit, VF contains the first components +*> of all right singular vectors of the bidiagonal matrix. +*> \endverbatim +*> +*> \param[out] VFW +*> \verbatim +*> VFW is DOUBLE PRECISION array, dimension ( M ) +*> Workspace for VF. +*> \endverbatim +*> +*> \param[in,out] VL +*> \verbatim +*> VL is DOUBLE PRECISION array, dimension ( M ) +*> On entry, VL(1:NL+1) contains the last components of all +*> right singular vectors of the upper block; and VL(NL+2:M) +*> contains the last components of all right singular vectors +*> of the lower block. On exit, VL contains the last components +*> of all right singular vectors of the bidiagonal matrix. +*> \endverbatim +*> +*> \param[out] VLW +*> \verbatim +*> VLW is DOUBLE PRECISION array, dimension ( M ) +*> Workspace for VL. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION +*> Contains the diagonal element associated with the added row. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION +*> Contains the off-diagonal element associated with the added +*> row. +*> \endverbatim +*> +*> \param[out] DSIGMA +*> \verbatim +*> DSIGMA is DOUBLE PRECISION array, dimension ( N ) +*> Contains a copy of the diagonal elements (K-1 singular values +*> and one zero) in the secular equation. +*> \endverbatim +*> +*> \param[out] IDX +*> \verbatim +*> IDX is INTEGER array, dimension ( N ) +*> This will contain the permutation used to sort the contents of +*> D into ascending order. +*> \endverbatim +*> +*> \param[out] IDXP +*> \verbatim +*> IDXP is INTEGER array, dimension ( N ) +*> This will contain the permutation used to place deflated +*> values of D at the end of the array. On output IDXP(2:K) +*> points to the nondeflated D-values and IDXP(K+1:N) +*> points to the deflated singular values. +*> \endverbatim +*> +*> \param[in] IDXQ +*> \verbatim +*> IDXQ is INTEGER array, dimension ( N ) +*> This contains the permutation which separately sorts the two +*> sub-problems in D into ascending order. Note that entries in +*> the first half of this permutation must first be moved one +*> position backward; and entries in the second half +*> must first have NL+1 added to their values. +*> \endverbatim +*> +*> \param[out] PERM +*> \verbatim +*> PERM is INTEGER array, dimension ( N ) +*> The permutations (from deflation and sorting) to be applied +*> to each singular block. Not referenced if ICOMPQ = 0. +*> \endverbatim +*> +*> \param[out] GIVPTR +*> \verbatim +*> GIVPTR is INTEGER +*> The number of Givens rotations which took place in this +*> subproblem. Not referenced if ICOMPQ = 0. +*> \endverbatim +*> +*> \param[out] GIVCOL +*> \verbatim +*> GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) +*> Each pair of numbers indicates a pair of columns to take place +*> in a Givens rotation. Not referenced if ICOMPQ = 0. +*> \endverbatim +*> +*> \param[in] LDGCOL +*> \verbatim +*> LDGCOL is INTEGER +*> The leading dimension of GIVCOL, must be at least N. +*> \endverbatim +*> +*> \param[out] GIVNUM +*> \verbatim +*> GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) +*> Each number indicates the C or S value to be used in the +*> corresponding Givens rotation. Not referenced if ICOMPQ = 0. +*> \endverbatim +*> +*> \param[in] LDGNUM +*> \verbatim +*> LDGNUM is INTEGER +*> The leading dimension of GIVNUM, must be at least N. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION +*> C contains garbage if SQRE =0 and the C-value of a Givens +*> rotation related to the right null space if SQRE = 1. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION +*> S contains garbage if SQRE =0 and the S-value of a Givens +*> rotation related to the right null space if SQRE = 1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Huan Ren, Computer Science Division, University of +*> California at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, + $ VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, + $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, + $ C, S, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, + $ NR, SQRE + DOUBLE PRECISION ALPHA, BETA, C, S +* .. +* .. Array Arguments .. + INTEGER GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ), + $ IDXQ( * ), PERM( * ) + DOUBLE PRECISION D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ), + $ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ), + $ ZW( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, EIGHT + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ EIGHT = 8.0D+0 ) +* .. +* .. Local Scalars .. +* + INTEGER I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, N, + $ NLP1, NLP2 + DOUBLE PRECISION EPS, HLFTOL, TAU, TOL, Z1 +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLAMRG, DROT, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + N = NL + NR + 1 + M = N + SQRE +* + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( NL.LT.1 ) THEN + INFO = -2 + ELSE IF( NR.LT.1 ) THEN + INFO = -3 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -4 + ELSE IF( LDGCOL.LT.N ) THEN + INFO = -22 + ELSE IF( LDGNUM.LT.N ) THEN + INFO = -24 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD7', -INFO ) + RETURN + END IF +* + NLP1 = NL + 1 + NLP2 = NL + 2 + IF( ICOMPQ.EQ.1 ) THEN + GIVPTR = 0 + END IF +* +* Generate the first part of the vector Z and move the singular +* values in the first part of D one position backward. +* + Z1 = ALPHA*VL( NLP1 ) + VL( NLP1 ) = ZERO + TAU = VF( NLP1 ) + DO 10 I = NL, 1, -1 + Z( I+1 ) = ALPHA*VL( I ) + VL( I ) = ZERO + VF( I+1 ) = VF( I ) + D( I+1 ) = D( I ) + IDXQ( I+1 ) = IDXQ( I ) + 1 + 10 CONTINUE + VF( 1 ) = TAU +* +* Generate the second part of the vector Z. +* + DO 20 I = NLP2, M + Z( I ) = BETA*VF( I ) + VF( I ) = ZERO + 20 CONTINUE +* +* Sort the singular values into increasing order +* + DO 30 I = NLP2, N + IDXQ( I ) = IDXQ( I ) + NLP1 + 30 CONTINUE +* +* DSIGMA, IDXC, IDXC, and ZW are used as storage space. +* + DO 40 I = 2, N + DSIGMA( I ) = D( IDXQ( I ) ) + ZW( I ) = Z( IDXQ( I ) ) + VFW( I ) = VF( IDXQ( I ) ) + VLW( I ) = VL( IDXQ( I ) ) + 40 CONTINUE +* + CALL DLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) ) +* + DO 50 I = 2, N + IDXI = 1 + IDX( I ) + D( I ) = DSIGMA( IDXI ) + Z( I ) = ZW( IDXI ) + VF( I ) = VFW( IDXI ) + VL( I ) = VLW( IDXI ) + 50 CONTINUE +* +* Calculate the allowable deflation tolerence +* + EPS = DLAMCH( 'Epsilon' ) + TOL = MAX( ABS( ALPHA ), ABS( BETA ) ) + TOL = EIGHT*EIGHT*EPS*MAX( ABS( D( N ) ), TOL ) +* +* There are 2 kinds of deflation -- first a value in the z-vector +* is small, second two (or more) singular values are very close +* together (their difference is small). +* +* If the value in the z-vector is small, we simply permute the +* array so that the corresponding singular value is moved to the +* end. +* +* If two values in the D-vector are close, we perform a two-sided +* rotation designed to make one of the corresponding z-vector +* entries zero, and then permute the array so that the deflated +* singular value is moved to the end. +* +* If there are multiple singular values then the problem deflates. +* Here the number of equal singular values are found. As each equal +* singular value is found, an elementary reflector is computed to +* rotate the corresponding singular subspace so that the +* corresponding components of Z are zero in this new basis. +* + K = 1 + K2 = N + 1 + DO 60 J = 2, N + IF( ABS( Z( J ) ).LE.TOL ) THEN +* +* Deflate due to small z component. +* + K2 = K2 - 1 + IDXP( K2 ) = J + IF( J.EQ.N ) + $ GO TO 100 + ELSE + JPREV = J + GO TO 70 + END IF + 60 CONTINUE + 70 CONTINUE + J = JPREV + 80 CONTINUE + J = J + 1 + IF( J.GT.N ) + $ GO TO 90 + IF( ABS( Z( J ) ).LE.TOL ) THEN +* +* Deflate due to small z component. +* + K2 = K2 - 1 + IDXP( K2 ) = J + ELSE +* +* Check if singular values are close enough to allow deflation. +* + IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN +* +* Deflation is possible. +* + S = Z( JPREV ) + C = Z( J ) +* +* Find sqrt(a**2+b**2) without overflow or +* destructive underflow. +* + TAU = DLAPY2( C, S ) + Z( J ) = TAU + Z( JPREV ) = ZERO + C = C / TAU + S = -S / TAU +* +* Record the appropriate Givens rotation +* + IF( ICOMPQ.EQ.1 ) THEN + GIVPTR = GIVPTR + 1 + IDXJP = IDXQ( IDX( JPREV )+1 ) + IDXJ = IDXQ( IDX( J )+1 ) + IF( IDXJP.LE.NLP1 ) THEN + IDXJP = IDXJP - 1 + END IF + IF( IDXJ.LE.NLP1 ) THEN + IDXJ = IDXJ - 1 + END IF + GIVCOL( GIVPTR, 2 ) = IDXJP + GIVCOL( GIVPTR, 1 ) = IDXJ + GIVNUM( GIVPTR, 2 ) = C + GIVNUM( GIVPTR, 1 ) = S + END IF + CALL DROT( 1, VF( JPREV ), 1, VF( J ), 1, C, S ) + CALL DROT( 1, VL( JPREV ), 1, VL( J ), 1, C, S ) + K2 = K2 - 1 + IDXP( K2 ) = JPREV + JPREV = J + ELSE + K = K + 1 + ZW( K ) = Z( JPREV ) + DSIGMA( K ) = D( JPREV ) + IDXP( K ) = JPREV + JPREV = J + END IF + END IF + GO TO 80 + 90 CONTINUE +* +* Record the last singular value. +* + K = K + 1 + ZW( K ) = Z( JPREV ) + DSIGMA( K ) = D( JPREV ) + IDXP( K ) = JPREV +* + 100 CONTINUE +* +* Sort the singular values into DSIGMA. The singular values which +* were not deflated go into the first K slots of DSIGMA, except +* that DSIGMA(1) is treated separately. +* + DO 110 J = 2, N + JP = IDXP( J ) + DSIGMA( J ) = D( JP ) + VFW( J ) = VF( JP ) + VLW( J ) = VL( JP ) + 110 CONTINUE + IF( ICOMPQ.EQ.1 ) THEN + DO 120 J = 2, N + JP = IDXP( J ) + PERM( J ) = IDXQ( IDX( JP )+1 ) + IF( PERM( J ).LE.NLP1 ) THEN + PERM( J ) = PERM( J ) - 1 + END IF + 120 CONTINUE + END IF +* +* The deflated singular values go back into the last N - K slots of +* D. +* + CALL DCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 ) +* +* Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and +* VL(M). +* + DSIGMA( 1 ) = ZERO + HLFTOL = TOL / TWO + IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL ) + $ DSIGMA( 2 ) = HLFTOL + IF( M.GT.N ) THEN + Z( 1 ) = DLAPY2( Z1, Z( M ) ) + IF( Z( 1 ).LE.TOL ) THEN + C = ONE + S = ZERO + Z( 1 ) = TOL + ELSE + C = Z1 / Z( 1 ) + S = -Z( M ) / Z( 1 ) + END IF + CALL DROT( 1, VF( M ), 1, VF( 1 ), 1, C, S ) + CALL DROT( 1, VL( M ), 1, VL( 1 ), 1, C, S ) + ELSE + IF( ABS( Z1 ).LE.TOL ) THEN + Z( 1 ) = TOL + ELSE + Z( 1 ) = Z1 + END IF + END IF +* +* Restore Z, VF, and VL. +* + CALL DCOPY( K-1, ZW( 2 ), 1, Z( 2 ), 1 ) + CALL DCOPY( N-1, VFW( 2 ), 1, VF( 2 ), 1 ) + CALL DCOPY( N-1, VLW( 2 ), 1, VL( 2 ), 1 ) +* + RETURN +* +* End of DLASD7 +* + END diff --git a/lib/linalg/dlasd8.f b/lib/linalg/dlasd8.f new file mode 100644 index 0000000000..fc5c48c528 --- /dev/null +++ b/lib/linalg/dlasd8.f @@ -0,0 +1,342 @@ +*> \brief \b DLASD8 finds the square roots of the roots of the secular equation, and stores, for each element in D, the distance to its two nearest poles. Used by sbdsdc. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASD8 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, +* DSIGMA, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER ICOMPQ, INFO, K, LDDIFR +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), DIFL( * ), DIFR( LDDIFR, * ), +* $ DSIGMA( * ), VF( * ), VL( * ), WORK( * ), +* $ Z( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASD8 finds the square roots of the roots of the secular equation, +*> as defined by the values in DSIGMA and Z. It makes the appropriate +*> calls to DLASD4, and stores, for each element in D, the distance +*> to its two nearest poles (elements in DSIGMA). It also updates +*> the arrays VF and VL, the first and last components of all the +*> right singular vectors of the original bidiagonal matrix. +*> +*> DLASD8 is called from DLASD6. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ICOMPQ +*> \verbatim +*> ICOMPQ is INTEGER +*> Specifies whether singular vectors are to be computed in +*> factored form in the calling routine: +*> = 0: Compute singular values only. +*> = 1: Compute singular vectors in factored form as well. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of terms in the rational function to be solved +*> by DLASD4. K >= 1. +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension ( K ) +*> On output, D contains the updated singular values. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension ( K ) +*> On entry, the first K elements of this array contain the +*> components of the deflation-adjusted updating row vector. +*> On exit, Z is updated. +*> \endverbatim +*> +*> \param[in,out] VF +*> \verbatim +*> VF is DOUBLE PRECISION array, dimension ( K ) +*> On entry, VF contains information passed through DBEDE8. +*> On exit, VF contains the first K components of the first +*> components of all right singular vectors of the bidiagonal +*> matrix. +*> \endverbatim +*> +*> \param[in,out] VL +*> \verbatim +*> VL is DOUBLE PRECISION array, dimension ( K ) +*> On entry, VL contains information passed through DBEDE8. +*> On exit, VL contains the first K components of the last +*> components of all right singular vectors of the bidiagonal +*> matrix. +*> \endverbatim +*> +*> \param[out] DIFL +*> \verbatim +*> DIFL is DOUBLE PRECISION array, dimension ( K ) +*> On exit, DIFL(I) = D(I) - DSIGMA(I). +*> \endverbatim +*> +*> \param[out] DIFR +*> \verbatim +*> DIFR is DOUBLE PRECISION array, +*> dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and +*> dimension ( K ) if ICOMPQ = 0. +*> On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not +*> defined and will not be referenced. +*> +*> If ICOMPQ = 1, DIFR(1:K,2) is an array containing the +*> normalizing factors for the right singular vector matrix. +*> \endverbatim +*> +*> \param[in] LDDIFR +*> \verbatim +*> LDDIFR is INTEGER +*> The leading dimension of DIFR, must be at least K. +*> \endverbatim +*> +*> \param[in,out] DSIGMA +*> \verbatim +*> DSIGMA is DOUBLE PRECISION array, dimension ( K ) +*> On entry, the first K elements of this array contain the old +*> roots of the deflated updating problem. These are the poles +*> of the secular equation. +*> On exit, the elements of DSIGMA may be very slightly altered +*> in value. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*K) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = 1, a singular value did not converge +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2017 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Huan Ren, Computer Science Division, University of +*> California at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, + $ DSIGMA, WORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2017 +* +* .. Scalar Arguments .. + INTEGER ICOMPQ, INFO, K, LDDIFR +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), DIFL( * ), DIFR( LDDIFR, * ), + $ DSIGMA( * ), VF( * ), VL( * ), WORK( * ), + $ Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IWK1, IWK2, IWK2I, IWK3, IWK3I, J + DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, RHO, TEMP +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLASCL, DLASD4, DLASET, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DDOT, DLAMC3, DNRM2 + EXTERNAL DDOT, DLAMC3, DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SIGN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( K.LT.1 ) THEN + INFO = -2 + ELSE IF( LDDIFR.LT.K ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD8', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( K.EQ.1 ) THEN + D( 1 ) = ABS( Z( 1 ) ) + DIFL( 1 ) = D( 1 ) + IF( ICOMPQ.EQ.1 ) THEN + DIFL( 2 ) = ONE + DIFR( 1, 2 ) = ONE + END IF + RETURN + END IF +* +* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can +* be computed with high relative accuracy (barring over/underflow). +* This is a problem on machines without a guard digit in +* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). +* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), +* which on any of these machines zeros out the bottommost +* bit of DSIGMA(I) if it is 1; this makes the subsequent +* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation +* occurs. On binary machines with a guard digit (almost all +* machines) it does not change DSIGMA(I) at all. On hexadecimal +* and decimal machines with a guard digit, it slightly +* changes the bottommost bits of DSIGMA(I). It does not account +* for hexadecimal or decimal machines without guard digits +* (we know of none). We use a subroutine call to compute +* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating +* this code. +* + DO 10 I = 1, K + DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I ) + 10 CONTINUE +* +* Book keeping. +* + IWK1 = 1 + IWK2 = IWK1 + K + IWK3 = IWK2 + K + IWK2I = IWK2 - 1 + IWK3I = IWK3 - 1 +* +* Normalize Z. +* + RHO = DNRM2( K, Z, 1 ) + CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO ) + RHO = RHO*RHO +* +* Initialize WORK(IWK3). +* + CALL DLASET( 'A', K, 1, ONE, ONE, WORK( IWK3 ), K ) +* +* Compute the updated singular values, the arrays DIFL, DIFR, +* and the updated Z. +* + DO 40 J = 1, K + CALL DLASD4( K, J, DSIGMA, Z, WORK( IWK1 ), RHO, D( J ), + $ WORK( IWK2 ), INFO ) +* +* If the root finder fails, report the convergence failure. +* + IF( INFO.NE.0 ) THEN + RETURN + END IF + WORK( IWK3I+J ) = WORK( IWK3I+J )*WORK( J )*WORK( IWK2I+J ) + DIFL( J ) = -WORK( J ) + DIFR( J, 1 ) = -WORK( J+1 ) + DO 20 I = 1, J - 1 + WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )* + $ WORK( IWK2I+I ) / ( DSIGMA( I )- + $ DSIGMA( J ) ) / ( DSIGMA( I )+ + $ DSIGMA( J ) ) + 20 CONTINUE + DO 30 I = J + 1, K + WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )* + $ WORK( IWK2I+I ) / ( DSIGMA( I )- + $ DSIGMA( J ) ) / ( DSIGMA( I )+ + $ DSIGMA( J ) ) + 30 CONTINUE + 40 CONTINUE +* +* Compute updated Z. +* + DO 50 I = 1, K + Z( I ) = SIGN( SQRT( ABS( WORK( IWK3I+I ) ) ), Z( I ) ) + 50 CONTINUE +* +* Update VF and VL. +* + DO 80 J = 1, K + DIFLJ = DIFL( J ) + DJ = D( J ) + DSIGJ = -DSIGMA( J ) + IF( J.LT.K ) THEN + DIFRJ = -DIFR( J, 1 ) + DSIGJP = -DSIGMA( J+1 ) + END IF + WORK( J ) = -Z( J ) / DIFLJ / ( DSIGMA( J )+DJ ) + DO 60 I = 1, J - 1 + WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJ )-DIFLJ ) + $ / ( DSIGMA( I )+DJ ) + 60 CONTINUE + DO 70 I = J + 1, K + WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJP )+DIFRJ ) + $ / ( DSIGMA( I )+DJ ) + 70 CONTINUE + TEMP = DNRM2( K, WORK, 1 ) + WORK( IWK2I+J ) = DDOT( K, WORK, 1, VF, 1 ) / TEMP + WORK( IWK3I+J ) = DDOT( K, WORK, 1, VL, 1 ) / TEMP + IF( ICOMPQ.EQ.1 ) THEN + DIFR( J, 2 ) = TEMP + END IF + 80 CONTINUE +* + CALL DCOPY( K, WORK( IWK2 ), 1, VF, 1 ) + CALL DCOPY( K, WORK( IWK3 ), 1, VL, 1 ) +* + RETURN +* +* End of DLASD8 +* + END + diff --git a/lib/linalg/dlasda.f b/lib/linalg/dlasda.f new file mode 100644 index 0000000000..f41a108b80 --- /dev/null +++ b/lib/linalg/dlasda.f @@ -0,0 +1,514 @@ +*> \brief \b DLASDA computes the singular value decomposition (SVD) of a real upper bidiagonal matrix with diagonal d and off-diagonal e. Used by sbdsdc. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASDA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, +* DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, +* PERM, GIVNUM, C, S, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE +* .. +* .. Array Arguments .. +* INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), +* $ K( * ), PERM( LDGCOL, * ) +* DOUBLE PRECISION C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ), +* $ E( * ), GIVNUM( LDU, * ), POLES( LDU, * ), +* $ S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ), +* $ Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Using a divide and conquer approach, DLASDA computes the singular +*> value decomposition (SVD) of a real upper bidiagonal N-by-M matrix +*> B with diagonal D and offdiagonal E, where M = N + SQRE. The +*> algorithm computes the singular values in the SVD B = U * S * VT. +*> The orthogonal matrices U and VT are optionally computed in +*> compact form. +*> +*> A related subroutine, DLASD0, computes the singular values and +*> the singular vectors in explicit form. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ICOMPQ +*> \verbatim +*> ICOMPQ is INTEGER +*> Specifies whether singular vectors are to be computed +*> in compact form, as follows +*> = 0: Compute singular values only. +*> = 1: Compute singular vectors of upper bidiagonal +*> matrix in compact form. +*> \endverbatim +*> +*> \param[in] SMLSIZ +*> \verbatim +*> SMLSIZ is INTEGER +*> The maximum size of the subproblems at the bottom of the +*> computation tree. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The row dimension of the upper bidiagonal matrix. This is +*> also the dimension of the main diagonal array D. +*> \endverbatim +*> +*> \param[in] SQRE +*> \verbatim +*> SQRE is INTEGER +*> Specifies the column dimension of the bidiagonal matrix. +*> = 0: The bidiagonal matrix has column dimension M = N; +*> = 1: The bidiagonal matrix has column dimension M = N + 1. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension ( N ) +*> On entry D contains the main diagonal of the bidiagonal +*> matrix. On exit D, if INFO = 0, contains its singular values. +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension ( M-1 ) +*> Contains the subdiagonal entries of the bidiagonal matrix. +*> On exit, E has been destroyed. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is DOUBLE PRECISION array, +*> dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced +*> if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left +*> singular vector matrices of all subproblems at the bottom +*> level. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER, LDU = > N. +*> The leading dimension of arrays U, VT, DIFL, DIFR, POLES, +*> GIVNUM, and Z. +*> \endverbatim +*> +*> \param[out] VT +*> \verbatim +*> VT is DOUBLE PRECISION array, +*> dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced +*> if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT**T contains the right +*> singular vector matrices of all subproblems at the bottom +*> level. +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER array, +*> dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0. +*> If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th +*> secular equation on the computation tree. +*> \endverbatim +*> +*> \param[out] DIFL +*> \verbatim +*> DIFL is DOUBLE PRECISION array, dimension ( LDU, NLVL ), +*> where NLVL = floor(log_2 (N/SMLSIZ))). +*> \endverbatim +*> +*> \param[out] DIFR +*> \verbatim +*> DIFR is DOUBLE PRECISION array, +*> dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and +*> dimension ( N ) if ICOMPQ = 0. +*> If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1) +*> record distances between singular values on the I-th +*> level and singular values on the (I -1)-th level, and +*> DIFR(1:N, 2 * I ) contains the normalizing factors for +*> the right singular vector matrix. See DLASD8 for details. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, +*> dimension ( LDU, NLVL ) if ICOMPQ = 1 and +*> dimension ( N ) if ICOMPQ = 0. +*> The first K elements of Z(1, I) contain the components of +*> the deflation-adjusted updating row vector for subproblems +*> on the I-th level. +*> \endverbatim +*> +*> \param[out] POLES +*> \verbatim +*> POLES is DOUBLE PRECISION array, +*> dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced +*> if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and +*> POLES(1, 2*I) contain the new and old singular values +*> involved in the secular equations on the I-th level. +*> \endverbatim +*> +*> \param[out] GIVPTR +*> \verbatim +*> GIVPTR is INTEGER array, +*> dimension ( N ) if ICOMPQ = 1, and not referenced if +*> ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records +*> the number of Givens rotations performed on the I-th +*> problem on the computation tree. +*> \endverbatim +*> +*> \param[out] GIVCOL +*> \verbatim +*> GIVCOL is INTEGER array, +*> dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not +*> referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, +*> GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations +*> of Givens rotations performed on the I-th level on the +*> computation tree. +*> \endverbatim +*> +*> \param[in] LDGCOL +*> \verbatim +*> LDGCOL is INTEGER, LDGCOL = > N. +*> The leading dimension of arrays GIVCOL and PERM. +*> \endverbatim +*> +*> \param[out] PERM +*> \verbatim +*> PERM is INTEGER array, +*> dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced +*> if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records +*> permutations done on the I-th level of the computation tree. +*> \endverbatim +*> +*> \param[out] GIVNUM +*> \verbatim +*> GIVNUM is DOUBLE PRECISION array, +*> dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not +*> referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, +*> GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S- +*> values of Givens rotations performed on the I-th level on +*> the computation tree. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION array, +*> dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. +*> If ICOMPQ = 1 and the I-th subproblem is not square, on exit, +*> C( I ) contains the C-value of a Givens rotation related to +*> the right null space of the I-th subproblem. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension ( N ) if +*> ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1 +*> and the I-th subproblem is not square, on exit, S( I ) +*> contains the S-value of a Givens rotation related to +*> the right null space of the I-th subproblem. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)). +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (7*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = 1, a singular value did not converge +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2017 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Huan Ren, Computer Science Division, University of +*> California at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, + $ DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, + $ PERM, GIVNUM, C, S, WORK, IWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2017 +* +* .. Scalar Arguments .. + INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE +* .. +* .. Array Arguments .. + INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), + $ K( * ), PERM( LDGCOL, * ) + DOUBLE PRECISION C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ), + $ E( * ), GIVNUM( LDU, * ), POLES( LDU, * ), + $ S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ), + $ Z( LDU, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, I1, IC, IDXQ, IDXQI, IM1, INODE, ITEMP, IWK, + $ J, LF, LL, LVL, LVL2, M, NCC, ND, NDB1, NDIML, + $ NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, NRU, + $ NWORK1, NWORK2, SMLSZP, SQREI, VF, VFI, VL, VLI + DOUBLE PRECISION ALPHA, BETA +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLASD6, DLASDQ, DLASDT, DLASET, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( SMLSIZ.LT.3 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -4 + ELSE IF( LDU.LT.( N+SQRE ) ) THEN + INFO = -8 + ELSE IF( LDGCOL.LT.N ) THEN + INFO = -17 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASDA', -INFO ) + RETURN + END IF +* + M = N + SQRE +* +* If the input matrix is too small, call DLASDQ to find the SVD. +* + IF( N.LE.SMLSIZ ) THEN + IF( ICOMPQ.EQ.0 ) THEN + CALL DLASDQ( 'U', SQRE, N, 0, 0, 0, D, E, VT, LDU, U, LDU, + $ U, LDU, WORK, INFO ) + ELSE + CALL DLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDU, U, LDU, + $ U, LDU, WORK, INFO ) + END IF + RETURN + END IF +* +* Book-keeping and set up the computation tree. +* + INODE = 1 + NDIML = INODE + N + NDIMR = NDIML + N + IDXQ = NDIMR + N + IWK = IDXQ + N +* + NCC = 0 + NRU = 0 +* + SMLSZP = SMLSIZ + 1 + VF = 1 + VL = VF + M + NWORK1 = VL + M + NWORK2 = NWORK1 + SMLSZP*SMLSZP +* + CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ), + $ IWORK( NDIMR ), SMLSIZ ) +* +* for the nodes on bottom level of the tree, solve +* their subproblems by DLASDQ. +* + NDB1 = ( ND+1 ) / 2 + DO 30 I = NDB1, ND +* +* IC : center row of each node +* NL : number of rows of left subproblem +* NR : number of rows of right subproblem +* NLF: starting row of the left subproblem +* NRF: starting row of the right subproblem +* + I1 = I - 1 + IC = IWORK( INODE+I1 ) + NL = IWORK( NDIML+I1 ) + NLP1 = NL + 1 + NR = IWORK( NDIMR+I1 ) + NLF = IC - NL + NRF = IC + 1 + IDXQI = IDXQ + NLF - 2 + VFI = VF + NLF - 1 + VLI = VL + NLF - 1 + SQREI = 1 + IF( ICOMPQ.EQ.0 ) THEN + CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, WORK( NWORK1 ), + $ SMLSZP ) + CALL DLASDQ( 'U', SQREI, NL, NLP1, NRU, NCC, D( NLF ), + $ E( NLF ), WORK( NWORK1 ), SMLSZP, + $ WORK( NWORK2 ), NL, WORK( NWORK2 ), NL, + $ WORK( NWORK2 ), INFO ) + ITEMP = NWORK1 + NL*SMLSZP + CALL DCOPY( NLP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 ) + CALL DCOPY( NLP1, WORK( ITEMP ), 1, WORK( VLI ), 1 ) + ELSE + CALL DLASET( 'A', NL, NL, ZERO, ONE, U( NLF, 1 ), LDU ) + CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, VT( NLF, 1 ), LDU ) + CALL DLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ), + $ E( NLF ), VT( NLF, 1 ), LDU, U( NLF, 1 ), LDU, + $ U( NLF, 1 ), LDU, WORK( NWORK1 ), INFO ) + CALL DCOPY( NLP1, VT( NLF, 1 ), 1, WORK( VFI ), 1 ) + CALL DCOPY( NLP1, VT( NLF, NLP1 ), 1, WORK( VLI ), 1 ) + END IF + IF( INFO.NE.0 ) THEN + RETURN + END IF + DO 10 J = 1, NL + IWORK( IDXQI+J ) = J + 10 CONTINUE + IF( ( I.EQ.ND ) .AND. ( SQRE.EQ.0 ) ) THEN + SQREI = 0 + ELSE + SQREI = 1 + END IF + IDXQI = IDXQI + NLP1 + VFI = VFI + NLP1 + VLI = VLI + NLP1 + NRP1 = NR + SQREI + IF( ICOMPQ.EQ.0 ) THEN + CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, WORK( NWORK1 ), + $ SMLSZP ) + CALL DLASDQ( 'U', SQREI, NR, NRP1, NRU, NCC, D( NRF ), + $ E( NRF ), WORK( NWORK1 ), SMLSZP, + $ WORK( NWORK2 ), NR, WORK( NWORK2 ), NR, + $ WORK( NWORK2 ), INFO ) + ITEMP = NWORK1 + ( NRP1-1 )*SMLSZP + CALL DCOPY( NRP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 ) + CALL DCOPY( NRP1, WORK( ITEMP ), 1, WORK( VLI ), 1 ) + ELSE + CALL DLASET( 'A', NR, NR, ZERO, ONE, U( NRF, 1 ), LDU ) + CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, VT( NRF, 1 ), LDU ) + CALL DLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ), + $ E( NRF ), VT( NRF, 1 ), LDU, U( NRF, 1 ), LDU, + $ U( NRF, 1 ), LDU, WORK( NWORK1 ), INFO ) + CALL DCOPY( NRP1, VT( NRF, 1 ), 1, WORK( VFI ), 1 ) + CALL DCOPY( NRP1, VT( NRF, NRP1 ), 1, WORK( VLI ), 1 ) + END IF + IF( INFO.NE.0 ) THEN + RETURN + END IF + DO 20 J = 1, NR + IWORK( IDXQI+J ) = J + 20 CONTINUE + 30 CONTINUE +* +* Now conquer each subproblem bottom-up. +* + J = 2**NLVL + DO 50 LVL = NLVL, 1, -1 + LVL2 = LVL*2 - 1 +* +* Find the first node LF and last node LL on +* the current level LVL. +* + IF( LVL.EQ.1 ) THEN + LF = 1 + LL = 1 + ELSE + LF = 2**( LVL-1 ) + LL = 2*LF - 1 + END IF + DO 40 I = LF, LL + IM1 = I - 1 + IC = IWORK( INODE+IM1 ) + NL = IWORK( NDIML+IM1 ) + NR = IWORK( NDIMR+IM1 ) + NLF = IC - NL + NRF = IC + 1 + IF( I.EQ.LL ) THEN + SQREI = SQRE + ELSE + SQREI = 1 + END IF + VFI = VF + NLF - 1 + VLI = VL + NLF - 1 + IDXQI = IDXQ + NLF - 1 + ALPHA = D( IC ) + BETA = E( IC ) + IF( ICOMPQ.EQ.0 ) THEN + CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ), + $ WORK( VFI ), WORK( VLI ), ALPHA, BETA, + $ IWORK( IDXQI ), PERM, GIVPTR( 1 ), GIVCOL, + $ LDGCOL, GIVNUM, LDU, POLES, DIFL, DIFR, Z, + $ K( 1 ), C( 1 ), S( 1 ), WORK( NWORK1 ), + $ IWORK( IWK ), INFO ) + ELSE + J = J - 1 + CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ), + $ WORK( VFI ), WORK( VLI ), ALPHA, BETA, + $ IWORK( IDXQI ), PERM( NLF, LVL ), + $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL, + $ GIVNUM( NLF, LVL2 ), LDU, + $ POLES( NLF, LVL2 ), DIFL( NLF, LVL ), + $ DIFR( NLF, LVL2 ), Z( NLF, LVL ), K( J ), + $ C( J ), S( J ), WORK( NWORK1 ), + $ IWORK( IWK ), INFO ) + END IF + IF( INFO.NE.0 ) THEN + RETURN + END IF + 40 CONTINUE + 50 CONTINUE +* + RETURN +* +* End of DLASDA +* + END diff --git a/lib/linalg/dlasdq.f b/lib/linalg/dlasdq.f new file mode 100644 index 0000000000..e7d3575a98 --- /dev/null +++ b/lib/linalg/dlasdq.f @@ -0,0 +1,413 @@ +*> \brief \b DLASDQ computes the SVD of a real bidiagonal matrix with diagonal d and off-diagonal e. Used by sbdsdc. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASDQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, +* U, LDU, C, LDC, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE +* .. +* .. Array Arguments .. +* DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), +* $ VT( LDVT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASDQ computes the singular value decomposition (SVD) of a real +*> (upper or lower) bidiagonal matrix with diagonal D and offdiagonal +*> E, accumulating the transformations if desired. Letting B denote +*> the input bidiagonal matrix, the algorithm computes orthogonal +*> matrices Q and P such that B = Q * S * P**T (P**T denotes the transpose +*> of P). The singular values S are overwritten on D. +*> +*> The input matrix U is changed to U * Q if desired. +*> The input matrix VT is changed to P**T * VT if desired. +*> The input matrix C is changed to Q**T * C if desired. +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices With +*> Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, +*> LAPACK Working Note #3, for a detailed description of the algorithm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the input bidiagonal matrix +*> is upper or lower bidiagonal, and whether it is square are +*> not. +*> UPLO = 'U' or 'u' B is upper bidiagonal. +*> UPLO = 'L' or 'l' B is lower bidiagonal. +*> \endverbatim +*> +*> \param[in] SQRE +*> \verbatim +*> SQRE is INTEGER +*> = 0: then the input matrix is N-by-N. +*> = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and +*> (N+1)-by-N if UPLU = 'L'. +*> +*> The bidiagonal matrix has +*> N = NL + NR + 1 rows and +*> M = N + SQRE >= N columns. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of rows and columns +*> in the matrix. N must be at least 0. +*> \endverbatim +*> +*> \param[in] NCVT +*> \verbatim +*> NCVT is INTEGER +*> On entry, NCVT specifies the number of columns of +*> the matrix VT. NCVT must be at least 0. +*> \endverbatim +*> +*> \param[in] NRU +*> \verbatim +*> NRU is INTEGER +*> On entry, NRU specifies the number of rows of +*> the matrix U. NRU must be at least 0. +*> \endverbatim +*> +*> \param[in] NCC +*> \verbatim +*> NCC is INTEGER +*> On entry, NCC specifies the number of columns of +*> the matrix C. NCC must be at least 0. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, D contains the diagonal entries of the +*> bidiagonal matrix whose SVD is desired. On normal exit, +*> D contains the singular values in ascending order. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array. +*> dimension is (N-1) if SQRE = 0 and N if SQRE = 1. +*> On entry, the entries of E contain the offdiagonal entries +*> of the bidiagonal matrix whose SVD is desired. On normal +*> exit, E will contain 0. If the algorithm does not converge, +*> D and E will contain the diagonal and superdiagonal entries +*> of a bidiagonal matrix orthogonally equivalent to the one +*> given as input. +*> \endverbatim +*> +*> \param[in,out] VT +*> \verbatim +*> VT is DOUBLE PRECISION array, dimension (LDVT, NCVT) +*> On entry, contains a matrix which on exit has been +*> premultiplied by P**T, dimension N-by-NCVT if SQRE = 0 +*> and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0). +*> \endverbatim +*> +*> \param[in] LDVT +*> \verbatim +*> LDVT is INTEGER +*> On entry, LDVT specifies the leading dimension of VT as +*> declared in the calling (sub) program. LDVT must be at +*> least 1. If NCVT is nonzero LDVT must also be at least N. +*> \endverbatim +*> +*> \param[in,out] U +*> \verbatim +*> U is DOUBLE PRECISION array, dimension (LDU, N) +*> On entry, contains a matrix which on exit has been +*> postmultiplied by Q, dimension NRU-by-N if SQRE = 0 +*> and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0). +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> On entry, LDU specifies the leading dimension of U as +*> declared in the calling (sub) program. LDU must be at +*> least max( 1, NRU ) . +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC, NCC) +*> On entry, contains an N-by-NCC matrix which on exit +*> has been premultiplied by Q**T dimension N-by-NCC if SQRE = 0 +*> and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the leading dimension of C as +*> declared in the calling (sub) program. LDC must be at +*> least 1. If NCC is nonzero, LDC must also be at least N. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (4*N) +*> Workspace. Only referenced if one of NCVT, NRU, or NCC is +*> nonzero, and if N is at least 2. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> On exit, a value of 0 indicates a successful exit. +*> If INFO < 0, argument number -INFO is illegal. +*> If INFO > 0, the algorithm did not converge, and INFO +*> specifies how many superdiagonals did not converge. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Huan Ren, Computer Science Division, University of +*> California at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, + $ U, LDU, C, LDC, WORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), + $ VT( LDVT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ROTATE + INTEGER I, ISUB, IUPLO, J, NP1, SQRE1 + DOUBLE PRECISION CS, R, SMIN, SN +* .. +* .. External Subroutines .. + EXTERNAL DBDSQR, DLARTG, DLASR, DSWAP, XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IUPLO = 0 + IF( LSAME( UPLO, 'U' ) ) + $ IUPLO = 1 + IF( LSAME( UPLO, 'L' ) ) + $ IUPLO = 2 + IF( IUPLO.EQ.0 ) THEN + INFO = -1 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NCVT.LT.0 ) THEN + INFO = -4 + ELSE IF( NRU.LT.0 ) THEN + INFO = -5 + ELSE IF( NCC.LT.0 ) THEN + INFO = -6 + ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR. + $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN + INFO = -10 + ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN + INFO = -12 + ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR. + $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN + INFO = -14 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASDQ', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) + $ RETURN +* +* ROTATE is true if any singular vectors desired, false otherwise +* + ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 ) + NP1 = N + 1 + SQRE1 = SQRE +* +* If matrix non-square upper bidiagonal, rotate to be lower +* bidiagonal. The rotations are on the right. +* + IF( ( IUPLO.EQ.1 ) .AND. ( SQRE1.EQ.1 ) ) THEN + DO 10 I = 1, N - 1 + CALL DLARTG( D( I ), E( I ), CS, SN, R ) + D( I ) = R + E( I ) = SN*D( I+1 ) + D( I+1 ) = CS*D( I+1 ) + IF( ROTATE ) THEN + WORK( I ) = CS + WORK( N+I ) = SN + END IF + 10 CONTINUE + CALL DLARTG( D( N ), E( N ), CS, SN, R ) + D( N ) = R + E( N ) = ZERO + IF( ROTATE ) THEN + WORK( N ) = CS + WORK( N+N ) = SN + END IF + IUPLO = 2 + SQRE1 = 0 +* +* Update singular vectors if desired. +* + IF( NCVT.GT.0 ) + $ CALL DLASR( 'L', 'V', 'F', NP1, NCVT, WORK( 1 ), + $ WORK( NP1 ), VT, LDVT ) + END IF +* +* If matrix lower bidiagonal, rotate to be upper bidiagonal +* by applying Givens rotations on the left. +* + IF( IUPLO.EQ.2 ) THEN + DO 20 I = 1, N - 1 + CALL DLARTG( D( I ), E( I ), CS, SN, R ) + D( I ) = R + E( I ) = SN*D( I+1 ) + D( I+1 ) = CS*D( I+1 ) + IF( ROTATE ) THEN + WORK( I ) = CS + WORK( N+I ) = SN + END IF + 20 CONTINUE +* +* If matrix (N+1)-by-N lower bidiagonal, one additional +* rotation is needed. +* + IF( SQRE1.EQ.1 ) THEN + CALL DLARTG( D( N ), E( N ), CS, SN, R ) + D( N ) = R + IF( ROTATE ) THEN + WORK( N ) = CS + WORK( N+N ) = SN + END IF + END IF +* +* Update singular vectors if desired. +* + IF( NRU.GT.0 ) THEN + IF( SQRE1.EQ.0 ) THEN + CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), + $ WORK( NP1 ), U, LDU ) + ELSE + CALL DLASR( 'R', 'V', 'F', NRU, NP1, WORK( 1 ), + $ WORK( NP1 ), U, LDU ) + END IF + END IF + IF( NCC.GT.0 ) THEN + IF( SQRE1.EQ.0 ) THEN + CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), + $ WORK( NP1 ), C, LDC ) + ELSE + CALL DLASR( 'L', 'V', 'F', NP1, NCC, WORK( 1 ), + $ WORK( NP1 ), C, LDC ) + END IF + END IF + END IF +* +* Call DBDSQR to compute the SVD of the reduced real +* N-by-N upper bidiagonal matrix. +* + CALL DBDSQR( 'U', N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, + $ LDC, WORK, INFO ) +* +* Sort the singular values into ascending order (insertion sort on +* singular values, but only one transposition per singular vector) +* + DO 40 I = 1, N +* +* Scan for smallest D(I). +* + ISUB = I + SMIN = D( I ) + DO 30 J = I + 1, N + IF( D( J ).LT.SMIN ) THEN + ISUB = J + SMIN = D( J ) + END IF + 30 CONTINUE + IF( ISUB.NE.I ) THEN +* +* Swap singular values and vectors. +* + D( ISUB ) = D( I ) + D( I ) = SMIN + IF( NCVT.GT.0 ) + $ CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( I, 1 ), LDVT ) + IF( NRU.GT.0 ) + $ CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, I ), 1 ) + IF( NCC.GT.0 ) + $ CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( I, 1 ), LDC ) + END IF + 40 CONTINUE +* + RETURN +* +* End of DLASDQ +* + END diff --git a/lib/linalg/dlasdt.f b/lib/linalg/dlasdt.f new file mode 100644 index 0000000000..37da2d035e --- /dev/null +++ b/lib/linalg/dlasdt.f @@ -0,0 +1,172 @@ +*> \brief \b DLASDT creates a tree of subproblems for bidiagonal divide and conquer. Used by sbdsdc. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASDT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB ) +* +* .. Scalar Arguments .. +* INTEGER LVL, MSUB, N, ND +* .. +* .. Array Arguments .. +* INTEGER INODE( * ), NDIML( * ), NDIMR( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASDT creates a tree of subproblems for bidiagonal divide and +*> conquer. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, the number of diagonal elements of the +*> bidiagonal matrix. +*> \endverbatim +*> +*> \param[out] LVL +*> \verbatim +*> LVL is INTEGER +*> On exit, the number of levels on the computation tree. +*> \endverbatim +*> +*> \param[out] ND +*> \verbatim +*> ND is INTEGER +*> On exit, the number of nodes on the tree. +*> \endverbatim +*> +*> \param[out] INODE +*> \verbatim +*> INODE is INTEGER array, dimension ( N ) +*> On exit, centers of subproblems. +*> \endverbatim +*> +*> \param[out] NDIML +*> \verbatim +*> NDIML is INTEGER array, dimension ( N ) +*> On exit, row dimensions of left children. +*> \endverbatim +*> +*> \param[out] NDIMR +*> \verbatim +*> NDIMR is INTEGER array, dimension ( N ) +*> On exit, row dimensions of right children. +*> \endverbatim +*> +*> \param[in] MSUB +*> \verbatim +*> MSUB is INTEGER +*> On entry, the maximum row dimension each subproblem at the +*> bottom of the tree can be of. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Ming Gu and Huan Ren, Computer Science Division, University of +*> California at Berkeley, USA +*> +* ===================================================================== + SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER LVL, MSUB, N, ND +* .. +* .. Array Arguments .. + INTEGER INODE( * ), NDIML( * ), NDIMR( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IL, IR, LLST, MAXN, NCRNT, NLVL + DOUBLE PRECISION TEMP +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, INT, LOG, MAX +* .. +* .. Executable Statements .. +* +* Find the number of levels on the tree. +* + MAXN = MAX( 1, N ) + TEMP = LOG( DBLE( MAXN ) / DBLE( MSUB+1 ) ) / LOG( TWO ) + LVL = INT( TEMP ) + 1 +* + I = N / 2 + INODE( 1 ) = I + 1 + NDIML( 1 ) = I + NDIMR( 1 ) = N - I - 1 + IL = 0 + IR = 1 + LLST = 1 + DO 20 NLVL = 1, LVL - 1 +* +* Constructing the tree at (NLVL+1)-st level. The number of +* nodes created on this level is LLST * 2. +* + DO 10 I = 0, LLST - 1 + IL = IL + 2 + IR = IR + 2 + NCRNT = LLST + I + NDIML( IL ) = NDIML( NCRNT ) / 2 + NDIMR( IL ) = NDIML( NCRNT ) - NDIML( IL ) - 1 + INODE( IL ) = INODE( NCRNT ) - NDIMR( IL ) - 1 + NDIML( IR ) = NDIMR( NCRNT ) / 2 + NDIMR( IR ) = NDIMR( NCRNT ) - NDIML( IR ) - 1 + INODE( IR ) = INODE( NCRNT ) + NDIML( IR ) + 1 + 10 CONTINUE + LLST = LLST*2 + 20 CONTINUE + ND = LLST*2 - 1 +* + RETURN +* +* End of DLASDT +* + END From 2e7b9197746af031a94a0032d5e77622ec1e09ca Mon Sep 17 00:00:00 2001 From: Christoph Junghans Date: Fri, 18 May 2018 15:17:13 -0600 Subject: [PATCH 7/9] linalg: update to netlib lapack-3.7.1 --- cmake/CMakeLists.txt | 2 +- lib/linalg/dasum.f | 42 +- lib/linalg/daxpy.f | 59 ++- lib/linalg/dbdsqr.f | 79 ++-- lib/linalg/dcabs1.f | 32 +- lib/linalg/dcopy.f | 59 ++- lib/linalg/ddot.f | 53 ++- lib/linalg/dgebd2.f | 38 +- lib/linalg/dgebrd.f | 38 +- lib/linalg/dgecon.f | 36 +- lib/linalg/dgelq2.f | 36 +- lib/linalg/dgelqf.f | 36 +- lib/linalg/dgemm.f | 48 +- lib/linalg/dgemv.f | 52 +-- lib/linalg/dgeqr2.f | 36 +- lib/linalg/dgeqrf.f | 36 +- lib/linalg/dger.f | 28 +- lib/linalg/dgesv.f | 34 +- lib/linalg/dgesvd.f | 671 ++++++++++++++-------------- lib/linalg/dgetf2.f | 64 +-- lib/linalg/dgetrf.f | 42 +- lib/linalg/dgetrf2.f | 272 ++++++++++++ lib/linalg/dgetri.f | 36 +- lib/linalg/dgetrs.f | 36 +- lib/linalg/disnan.f | 42 +- lib/linalg/dlabad.f | 38 +- lib/linalg/dlabrd.f | 38 +- lib/linalg/dlacn2.f | 38 +- lib/linalg/dlacpy.f | 38 +- lib/linalg/dladiv.f | 194 ++++++-- lib/linalg/dlae2.f | 38 +- lib/linalg/dlaed0.f | 36 +- lib/linalg/dlaed1.f | 38 +- lib/linalg/dlaed2.f | 40 +- lib/linalg/dlaed3.f | 38 +- lib/linalg/dlaed4.f | 36 +- lib/linalg/dlaed5.f | 36 +- lib/linalg/dlaed6.f | 47 +- lib/linalg/dlaed7.f | 40 +- lib/linalg/dlaed8.f | 40 +- lib/linalg/dlaed9.f | 36 +- lib/linalg/dlaeda.f | 36 +- lib/linalg/dlaev2.f | 38 +- lib/linalg/dlaisnan.f | 42 +- lib/linalg/dlamch.f | 905 +++++--------------------------------- lib/linalg/dlamrg.f | 38 +- lib/linalg/dlange.f | 36 +- lib/linalg/dlanst.f | 38 +- lib/linalg/dlansy.f | 36 +- lib/linalg/dlapy2.f | 66 +-- lib/linalg/dlapy3.f | 38 +- lib/linalg/dlarf.f | 36 +- lib/linalg/dlarfb.f | 328 ++++++-------- lib/linalg/dlarfg.f | 36 +- lib/linalg/dlarft.f | 48 +- lib/linalg/dlartg.f | 38 +- lib/linalg/dlas2.f | 38 +- lib/linalg/dlascl.f | 44 +- lib/linalg/dlaset.f | 40 +- lib/linalg/dlasq1.f | 42 +- lib/linalg/dlasq2.f | 96 ++-- lib/linalg/dlasq3.f | 62 +-- lib/linalg/dlasq4.f | 59 ++- lib/linalg/dlasq5.f | 100 ++--- lib/linalg/dlasq6.f | 48 +- lib/linalg/dlasr.f | 78 ++-- lib/linalg/dlasrt.f | 38 +- lib/linalg/dlassq.f | 38 +- lib/linalg/dlasv2.f | 38 +- lib/linalg/dlaswp.f | 56 +-- lib/linalg/dlatrd.f | 36 +- lib/linalg/dlatrs.f | 36 +- lib/linalg/dnrm2.f | 42 +- lib/linalg/dorg2l.f | 36 +- lib/linalg/dorg2r.f | 36 +- lib/linalg/dorgbr.f | 35 +- lib/linalg/dorgl2.f | 36 +- lib/linalg/dorglq.f | 36 +- lib/linalg/dorgql.f | 36 +- lib/linalg/dorgqr.f | 36 +- lib/linalg/dorgtr.f | 36 +- lib/linalg/dorm2l.f | 36 +- lib/linalg/dorm2r.f | 36 +- lib/linalg/dormbr.f | 36 +- lib/linalg/dorml2.f | 36 +- lib/linalg/dormlq.f | 69 ++- lib/linalg/dormql.f | 79 ++-- lib/linalg/dormqr.f | 69 ++- lib/linalg/dormtr.f | 36 +- lib/linalg/dpotf2.f | 36 +- lib/linalg/dpotrf.f | 44 +- lib/linalg/drot.f | 63 ++- lib/linalg/drscl.f | 36 +- lib/linalg/dscal.f | 50 ++- lib/linalg/dstedc.f | 89 ++-- lib/linalg/dsteqr.f | 36 +- lib/linalg/dsterf.f | 38 +- lib/linalg/dswap.f | 57 ++- lib/linalg/dsyev.f | 36 +- lib/linalg/dsyevd.f | 36 +- lib/linalg/dsygs2.f | 36 +- lib/linalg/dsygst.f | 36 +- lib/linalg/dsygv.f | 38 +- lib/linalg/dsygvd.f | 38 +- lib/linalg/dsymm.f | 28 +- lib/linalg/dsymv.f | 28 +- lib/linalg/dsyr2.f | 28 +- lib/linalg/dsyr2k.f | 28 +- lib/linalg/dsyrk.f | 26 +- lib/linalg/dsytd2.f | 36 +- lib/linalg/dsytrd.f | 36 +- lib/linalg/dtrmm.f | 26 +- lib/linalg/dtrmv.f | 28 +- lib/linalg/dtrsm.f | 28 +- lib/linalg/dtrsv.f | 26 +- lib/linalg/dtrti2.f | 36 +- lib/linalg/dtrtri.f | 36 +- lib/linalg/dznrm2.f | 43 +- lib/linalg/idamax.f | 44 +- lib/linalg/ieeeck.f | 38 +- lib/linalg/iladlc.f | 38 +- lib/linalg/iladlr.f | 38 +- lib/linalg/ilaenv.f | 127 +++++- lib/linalg/ilazlc.f | 36 +- lib/linalg/ilazlr.f | 36 +- lib/linalg/iparam2stage.F | 386 ++++++++++++++++ lib/linalg/iparmq.f | 153 +++++-- lib/linalg/lsame.f | 20 +- lib/linalg/xerbla.f | 38 +- lib/linalg/zaxpy.f | 59 ++- lib/linalg/zcopy.f | 53 ++- lib/linalg/zdotc.f | 57 ++- lib/linalg/zdscal.f | 48 +- lib/linalg/zgemm.f | 60 ++- lib/linalg/zgemv.f | 52 +-- lib/linalg/zgerc.f | 28 +- lib/linalg/zheev.f | 36 +- lib/linalg/zhemv.f | 28 +- lib/linalg/zher2.f | 28 +- lib/linalg/zher2k.f | 28 +- lib/linalg/zhetd2.f | 36 +- lib/linalg/zhetrd.f | 36 +- lib/linalg/zhpr.f | 26 +- lib/linalg/zlacgv.f | 36 +- lib/linalg/zladiv.f | 36 +- lib/linalg/zlanhe.f | 36 +- lib/linalg/zlarf.f | 36 +- lib/linalg/zlarfb.f | 312 ++++++------- lib/linalg/zlarfg.f | 36 +- lib/linalg/zlarft.f | 52 +-- lib/linalg/zlascl.f | 42 +- lib/linalg/zlaset.f | 38 +- lib/linalg/zlasr.f | 66 +-- lib/linalg/zlassq.f | 36 +- lib/linalg/zlatrd.f | 36 +- lib/linalg/zpptrf.f | 36 +- lib/linalg/zpptri.f | 36 +- lib/linalg/zscal.f | 48 +- lib/linalg/zsteqr.f | 36 +- lib/linalg/zswap.f | 53 ++- lib/linalg/ztpmv.f | 30 +- lib/linalg/ztpsv.f | 26 +- lib/linalg/ztptri.f | 36 +- lib/linalg/ztrmm.f | 28 +- lib/linalg/ztrmv.f | 30 +- lib/linalg/zung2l.f | 36 +- lib/linalg/zung2r.f | 36 +- lib/linalg/zungl2.f | 36 +- lib/linalg/zungql.f | 36 +- lib/linalg/zungqr.f | 36 +- lib/linalg/zungtr.f | 36 +- 171 files changed, 5320 insertions(+), 4660 deletions(-) create mode 100644 lib/linalg/dgetrf2.f create mode 100644 lib/linalg/iparam2stage.F diff --git a/cmake/CMakeLists.txt b/cmake/CMakeLists.txt index 5b52a7d6e6..ae83ce7e4b 100644 --- a/cmake/CMakeLists.txt +++ b/cmake/CMakeLists.txt @@ -203,7 +203,7 @@ if(PKG_MSCG OR PKG_USER-ATC OR PKG_USER-AWPMD OR PKG_USER-QUIP OR PKG_LATTE) find_package(LAPACK) if(NOT LAPACK_FOUND) enable_language(Fortran) - file(GLOB LAPACK_SOURCES ${LAMMPS_LIB_SOURCE_DIR}/linalg/*.f) + file(GLOB LAPACK_SOURCES ${LAMMPS_LIB_SOURCE_DIR}/linalg/*.[fF]) add_library(linalg STATIC ${LAPACK_SOURCES}) set(LAPACK_LIBRARIES linalg) endif() diff --git a/lib/linalg/dasum.f b/lib/linalg/dasum.f index c1bd78ac81..cc5977f770 100644 --- a/lib/linalg/dasum.f +++ b/lib/linalg/dasum.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * .. * .. Array Arguments .. * DOUBLE PRECISION DX(*) * .. -* +* * *> \par Purpose: * ============= @@ -26,15 +26,35 @@ *> DASUM takes the sum of the absolute values. *> \endverbatim * +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +* * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * @@ -51,10 +71,10 @@ * ===================================================================== DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lib/linalg/daxpy.f b/lib/linalg/daxpy.f index 64a02d68bc..cb94fc1e0a 100644 --- a/lib/linalg/daxpy.f +++ b/lib/linalg/daxpy.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION DA * INTEGER INCX,INCY,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION DX(*),DY(*) * .. -* +* * *> \par Purpose: * ============= @@ -28,15 +28,52 @@ *> uses unrolled loops for increments equal to one. *> \endverbatim * +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DA +*> \verbatim +*> DA is DOUBLE PRECISION +*> On entry, DA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +*> +*> \param[in,out] DY +*> \verbatim +*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of DY +*> \endverbatim +* * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * @@ -52,10 +89,10 @@ * ===================================================================== SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION DA diff --git a/lib/linalg/dbdsqr.f b/lib/linalg/dbdsqr.f index 007e99779b..93db95e7a8 100644 --- a/lib/linalg/dbdsqr.f +++ b/lib/linalg/dbdsqr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DBDSQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DBDSQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, * LDU, C, LDC, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU @@ -29,7 +29,7 @@ * DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -40,9 +40,9 @@ *> left singular vectors from the singular value decomposition (SVD) of *> a real N-by-N (upper or lower) bidiagonal matrix B using the implicit *> zero-shift QR algorithm. The SVD of B has the form -*> +*> *> B = Q * S * P**T -*> +*> *> where S is the diagonal matrix of singular values, Q is an orthogonal *> matrix of left singular vectors, and P is an orthogonal matrix of *> right singular vectors. If left singular vectors are requested, this @@ -113,7 +113,7 @@ *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> On entry, the N-1 offdiagonal elements of the bidiagonal -*> matrix B. +*> matrix B. *> On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E *> will contain the diagonal and superdiagonal elements of a *> bidiagonal matrix orthogonally equivalent to the one given @@ -179,7 +179,7 @@ *> = 1, a split was marked by a positive value in E *> = 2, current block of Z not diagonalized after 30*N *> iterations (in inner while loop) -*> = 3, termination criterion of outer while loop not met +*> = 3, termination criterion of outer while loop not met *> (program created more than N unreduced blocks) *> else NCVT = NRU = NCC = 0, *> the algorithm did not converge; D and E contain the @@ -212,17 +212,28 @@ *> algorithm through its inner loop. The algorithms stops *> (and so fails to converge) if the number of passes *> through the inner loop exceeds MAXITR*N**2. +*> +*> \endverbatim +* +*> \par Note: +* =========== +*> +*> \verbatim +*> Bug report from Cezary Dendek. +*> On March 23rd 2017, the INTEGER variable MAXIT = MAXITR*N**2 is +*> removed since it can overflow pretty easily (for N larger or equal +*> than 18,919). We instead use MAXITDIVN = MAXITR*N. *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2017 * *> \ingroup auxOTHERcomputational * @@ -230,10 +241,10 @@ SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, $ LDU, C, LDC, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* June 2017 * * .. Scalar Arguments .. CHARACTER UPLO @@ -266,8 +277,8 @@ * .. * .. Local Scalars .. LOGICAL LOWER, ROTATE - INTEGER I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1, - $ NM12, NM13, OLDLL, OLDM + INTEGER I, IDIR, ISUB, ITER, ITERDIVN, J, LL, LLL, M, + $ MAXITDIVN, NM1, NM12, NM13, OLDLL, OLDM DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU, $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL, $ SINR, SLL, SMAX, SMIN, SMINL, SMINOA, @@ -329,7 +340,7 @@ CALL DLASQ1( N, D, E, WORK, INFO ) * * If INFO equals 2, dqds didn't finish, try to finish -* +* IF( INFO .NE. 2 ) RETURN INFO = 0 END IF @@ -400,20 +411,21 @@ 40 CONTINUE 50 CONTINUE SMINOA = SMINOA / SQRT( DBLE( N ) ) - THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL ) + THRESH = MAX( TOL*SMINOA, MAXITR*(N*(N*UNFL)) ) ELSE * * Absolute accuracy desired * - THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL ) + THRESH = MAX( ABS( TOL )*SMAX, MAXITR*(N*(N*UNFL)) ) END IF * * Prepare for main iteration loop for the singular values * (MAXIT is the maximum number of passes through the inner * loop permitted before nonconvergence signalled.) * - MAXIT = MAXITR*N*N - ITER = 0 + MAXITDIVN = MAXITR*N + ITERDIVN = 0 + ITER = -1 OLDLL = -1 OLDM = -1 * @@ -429,8 +441,13 @@ * IF( M.LE.1 ) $ GO TO 160 - IF( ITER.GT.MAXIT ) - $ GO TO 200 +* + IF( ITER.GE.N ) THEN + ITER = ITER - N + ITERDIVN = ITERDIVN + 1 + IF( ITERDIVN.GE.MAXITDIVN ) + $ GO TO 200 + END IF * * Find diagonal block of matrix to work on * diff --git a/lib/linalg/dcabs1.f b/lib/linalg/dcabs1.f index f6debb9ac2..d6d850ed0f 100644 --- a/lib/linalg/dcabs1.f +++ b/lib/linalg/dcabs1.f @@ -2,47 +2,55 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DCABS1(Z) -* +* * .. Scalar Arguments .. * COMPLEX*16 Z * .. * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> DCABS1 computes absolute value of a double complex number +*> DCABS1 computes |Re(.)| + |Im(.)| of a double complex number +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] Z +*> \verbatim +*> Z is COMPLEX*16 *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * * ===================================================================== DOUBLE PRECISION FUNCTION DCABS1(Z) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 Z diff --git a/lib/linalg/dcopy.f b/lib/linalg/dcopy.f index d9d5ac7aa2..27bc08582b 100644 --- a/lib/linalg/dcopy.f +++ b/lib/linalg/dcopy.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * DOUBLE PRECISION DX(*),DY(*) * .. -* +* * *> \par Purpose: * ============= @@ -24,18 +24,49 @@ *> \verbatim *> *> DCOPY copies a vector, x, to a vector, y. -*> uses unrolled loops for increments equal to one. +*> uses unrolled loops for increments equal to 1. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +*> +*> \param[out] DY +*> \verbatim +*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of DY *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * @@ -51,10 +82,10 @@ * ===================================================================== SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N @@ -85,7 +116,7 @@ DY(I) = DX(I) END DO IF (N.LT.7) RETURN - END IF + END IF MP1 = M + 1 DO I = MP1,N,7 DY(I) = DX(I) @@ -96,7 +127,7 @@ DY(I+5) = DX(I+5) DY(I+6) = DX(I+6) END DO - ELSE + ELSE * * code for unequal increments or equal increments * not equal to 1 diff --git a/lib/linalg/ddot.f b/lib/linalg/ddot.f index cc0c1b7a43..3d18695aab 100644 --- a/lib/linalg/ddot.f +++ b/lib/linalg/ddot.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * DOUBLE PRECISION DX(*),DY(*) * .. -* +* * *> \par Purpose: * ============= @@ -27,15 +27,46 @@ *> uses unrolled loops for increments equal to one. *> \endverbatim * +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +*> +*> \param[in] DY +*> \verbatim +*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of DY +*> \endverbatim +* * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * @@ -51,10 +82,10 @@ * ===================================================================== DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N diff --git a/lib/linalg/dgebd2.f b/lib/linalg/dgebd2.f index 4b4dcc9641..2bec4e29c7 100644 --- a/lib/linalg/dgebd2.f +++ b/lib/linalg/dgebd2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEBD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEBD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -27,7 +27,7 @@ * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), * $ TAUQ( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -100,7 +100,7 @@ *> *> \param[out] TAUQ *> \verbatim -*> TAUQ is DOUBLE PRECISION array dimension (min(M,N)) +*> TAUQ is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix Q. See Further Details. *> \endverbatim @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2017 * *> \ingroup doubleGEcomputational * @@ -189,10 +189,10 @@ * ===================================================================== SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lib/linalg/dgebrd.f b/lib/linalg/dgebrd.f index 6cb61f002f..957cf2e539 100644 --- a/lib/linalg/dgebrd.f +++ b/lib/linalg/dgebrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEBRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEBRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. @@ -28,7 +28,7 @@ * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), * $ TAUQ( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,7 +101,7 @@ *> *> \param[out] TAUQ *> \verbatim -*> TAUQ is DOUBLE PRECISION array dimension (min(M,N)) +*> TAUQ is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix Q. See Further Details. *> \endverbatim @@ -142,12 +142,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2017 * *> \ingroup doubleGEcomputational * @@ -205,10 +205,10 @@ SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* June 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lib/linalg/dgecon.f b/lib/linalg/dgecon.f index df9d8e1c40..be20bbcd2a 100644 --- a/lib/linalg/dgecon.f +++ b/lib/linalg/dgecon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGECON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGECON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,12 +111,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -124,10 +124,10 @@ SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lib/linalg/dgelq2.f b/lib/linalg/dgelq2.f index 0d64ba5210..04aa57fc19 100644 --- a/lib/linalg/dgelq2.f +++ b/lib/linalg/dgelq2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGELQ2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGELQ2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -91,12 +91,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -121,10 +121,10 @@ * ===================================================================== SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lib/linalg/dgelqf.f b/lib/linalg/dgelqf.f index d27b04ab1d..834c47168f 100644 --- a/lib/linalg/dgelqf.f +++ b/lib/linalg/dgelqf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGELQF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGELQF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,12 +105,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -135,10 +135,10 @@ * ===================================================================== SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lib/linalg/dgemm.f b/lib/linalg/dgemm.f index 45d001b7ab..3a60ca4e73 100644 --- a/lib/linalg/dgemm.f +++ b/lib/linalg/dgemm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA,BETA * INTEGER K,LDA,LDB,LDC,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -97,7 +97,7 @@ *> *> \param[in] A *> \verbatim -*> A is DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is +*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is *> k when TRANSA = 'N' or 'n', and is m otherwise. *> Before entry with TRANSA = 'N' or 'n', the leading m by k *> part of the array A must contain the matrix A, otherwise @@ -116,7 +116,7 @@ *> *> \param[in] B *> \verbatim -*> B is DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is +*> B is DOUBLE PRECISION array, dimension ( LDB, kb ), where kb is *> n when TRANSB = 'N' or 'n', and is k otherwise. *> Before entry with TRANSB = 'N' or 'n', the leading k by n *> part of the array B must contain the matrix B, otherwise @@ -142,7 +142,7 @@ *> *> \param[in,out] C *> \verbatim -*> C is DOUBLE PRECISION array of DIMENSION ( LDC, n ). +*> C is DOUBLE PRECISION array, dimension ( LDC, N ) *> Before entry, the leading m by n part of the array C must *> contain the matrix C, except when beta is zero, in which *> case C need not be set on entry. @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level3 * @@ -187,10 +187,10 @@ * ===================================================================== SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA,BETA @@ -311,12 +311,10 @@ 60 CONTINUE END IF DO 80 L = 1,K - IF (B(L,J).NE.ZERO) THEN - TEMP = ALPHA*B(L,J) - DO 70 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 70 CONTINUE - END IF + TEMP = ALPHA*B(L,J) + DO 70 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE 80 CONTINUE 90 CONTINUE ELSE @@ -353,12 +351,10 @@ 140 CONTINUE END IF DO 160 L = 1,K - IF (B(J,L).NE.ZERO) THEN - TEMP = ALPHA*B(J,L) - DO 150 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 150 CONTINUE - END IF + TEMP = ALPHA*B(J,L) + DO 150 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 150 CONTINUE 160 CONTINUE 170 CONTINUE ELSE diff --git a/lib/linalg/dgemv.f b/lib/linalg/dgemv.f index 675257fac7..08e395b1cd 100644 --- a/lib/linalg/dgemv.f +++ b/lib/linalg/dgemv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA,BETA * INTEGER INCX,INCY,LDA,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -71,7 +71,7 @@ *> *> \param[in] A *> \verbatim -*> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ). +*> A is DOUBLE PRECISION array, dimension ( LDA, N ) *> Before entry, the leading m by n part of the array A must *> contain the matrix of coefficients. *> \endverbatim @@ -86,7 +86,7 @@ *> *> \param[in] X *> \verbatim -*> X is DOUBLE PRECISION array of DIMENSION at least +*> X is DOUBLE PRECISION array, dimension at least *> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' *> and at least *> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. @@ -110,7 +110,7 @@ *> *> \param[in,out] Y *> \verbatim -*> Y is DOUBLE PRECISION array of DIMENSION at least +*> Y is DOUBLE PRECISION array, dimension at least *> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' *> and at least *> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. @@ -129,12 +129,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level2 * @@ -156,10 +156,10 @@ * ===================================================================== SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA,BETA @@ -278,24 +278,20 @@ JX = KX IF (INCY.EQ.1) THEN DO 60 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = ALPHA*X(JX) - DO 50 I = 1,M - Y(I) = Y(I) + TEMP*A(I,J) - 50 CONTINUE - END IF + TEMP = ALPHA*X(JX) + DO 50 I = 1,M + Y(I) = Y(I) + TEMP*A(I,J) + 50 CONTINUE JX = JX + INCX 60 CONTINUE ELSE DO 80 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = ALPHA*X(JX) - IY = KY - DO 70 I = 1,M - Y(IY) = Y(IY) + TEMP*A(I,J) - IY = IY + INCY - 70 CONTINUE - END IF + TEMP = ALPHA*X(JX) + IY = KY + DO 70 I = 1,M + Y(IY) = Y(IY) + TEMP*A(I,J) + IY = IY + INCY + 70 CONTINUE JX = JX + INCX 80 CONTINUE END IF diff --git a/lib/linalg/dgeqr2.f b/lib/linalg/dgeqr2.f index 8e63db8866..c1e91e9bde 100644 --- a/lib/linalg/dgeqr2.f +++ b/lib/linalg/dgeqr2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEQR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEQR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -91,12 +91,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -121,10 +121,10 @@ * ===================================================================== SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lib/linalg/dgeqrf.f b/lib/linalg/dgeqrf.f index 2990257581..83d7d8dd71 100644 --- a/lib/linalg/dgeqrf.f +++ b/lib/linalg/dgeqrf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEQRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEQRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,12 +106,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -136,10 +136,10 @@ * ===================================================================== SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lib/linalg/dger.f b/lib/linalg/dger.f index a042483703..bdc8ef4349 100644 --- a/lib/linalg/dger.f +++ b/lib/linalg/dger.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA * INTEGER INCX,INCY,LDA,M,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -57,7 +57,7 @@ *> *> \param[in] X *> \verbatim -*> X is DOUBLE PRECISION array of dimension at least +*> X is DOUBLE PRECISION array, dimension at least *> ( 1 + ( m - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the m *> element vector x. @@ -72,7 +72,7 @@ *> *> \param[in] Y *> \verbatim -*> Y is DOUBLE PRECISION array of dimension at least +*> Y is DOUBLE PRECISION array, dimension at least *> ( 1 + ( n - 1 )*abs( INCY ) ). *> Before entry, the incremented array Y must contain the n *> element vector y. @@ -87,7 +87,7 @@ *> *> \param[in,out] A *> \verbatim -*> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ). +*> A is DOUBLE PRECISION array, dimension ( LDA, N ) *> Before entry, the leading m by n part of the array A must *> contain the matrix of coefficients. On exit, A is *> overwritten by the updated matrix. @@ -104,12 +104,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level2 * @@ -130,10 +130,10 @@ * ===================================================================== SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA diff --git a/lib/linalg/dgesv.f b/lib/linalg/dgesv.f index 8d47f839dc..23999e167f 100644 --- a/lib/linalg/dgesv.f +++ b/lib/linalg/dgesv.f @@ -2,16 +2,16 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGESV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGESV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] *> \endhtmlonly * @@ -19,7 +19,7 @@ * =========== * * SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, N, NRHS * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,22 +110,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEsolve * * ===================================================================== SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, N, NRHS diff --git a/lib/linalg/dgesvd.f b/lib/linalg/dgesvd.f index 898570b669..ddf0bd5c2d 100644 --- a/lib/linalg/dgesvd.f +++ b/lib/linalg/dgesvd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGESVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGESVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBU, JOBVT * INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -173,9 +173,9 @@ *> LWORK is INTEGER *> The dimension of the array WORK. *> LWORK >= MAX(1,5*MIN(M,N)) for the paths (see comments inside code): -*> - PATH 1 (M much larger than N, JOBU='N') +*> - PATH 1 (M much larger than N, JOBU='N') *> - PATH 1t (N much larger than M, JOBVT='N') -*> LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)) for the other paths +*> LWORK >= MAX(1,3*MIN(M,N) + MAX(M,N),5*MIN(M,N)) for the other paths *> For good performance, LWORK should generally be larger. *> *> If LWORK = -1, then a workspace query is assumed; the routine @@ -198,10 +198,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -211,7 +211,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ VT, LDVT, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 @@ -314,24 +314,24 @@ BDSPAC = 5*N * Compute space needed for DGEQRF CALL DGEQRF( M, N, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_DGEQRF=DUM(1) + LWORK_DGEQRF = INT( DUM(1) ) * Compute space needed for DORGQR CALL DORGQR( M, N, N, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_DORGQR_N=DUM(1) + LWORK_DORGQR_N = INT( DUM(1) ) CALL DORGQR( M, M, N, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_DORGQR_M=DUM(1) + LWORK_DORGQR_M = INT( DUM(1) ) * Compute space needed for DGEBRD CALL DGEBRD( N, N, A, LDA, S, DUM(1), DUM(1), $ DUM(1), DUM(1), -1, IERR ) - LWORK_DGEBRD=DUM(1) + LWORK_DGEBRD = INT( DUM(1) ) * Compute space needed for DORGBR P CALL DORGBR( 'P', N, N, N, A, LDA, DUM(1), $ DUM(1), -1, IERR ) - LWORK_DORGBR_P=DUM(1) + LWORK_DORGBR_P = INT( DUM(1) ) * Compute space needed for DORGBR Q CALL DORGBR( 'Q', N, N, N, A, LDA, DUM(1), $ DUM(1), -1, IERR ) - LWORK_DORGBR_Q=DUM(1) + LWORK_DORGBR_Q = INT( DUM(1) ) * IF( M.GE.MNTHR ) THEN IF( WNTUN ) THEN @@ -339,9 +339,9 @@ * Path 1 (M much larger than N, JOBU='N') * MAXWRK = N + LWORK_DGEQRF - MAXWRK = MAX( MAXWRK, 3*N+LWORK_DGEBRD ) + MAXWRK = MAX( MAXWRK, 3*N + LWORK_DGEBRD ) IF( WNTVO .OR. WNTVAS ) - $ MAXWRK = MAX( MAXWRK, 3*N+LWORK_DORGBR_P ) + $ MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR_P ) MAXWRK = MAX( MAXWRK, BDSPAC ) MINWRK = MAX( 4*N, BDSPAC ) ELSE IF( WNTUO .AND. WNTVN ) THEN @@ -349,97 +349,97 @@ * Path 2 (M much larger than N, JOBU='O', JOBVT='N') * WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N+LWORK_DORGQR_N ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N ) - MINWRK = MAX( 3*N+M, BDSPAC ) + MAXWRK = MAX( N*N + WRKBL, N*N + M*N + N ) + MINWRK = MAX( 3*N + M, BDSPAC ) ELSE IF( WNTUO .AND. WNTVAS ) THEN * * Path 3 (M much larger than N, JOBU='O', JOBVT='S' or * 'A') * WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N+LWORK_DORGQR_N ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N ) - MINWRK = MAX( 3*N+M, BDSPAC ) + MAXWRK = MAX( N*N + WRKBL, N*N + M*N + N ) + MINWRK = MAX( 3*N + M, BDSPAC ) ELSE IF( WNTUS .AND. WNTVN ) THEN * * Path 4 (M much larger than N, JOBU='S', JOBVT='N') * WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N+LWORK_DORGQR_N ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = N*N + WRKBL - MINWRK = MAX( 3*N+M, BDSPAC ) + MINWRK = MAX( 3*N + M, BDSPAC ) ELSE IF( WNTUS .AND. WNTVO ) THEN * * Path 5 (M much larger than N, JOBU='S', JOBVT='O') * WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N+LWORK_DORGQR_N ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = 2*N*N + WRKBL - MINWRK = MAX( 3*N+M, BDSPAC ) + MINWRK = MAX( 3*N + M, BDSPAC ) ELSE IF( WNTUS .AND. WNTVAS ) THEN * * Path 6 (M much larger than N, JOBU='S', JOBVT='S' or * 'A') * WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N+LWORK_DORGQR_N ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = N*N + WRKBL - MINWRK = MAX( 3*N+M, BDSPAC ) + MINWRK = MAX( 3*N + M, BDSPAC ) ELSE IF( WNTUA .AND. WNTVN ) THEN * * Path 7 (M much larger than N, JOBU='A', JOBVT='N') * WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N+LWORK_DORGQR_M ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_M ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = N*N + WRKBL - MINWRK = MAX( 3*N+M, BDSPAC ) + MINWRK = MAX( 3*N + M, BDSPAC ) ELSE IF( WNTUA .AND. WNTVO ) THEN * * Path 8 (M much larger than N, JOBU='A', JOBVT='O') * WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N+LWORK_DORGQR_M ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_M ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = 2*N*N + WRKBL - MINWRK = MAX( 3*N+M, BDSPAC ) + MINWRK = MAX( 3*N + M, BDSPAC ) ELSE IF( WNTUA .AND. WNTVAS ) THEN * * Path 9 (M much larger than N, JOBU='A', JOBVT='S' or * 'A') * WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N+LWORK_DORGQR_M ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_M ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = N*N + WRKBL - MINWRK = MAX( 3*N+M, BDSPAC ) + MINWRK = MAX( 3*N + M, BDSPAC ) END IF ELSE * @@ -447,25 +447,25 @@ * CALL DGEBRD( M, N, A, LDA, S, DUM(1), DUM(1), $ DUM(1), DUM(1), -1, IERR ) - LWORK_DGEBRD=DUM(1) + LWORK_DGEBRD = INT( DUM(1) ) MAXWRK = 3*N + LWORK_DGEBRD IF( WNTUS .OR. WNTUO ) THEN CALL DORGBR( 'Q', M, N, N, A, LDA, DUM(1), $ DUM(1), -1, IERR ) - LWORK_DORGBR_Q=DUM(1) - MAXWRK = MAX( MAXWRK, 3*N+LWORK_DORGBR_Q ) + LWORK_DORGBR_Q = INT( DUM(1) ) + MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR_Q ) END IF IF( WNTUA ) THEN CALL DORGBR( 'Q', M, M, N, A, LDA, DUM(1), $ DUM(1), -1, IERR ) - LWORK_DORGBR_Q=DUM(1) - MAXWRK = MAX( MAXWRK, 3*N+LWORK_DORGBR_Q ) + LWORK_DORGBR_Q = INT( DUM(1) ) + MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR_Q ) END IF IF( .NOT.WNTVN ) THEN - MAXWRK = MAX( MAXWRK, 3*N+LWORK_DORGBR_P ) + MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR_P ) END IF MAXWRK = MAX( MAXWRK, BDSPAC ) - MINWRK = MAX( 3*N+M, BDSPAC ) + MINWRK = MAX( 3*N + M, BDSPAC ) END IF ELSE IF( MINMN.GT.0 ) THEN * @@ -475,33 +475,33 @@ BDSPAC = 5*M * Compute space needed for DGELQF CALL DGELQF( M, N, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_DGELQF=DUM(1) + LWORK_DGELQF = INT( DUM(1) ) * Compute space needed for DORGLQ CALL DORGLQ( N, N, M, DUM(1), N, DUM(1), DUM(1), -1, IERR ) - LWORK_DORGLQ_N=DUM(1) + LWORK_DORGLQ_N = INT( DUM(1) ) CALL DORGLQ( M, N, M, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_DORGLQ_M=DUM(1) + LWORK_DORGLQ_M = INT( DUM(1) ) * Compute space needed for DGEBRD CALL DGEBRD( M, M, A, LDA, S, DUM(1), DUM(1), $ DUM(1), DUM(1), -1, IERR ) - LWORK_DGEBRD=DUM(1) + LWORK_DGEBRD = INT( DUM(1) ) * Compute space needed for DORGBR P CALL DORGBR( 'P', M, M, M, A, N, DUM(1), $ DUM(1), -1, IERR ) - LWORK_DORGBR_P=DUM(1) + LWORK_DORGBR_P = INT( DUM(1) ) * Compute space needed for DORGBR Q CALL DORGBR( 'Q', M, M, M, A, N, DUM(1), $ DUM(1), -1, IERR ) - LWORK_DORGBR_Q=DUM(1) + LWORK_DORGBR_Q = INT( DUM(1) ) IF( N.GE.MNTHR ) THEN IF( WNTVN ) THEN * * Path 1t(N much larger than M, JOBVT='N') * MAXWRK = M + LWORK_DGELQF - MAXWRK = MAX( MAXWRK, 3*M+LWORK_DGEBRD ) + MAXWRK = MAX( MAXWRK, 3*M + LWORK_DGEBRD ) IF( WNTUO .OR. WNTUAS ) - $ MAXWRK = MAX( MAXWRK, 3*M+LWORK_DORGBR_Q ) + $ MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR_Q ) MAXWRK = MAX( MAXWRK, BDSPAC ) MINWRK = MAX( 4*M, BDSPAC ) ELSE IF( WNTVO .AND. WNTUN ) THEN @@ -509,97 +509,97 @@ * Path 2t(N much larger than M, JOBU='N', JOBVT='O') * WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M+LWORK_DORGLQ_M ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M ) - MINWRK = MAX( 3*M+N, BDSPAC ) + MAXWRK = MAX( M*M + WRKBL, M*M + M*N + M ) + MINWRK = MAX( 3*M + N, BDSPAC ) ELSE IF( WNTVO .AND. WNTUAS ) THEN * * Path 3t(N much larger than M, JOBU='S' or 'A', * JOBVT='O') * WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M+LWORK_DORGLQ_M ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M ) - MINWRK = MAX( 3*M+N, BDSPAC ) + MAXWRK = MAX( M*M + WRKBL, M*M + M*N + M ) + MINWRK = MAX( 3*M + N, BDSPAC ) ELSE IF( WNTVS .AND. WNTUN ) THEN * * Path 4t(N much larger than M, JOBU='N', JOBVT='S') * WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M+LWORK_DORGLQ_M ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = M*M + WRKBL - MINWRK = MAX( 3*M+N, BDSPAC ) + MINWRK = MAX( 3*M + N, BDSPAC ) ELSE IF( WNTVS .AND. WNTUO ) THEN * * Path 5t(N much larger than M, JOBU='O', JOBVT='S') * WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M+LWORK_DORGLQ_M ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = 2*M*M + WRKBL - MINWRK = MAX( 3*M+N, BDSPAC ) + MINWRK = MAX( 3*M + N, BDSPAC ) ELSE IF( WNTVS .AND. WNTUAS ) THEN * * Path 6t(N much larger than M, JOBU='S' or 'A', * JOBVT='S') * WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M+LWORK_DORGLQ_M ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = M*M + WRKBL - MINWRK = MAX( 3*M+N, BDSPAC ) + MINWRK = MAX( 3*M + N, BDSPAC ) ELSE IF( WNTVA .AND. WNTUN ) THEN * * Path 7t(N much larger than M, JOBU='N', JOBVT='A') * WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M+LWORK_DORGLQ_N ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_N ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = M*M + WRKBL - MINWRK = MAX( 3*M+N, BDSPAC ) + MINWRK = MAX( 3*M + N, BDSPAC ) ELSE IF( WNTVA .AND. WNTUO ) THEN * * Path 8t(N much larger than M, JOBU='O', JOBVT='A') * WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M+LWORK_DORGLQ_N ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_N ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = 2*M*M + WRKBL - MINWRK = MAX( 3*M+N, BDSPAC ) + MINWRK = MAX( 3*M + N, BDSPAC ) ELSE IF( WNTVA .AND. WNTUAS ) THEN * * Path 9t(N much larger than M, JOBU='S' or 'A', * JOBVT='A') * WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M+LWORK_DORGLQ_N ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_N ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = M*M + WRKBL - MINWRK = MAX( 3*M+N, BDSPAC ) + MINWRK = MAX( 3*M + N, BDSPAC ) END IF ELSE * @@ -607,26 +607,26 @@ * CALL DGEBRD( M, N, A, LDA, S, DUM(1), DUM(1), $ DUM(1), DUM(1), -1, IERR ) - LWORK_DGEBRD=DUM(1) + LWORK_DGEBRD = INT( DUM(1) ) MAXWRK = 3*M + LWORK_DGEBRD IF( WNTVS .OR. WNTVO ) THEN * Compute space needed for DORGBR P CALL DORGBR( 'P', M, N, M, A, N, DUM(1), $ DUM(1), -1, IERR ) - LWORK_DORGBR_P=DUM(1) - MAXWRK = MAX( MAXWRK, 3*M+LWORK_DORGBR_P ) + LWORK_DORGBR_P = INT( DUM(1) ) + MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR_P ) END IF IF( WNTVA ) THEN CALL DORGBR( 'P', N, N, M, A, N, DUM(1), $ DUM(1), -1, IERR ) - LWORK_DORGBR_P=DUM(1) - MAXWRK = MAX( MAXWRK, 3*M+LWORK_DORGBR_P ) + LWORK_DORGBR_P = INT( DUM(1) ) + MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR_P ) END IF IF( .NOT.WNTUN ) THEN - MAXWRK = MAX( MAXWRK, 3*M+LWORK_DORGBR_Q ) + MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR_Q ) END IF MAXWRK = MAX( MAXWRK, BDSPAC ) - MINWRK = MAX( 3*M+N, BDSPAC ) + MINWRK = MAX( 3*M + N, BDSPAC ) END IF END IF MAXWRK = MAX( MAXWRK, MINWRK ) @@ -685,21 +685,24 @@ IWORK = ITAU + N * * Compute A=Q*R -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Zero out below R * - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA ) + IF( N .GT. 1 ) THEN + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), + $ LDA ) + END IF IE = 1 ITAUQ = IE + N ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, @@ -708,7 +711,7 @@ IF( WNTVO .OR. WNTVAS ) THEN * * If right singular vectors desired, generate P'. -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -739,13 +742,13 @@ * Sufficient workspace for a fast algorithm * IR = 1 - IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN + IF( LWORK.GE.MAX( WRKBL, LDA*N + N ) + LDA*N ) THEN * * WORK(IU) is LDA by N, WORK(IR) is LDA by N * LDWRKU = LDA LDWRKR = LDA - ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN + ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N + N ) + N*N ) THEN * * WORK(IU) is LDA by N, WORK(IR) is N by N * @@ -762,7 +765,7 @@ IWORK = ITAU + N * * Compute A=Q*R -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -774,7 +777,7 @@ $ LDWRKR ) * * Generate Q in A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -784,14 +787,14 @@ IWORK = ITAUP + N * * Bidiagonalize R in WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) * CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing R -* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), @@ -800,7 +803,7 @@ * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IR) -* (Workspace: need N*N+BDSPAC) +* (Workspace: need N*N + BDSPAC) * CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, 1, $ WORK( IR ), LDWRKR, DUM, 1, @@ -809,7 +812,7 @@ * * Multiply Q in A by left singular vectors of R in * WORK(IR), storing result in WORK(IU) and copying to A -* (Workspace: need N*N+2*N, prefer N*N+M*N+N) +* (Workspace: need N*N + 2*N, prefer N*N + M*N + N) * DO 10 I = 1, M, LDWRKU CHUNK = MIN( M-I+1, LDWRKU ) @@ -830,14 +833,14 @@ IWORK = ITAUP + N * * Bidiagonalize A -* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) +* (Workspace: need 3*N + M, prefer 3*N + (M + N)*NB) * CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing A -* (Workspace: need 4*N, prefer 3*N+N*NB) +* (Workspace: need 4*N, prefer 3*N + N*NB) * CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -863,13 +866,13 @@ * Sufficient workspace for a fast algorithm * IR = 1 - IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN + IF( LWORK.GE.MAX( WRKBL, LDA*N + N ) + LDA*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is LDA by N * LDWRKU = LDA LDWRKR = LDA - ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN + ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N + N ) + N*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is N by N * @@ -886,7 +889,7 @@ IWORK = ITAU + N * * Compute A=Q*R -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -899,7 +902,7 @@ $ VT( 2, 1 ), LDVT ) * * Generate Q in A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -909,7 +912,7 @@ IWORK = ITAUP + N * * Bidiagonalize R in VT, copying result to WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) * CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), @@ -917,14 +920,14 @@ CALL DLACPY( 'L', N, N, VT, LDVT, WORK( IR ), LDWRKR ) * * Generate left vectors bidiagonalizing R in WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing R in VT -* (Workspace: need N*N+4*N-1, prefer N*N+3*N+(N-1)*NB) +* (Workspace: need N*N + 4*N-1, prefer N*N + 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -933,7 +936,7 @@ * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IR) and computing right * singular vectors of R in VT -* (Workspace: need N*N+BDSPAC) +* (Workspace: need N*N + BDSPAC) * CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, LDVT, $ WORK( IR ), LDWRKR, DUM, 1, @@ -942,7 +945,7 @@ * * Multiply Q in A by left singular vectors of R in * WORK(IR), storing result in WORK(IU) and copying to A -* (Workspace: need N*N+2*N, prefer N*N+M*N+N) +* (Workspace: need N*N + 2*N, prefer N*N + M*N + N) * DO 20 I = 1, M, LDWRKU CHUNK = MIN( M-I+1, LDWRKU ) @@ -961,7 +964,7 @@ IWORK = ITAU + N * * Compute A=Q*R -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -974,7 +977,7 @@ $ VT( 2, 1 ), LDVT ) * * Generate Q in A -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -984,21 +987,21 @@ IWORK = ITAUP + N * * Bidiagonalize R in VT -* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in A by left vectors bidiagonalizing R -* (Workspace: need 3*N+M, prefer 3*N+M*NB) +* (Workspace: need 3*N + M, prefer 3*N + M*NB) * CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, $ WORK( ITAUQ ), A, LDA, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing R in VT -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1042,7 +1045,7 @@ IWORK = ITAU + N * * Compute A=Q*R -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1055,7 +1058,7 @@ $ WORK( IR+1 ), LDWRKR ) * * Generate Q in A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1065,7 +1068,7 @@ IWORK = ITAUP + N * * Bidiagonalize R in WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) * CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, $ WORK( IE ), WORK( ITAUQ ), @@ -1073,7 +1076,7 @@ $ LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing R in WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), @@ -1082,7 +1085,7 @@ * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IR) -* (Workspace: need N*N+BDSPAC) +* (Workspace: need N*N + BDSPAC) * CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, $ 1, WORK( IR ), LDWRKR, DUM, 1, @@ -1103,14 +1106,14 @@ IWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1121,18 +1124,20 @@ * * Zero out below R in A * - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), - $ LDA ) + IF( N .GT. 1 ) THEN + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ A( 2, 1 ), LDA ) + END IF * * Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left vectors bidiagonalizing R -* (Workspace: need 3*N+M, prefer 3*N+M*NB) +* (Workspace: need 3*N + M, prefer 3*N + M*NB) * CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), @@ -1167,7 +1172,7 @@ LDWRKU = LDA IR = IU + LDWRKU*N LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN + ELSE IF( LWORK.GE.WRKBL+( LDA + N )*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is N by N * @@ -1186,7 +1191,7 @@ IWORK = ITAU + N * * Compute A=Q*R -* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) +* (Workspace: need 2*N*N + 2*N, prefer 2*N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1199,7 +1204,7 @@ $ WORK( IU+1 ), LDWRKU ) * * Generate Q in A -* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) +* (Workspace: need 2*N*N + 2*N, prefer 2*N*N + N + N*NB) * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1210,7 +1215,7 @@ * * Bidiagonalize R in WORK(IU), copying result to * WORK(IR) -* (Workspace: need 2*N*N+4*N, +* (Workspace: need 2*N*N + 4*N, * prefer 2*N*N+3*N+2*N*NB) * CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, @@ -1221,14 +1226,14 @@ $ WORK( IR ), LDWRKR ) * * Generate left bidiagonalizing vectors in WORK(IU) -* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB) +* (Workspace: need 2*N*N + 4*N, prefer 2*N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in WORK(IR) -* (Workspace: need 2*N*N+4*N-1, +* (Workspace: need 2*N*N + 4*N-1, * prefer 2*N*N+3*N+(N-1)*NB) * CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR, @@ -1239,7 +1244,7 @@ * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IU) and computing * right singular vectors of R in WORK(IR) -* (Workspace: need 2*N*N+BDSPAC) +* (Workspace: need 2*N*N + BDSPAC) * CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), $ WORK( IR ), LDWRKR, WORK( IU ), @@ -1266,14 +1271,14 @@ IWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1284,25 +1289,27 @@ * * Zero out below R in A * - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), - $ LDA ) + IF( N .GT. 1 ) THEN + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ A( 2, 1 ), LDA ) + END IF * * Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left vectors bidiagonalizing R -* (Workspace: need 3*N+M, prefer 3*N+M*NB) +* (Workspace: need 3*N + M, prefer 3*N + M*NB) * CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing R in A -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1346,7 +1353,7 @@ IWORK = ITAU + N * * Compute A=Q*R -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1359,7 +1366,7 @@ $ WORK( IU+1 ), LDWRKU ) * * Generate Q in A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1369,7 +1376,7 @@ IWORK = ITAUP + N * * Bidiagonalize R in WORK(IU), copying result to VT -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) * CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, $ WORK( IE ), WORK( ITAUQ ), @@ -1379,14 +1386,14 @@ $ LDVT ) * * Generate left bidiagonalizing vectors in WORK(IU) -* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in VT -* (Workspace: need N*N+4*N-1, +* (Workspace: need N*N + 4*N-1, * prefer N*N+3*N+(N-1)*NB) * CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), @@ -1396,7 +1403,7 @@ * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IU) and computing * right singular vectors of R in VT -* (Workspace: need N*N+BDSPAC) +* (Workspace: need N*N + BDSPAC) * CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, $ LDVT, WORK( IU ), LDWRKU, DUM, 1, @@ -1417,14 +1424,14 @@ IWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1441,7 +1448,7 @@ IWORK = ITAUP + N * * Bidiagonalize R in VT -* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), @@ -1449,14 +1456,14 @@ * * Multiply Q in U by left bidiagonalizing vectors * in VT -* (Workspace: need 3*N+M, prefer 3*N+M*NB) +* (Workspace: need 3*N + M, prefer 3*N + M*NB) * CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in VT -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1503,7 +1510,7 @@ IWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1517,7 +1524,7 @@ $ WORK( IR+1 ), LDWRKR ) * * Generate Q in U -* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) +* (Workspace: need N*N + N + M, prefer N*N + N + M*NB) * CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1527,7 +1534,7 @@ IWORK = ITAUP + N * * Bidiagonalize R in WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) * CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, $ WORK( IE ), WORK( ITAUQ ), @@ -1535,7 +1542,7 @@ $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), @@ -1544,7 +1551,7 @@ * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IR) -* (Workspace: need N*N+BDSPAC) +* (Workspace: need N*N + BDSPAC) * CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, $ 1, WORK( IR ), LDWRKR, DUM, 1, @@ -1569,14 +1576,14 @@ IWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (Workspace: need N+M, prefer N+M*NB) +* (Workspace: need N + M, prefer N + M*NB) * CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1587,11 +1594,13 @@ * * Zero out below R in A * - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), - $ LDA ) + IF( N .GT. 1 ) THEN + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ A( 2, 1 ), LDA ) + END IF * * Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), @@ -1599,7 +1608,7 @@ * * Multiply Q in U by left bidiagonalizing vectors * in A -* (Workspace: need 3*N+M, prefer 3*N+M*NB) +* (Workspace: need 3*N + M, prefer 3*N + M*NB) * CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), @@ -1634,7 +1643,7 @@ LDWRKU = LDA IR = IU + LDWRKU*N LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN + ELSE IF( LWORK.GE.WRKBL+( LDA + N )*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is N by N * @@ -1653,14 +1662,14 @@ IWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) +* (Workspace: need 2*N*N + 2*N, prefer 2*N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (Workspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB) +* (Workspace: need 2*N*N + N + M, prefer 2*N*N + N + M*NB) * CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1678,7 +1687,7 @@ * * Bidiagonalize R in WORK(IU), copying result to * WORK(IR) -* (Workspace: need 2*N*N+4*N, +* (Workspace: need 2*N*N + 4*N, * prefer 2*N*N+3*N+2*N*NB) * CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, @@ -1689,14 +1698,14 @@ $ WORK( IR ), LDWRKR ) * * Generate left bidiagonalizing vectors in WORK(IU) -* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB) +* (Workspace: need 2*N*N + 4*N, prefer 2*N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in WORK(IR) -* (Workspace: need 2*N*N+4*N-1, +* (Workspace: need 2*N*N + 4*N-1, * prefer 2*N*N+3*N+(N-1)*NB) * CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR, @@ -1707,7 +1716,7 @@ * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IU) and computing * right singular vectors of R in WORK(IR) -* (Workspace: need 2*N*N+BDSPAC) +* (Workspace: need 2*N*N + BDSPAC) * CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), $ WORK( IR ), LDWRKR, WORK( IU ), @@ -1737,14 +1746,14 @@ IWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (Workspace: need N+M, prefer N+M*NB) +* (Workspace: need N + M, prefer N + M*NB) * CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1755,11 +1764,13 @@ * * Zero out below R in A * - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), - $ LDA ) + IF( N .GT. 1 ) THEN + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ A( 2, 1 ), LDA ) + END IF * * Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), @@ -1767,14 +1778,14 @@ * * Multiply Q in U by left bidiagonalizing vectors * in A -* (Workspace: need 3*N+M, prefer 3*N+M*NB) +* (Workspace: need 3*N + M, prefer 3*N + M*NB) * CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in A -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1818,14 +1829,14 @@ IWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) +* (Workspace: need N*N + N + M, prefer N*N + N + M*NB) * CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1842,7 +1853,7 @@ IWORK = ITAUP + N * * Bidiagonalize R in WORK(IU), copying result to VT -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) * CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, $ WORK( IE ), WORK( ITAUQ ), @@ -1852,14 +1863,14 @@ $ LDVT ) * * Generate left bidiagonalizing vectors in WORK(IU) -* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in VT -* (Workspace: need N*N+4*N-1, +* (Workspace: need N*N + 4*N-1, * prefer N*N+3*N+(N-1)*NB) * CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), @@ -1869,7 +1880,7 @@ * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IU) and computing * right singular vectors of R in VT -* (Workspace: need N*N+BDSPAC) +* (Workspace: need N*N + BDSPAC) * CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, $ LDVT, WORK( IU ), LDWRKU, DUM, 1, @@ -1894,14 +1905,14 @@ IWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (Workspace: need N+M, prefer N+M*NB) +* (Workspace: need N + M, prefer N + M*NB) * CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1918,7 +1929,7 @@ IWORK = ITAUP + N * * Bidiagonalize R in VT -* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), @@ -1926,14 +1937,14 @@ * * Multiply Q in U by left bidiagonalizing vectors * in VT -* (Workspace: need 3*N+M, prefer 3*N+M*NB) +* (Workspace: need 3*N + M, prefer 3*N + M*NB) * CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in VT -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1967,7 +1978,7 @@ IWORK = ITAUP + N * * Bidiagonalize A -* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) +* (Workspace: need 3*N + M, prefer 3*N + (M + N)*NB) * CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, @@ -1976,7 +1987,7 @@ * * If left singular vectors desired in U, copy result to U * and generate left bidiagonalizing vectors in U -* (Workspace: need 3*N+NCU, prefer 3*N+NCU*NB) +* (Workspace: need 3*N + NCU, prefer 3*N + NCU*NB) * CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) IF( WNTUS ) @@ -1990,7 +2001,7 @@ * * If right singular vectors desired in VT, copy result to * VT and generate right bidiagonalizing vectors in VT -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), @@ -2000,7 +2011,7 @@ * * If left singular vectors desired in A, generate left * bidiagonalizing vectors in A -* (Workspace: need 4*N, prefer 3*N+N*NB) +* (Workspace: need 4*N, prefer 3*N + N*NB) * CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2009,7 +2020,7 @@ * * If right singular vectors desired in A, generate right * bidiagonalizing vectors in A -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2071,7 +2082,7 @@ IWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) @@ -2085,7 +2096,7 @@ IWORK = ITAUP + M * * Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, @@ -2093,7 +2104,7 @@ IF( WNTUO .OR. WNTUAS ) THEN * * If left singular vectors desired, generate Q -* (Workspace: need 4*M, prefer 3*M+M*NB) +* (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2126,14 +2137,14 @@ * Sufficient workspace for a fast algorithm * IR = 1 - IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN + IF( LWORK.GE.MAX( WRKBL, LDA*N + M ) + LDA*M ) THEN * * WORK(IU) is LDA by N and WORK(IR) is LDA by M * LDWRKU = LDA CHUNK = N LDWRKR = LDA - ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN + ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N + M ) + M*M ) THEN * * WORK(IU) is LDA by N and WORK(IR) is M by M * @@ -2152,7 +2163,7 @@ IWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2164,7 +2175,7 @@ $ WORK( IR+LDWRKR ), LDWRKR ) * * Generate Q in A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2174,14 +2185,14 @@ IWORK = ITAUP + M * * Bidiagonalize L in WORK(IR) -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) * CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing L -* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) +* (Workspace: need M*M + 4*M-1, prefer M*M + 3*M + (M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), @@ -2190,7 +2201,7 @@ * * Perform bidiagonal QR iteration, computing right * singular vectors of L in WORK(IR) -* (Workspace: need M*M+BDSPAC) +* (Workspace: need M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1, @@ -2199,7 +2210,7 @@ * * Multiply right singular vectors of L in WORK(IR) by Q * in A, storing result in WORK(IU) and copying to A -* (Workspace: need M*M+2*M, prefer M*M+M*N+M) +* (Workspace: need M*M + 2*M, prefer M*M + M*N + M) * DO 30 I = 1, N, CHUNK BLK = MIN( N-I+1, CHUNK ) @@ -2220,14 +2231,14 @@ IWORK = ITAUP + M * * Bidiagonalize A -* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) +* (Workspace: need 3*M + N, prefer 3*M + (M + N)*NB) * CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing A -* (Workspace: need 4*M, prefer 3*M+M*NB) +* (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2253,14 +2264,14 @@ * Sufficient workspace for a fast algorithm * IR = 1 - IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN + IF( LWORK.GE.MAX( WRKBL, LDA*N + M ) + LDA*M ) THEN * * WORK(IU) is LDA by N and WORK(IR) is LDA by M * LDWRKU = LDA CHUNK = N LDWRKR = LDA - ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN + ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N + M ) + M*M ) THEN * * WORK(IU) is LDA by N and WORK(IR) is M by M * @@ -2279,7 +2290,7 @@ IWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2291,7 +2302,7 @@ $ LDU ) * * Generate Q in A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2301,7 +2312,7 @@ IWORK = ITAUP + M * * Bidiagonalize L in U, copying result to WORK(IR) -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) * CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), @@ -2309,14 +2320,14 @@ CALL DLACPY( 'U', M, M, U, LDU, WORK( IR ), LDWRKR ) * * Generate right vectors bidiagonalizing L in WORK(IR) -* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) +* (Workspace: need M*M + 4*M-1, prefer M*M + 3*M + (M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing L in U -* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2325,7 +2336,7 @@ * Perform bidiagonal QR iteration, computing left * singular vectors of L in U, and computing right * singular vectors of L in WORK(IR) -* (Workspace: need M*M+BDSPAC) +* (Workspace: need M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), $ WORK( IR ), LDWRKR, U, LDU, DUM, 1, @@ -2334,7 +2345,7 @@ * * Multiply right singular vectors of L in WORK(IR) by Q * in A, storing result in WORK(IU) and copying to A -* (Workspace: need M*M+2*M, prefer M*M+M*N+M)) +* (Workspace: need M*M + 2*M, prefer M*M + M*N + M)) * DO 40 I = 1, N, CHUNK BLK = MIN( N-I+1, CHUNK ) @@ -2353,7 +2364,7 @@ IWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2365,7 +2376,7 @@ $ LDU ) * * Generate Q in A -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2375,21 +2386,21 @@ IWORK = ITAUP + M * * Bidiagonalize L in U -* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right vectors bidiagonalizing L by Q in A -* (Workspace: need 3*M+N, prefer 3*M+N*NB) +* (Workspace: need 3*M + N, prefer 3*M + N*NB) * CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU, $ WORK( ITAUP ), A, LDA, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing L in U -* (Workspace: need 4*M, prefer 3*M+M*NB) +* (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2433,7 +2444,7 @@ IWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2446,7 +2457,7 @@ $ WORK( IR+LDWRKR ), LDWRKR ) * * Generate Q in A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2456,7 +2467,7 @@ IWORK = ITAUP + M * * Bidiagonalize L in WORK(IR) -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) * CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, $ WORK( IE ), WORK( ITAUQ ), @@ -2465,7 +2476,7 @@ * * Generate right vectors bidiagonalizing L in * WORK(IR) -* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + (M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), @@ -2474,7 +2485,7 @@ * * Perform bidiagonal QR iteration, computing right * singular vectors of L in WORK(IR) -* (Workspace: need M*M+BDSPAC) +* (Workspace: need M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1, @@ -2495,7 +2506,7 @@ IWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2505,7 +2516,7 @@ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2520,14 +2531,14 @@ $ LDA ) * * Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right vectors bidiagonalizing L by Q in VT -* (Workspace: need 3*M+N, prefer 3*M+N*NB) +* (Workspace: need 3*M + N, prefer 3*M + N*NB) * CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, @@ -2562,7 +2573,7 @@ LDWRKU = LDA IR = IU + LDWRKU*M LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN + ELSE IF( LWORK.GE.WRKBL+( LDA + M )*M ) THEN * * WORK(IU) is LDA by M and WORK(IR) is M by M * @@ -2581,7 +2592,7 @@ IWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) +* (Workspace: need 2*M*M + 2*M, prefer 2*M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2594,7 +2605,7 @@ $ WORK( IU+LDWRKU ), LDWRKU ) * * Generate Q in A -* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) +* (Workspace: need 2*M*M + 2*M, prefer 2*M*M + M + M*NB) * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2605,7 +2616,7 @@ * * Bidiagonalize L in WORK(IU), copying result to * WORK(IR) -* (Workspace: need 2*M*M+4*M, +* (Workspace: need 2*M*M + 4*M, * prefer 2*M*M+3*M+2*M*NB) * CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, @@ -2616,7 +2627,7 @@ $ WORK( IR ), LDWRKR ) * * Generate right bidiagonalizing vectors in WORK(IU) -* (Workspace: need 2*M*M+4*M-1, +* (Workspace: need 2*M*M + 4*M-1, * prefer 2*M*M+3*M+(M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, @@ -2624,7 +2635,7 @@ $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in WORK(IR) -* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB) +* (Workspace: need 2*M*M + 4*M, prefer 2*M*M + 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), @@ -2634,7 +2645,7 @@ * Perform bidiagonal QR iteration, computing left * singular vectors of L in WORK(IR) and computing * right singular vectors of L in WORK(IU) -* (Workspace: need 2*M*M+BDSPAC) +* (Workspace: need 2*M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), $ WORK( IU ), LDWRKU, WORK( IR ), @@ -2661,14 +2672,14 @@ IWORK = ITAU + M * * Compute A=L*Q, copying result to VT -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2683,21 +2694,21 @@ $ LDA ) * * Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right vectors bidiagonalizing L by Q in VT -* (Workspace: need 3*M+N, prefer 3*M+N*NB) +* (Workspace: need 3*M + N, prefer 3*M + N*NB) * CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors of L in A -* (Workspace: need 4*M, prefer 3*M+M*NB) +* (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2741,7 +2752,7 @@ IWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2754,7 +2765,7 @@ $ WORK( IU+LDWRKU ), LDWRKU ) * * Generate Q in A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2764,7 +2775,7 @@ IWORK = ITAUP + M * * Bidiagonalize L in WORK(IU), copying result to U -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) * CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, $ WORK( IE ), WORK( ITAUQ ), @@ -2774,7 +2785,7 @@ $ LDU ) * * Generate right bidiagonalizing vectors in WORK(IU) -* (Workspace: need M*M+4*M-1, +* (Workspace: need M*M + 4*M-1, * prefer M*M+3*M+(M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, @@ -2782,7 +2793,7 @@ $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in U -* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2791,7 +2802,7 @@ * Perform bidiagonal QR iteration, computing left * singular vectors of L in U and computing right * singular vectors of L in WORK(IU) -* (Workspace: need M*M+BDSPAC) +* (Workspace: need M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), $ WORK( IU ), LDWRKU, U, LDU, DUM, 1, @@ -2812,14 +2823,14 @@ IWORK = ITAU + M * * Compute A=L*Q, copying result to VT -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2835,7 +2846,7 @@ IWORK = ITAUP + M * * Bidiagonalize L in U -* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), @@ -2843,14 +2854,14 @@ * * Multiply right bidiagonalizing vectors in U by Q * in VT -* (Workspace: need 3*M+N, prefer 3*M+N*NB) +* (Workspace: need 3*M + N, prefer 3*M + N*NB) * CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in U -* (Workspace: need 4*M, prefer 3*M+M*NB) +* (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2877,7 +2888,7 @@ * N right singular vectors to be computed in VT and * no left singular vectors to be computed * - IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN + IF( LWORK.GE.M*M+MAX( N + M, 4*M, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * @@ -2897,7 +2908,7 @@ IWORK = ITAU + M * * Compute A=L*Q, copying result to VT -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2911,7 +2922,7 @@ $ WORK( IR+LDWRKR ), LDWRKR ) * * Generate Q in VT -* (Workspace: need M*M+M+N, prefer M*M+M+N*NB) +* (Workspace: need M*M + M + N, prefer M*M + M + N*NB) * CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2921,7 +2932,7 @@ IWORK = ITAUP + M * * Bidiagonalize L in WORK(IR) -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) * CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, $ WORK( IE ), WORK( ITAUQ ), @@ -2929,7 +2940,7 @@ $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in WORK(IR) -* (Workspace: need M*M+4*M-1, +* (Workspace: need M*M + 4*M-1, * prefer M*M+3*M+(M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, @@ -2939,7 +2950,7 @@ * * Perform bidiagonal QR iteration, computing right * singular vectors of L in WORK(IR) -* (Workspace: need M*M+BDSPAC) +* (Workspace: need M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1, @@ -2964,14 +2975,14 @@ IWORK = ITAU + M * * Compute A=L*Q, copying result to VT -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (Workspace: need M+N, prefer M+N*NB) +* (Workspace: need M + N, prefer M + N*NB) * CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2986,7 +2997,7 @@ $ LDA ) * * Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), @@ -2994,7 +3005,7 @@ * * Multiply right bidiagonalizing vectors in A by Q * in VT -* (Workspace: need 3*M+N, prefer 3*M+N*NB) +* (Workspace: need 3*M + N, prefer 3*M + N*NB) * CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, @@ -3017,7 +3028,7 @@ * N right singular vectors to be computed in VT and * M left singular vectors to be overwritten on A * - IF( LWORK.GE.2*M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN + IF( LWORK.GE.2*M*M+MAX( N + M, 4*M, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * @@ -3029,7 +3040,7 @@ LDWRKU = LDA IR = IU + LDWRKU*M LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN + ELSE IF( LWORK.GE.WRKBL+( LDA + M )*M ) THEN * * WORK(IU) is LDA by M and WORK(IR) is M by M * @@ -3048,14 +3059,14 @@ IWORK = ITAU + M * * Compute A=L*Q, copying result to VT -* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) +* (Workspace: need 2*M*M + 2*M, prefer 2*M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (Workspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB) +* (Workspace: need 2*M*M + M + N, prefer 2*M*M + M + N*NB) * CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -3073,7 +3084,7 @@ * * Bidiagonalize L in WORK(IU), copying result to * WORK(IR) -* (Workspace: need 2*M*M+4*M, +* (Workspace: need 2*M*M + 4*M, * prefer 2*M*M+3*M+2*M*NB) * CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, @@ -3084,7 +3095,7 @@ $ WORK( IR ), LDWRKR ) * * Generate right bidiagonalizing vectors in WORK(IU) -* (Workspace: need 2*M*M+4*M-1, +* (Workspace: need 2*M*M + 4*M-1, * prefer 2*M*M+3*M+(M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, @@ -3092,7 +3103,7 @@ $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in WORK(IR) -* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB) +* (Workspace: need 2*M*M + 4*M, prefer 2*M*M + 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), @@ -3102,7 +3113,7 @@ * Perform bidiagonal QR iteration, computing left * singular vectors of L in WORK(IR) and computing * right singular vectors of L in WORK(IU) -* (Workspace: need 2*M*M+BDSPAC) +* (Workspace: need 2*M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), $ WORK( IU ), LDWRKU, WORK( IR ), @@ -3132,14 +3143,14 @@ IWORK = ITAU + M * * Compute A=L*Q, copying result to VT -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (Workspace: need M+N, prefer M+N*NB) +* (Workspace: need M + N, prefer M + N*NB) * CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -3154,7 +3165,7 @@ $ LDA ) * * Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), @@ -3162,14 +3173,14 @@ * * Multiply right bidiagonalizing vectors in A by Q * in VT -* (Workspace: need 3*M+N, prefer 3*M+N*NB) +* (Workspace: need 3*M + N, prefer 3*M + N*NB) * CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in A -* (Workspace: need 4*M, prefer 3*M+M*NB) +* (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -3193,7 +3204,7 @@ * N right singular vectors to be computed in VT and * M left singular vectors to be computed in U * - IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN + IF( LWORK.GE.M*M+MAX( N + M, 4*M, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * @@ -3213,14 +3224,14 @@ IWORK = ITAU + M * * Compute A=L*Q, copying result to VT -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (Workspace: need M*M+M+N, prefer M*M+M+N*NB) +* (Workspace: need M*M + M + N, prefer M*M + M + N*NB) * CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -3237,7 +3248,7 @@ IWORK = ITAUP + M * * Bidiagonalize L in WORK(IU), copying result to U -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) * CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, $ WORK( IE ), WORK( ITAUQ ), @@ -3247,14 +3258,14 @@ $ LDU ) * * Generate right bidiagonalizing vectors in WORK(IU) -* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + (M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in U -* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -3263,7 +3274,7 @@ * Perform bidiagonal QR iteration, computing left * singular vectors of L in U and computing right * singular vectors of L in WORK(IU) -* (Workspace: need M*M+BDSPAC) +* (Workspace: need M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), $ WORK( IU ), LDWRKU, U, LDU, DUM, 1, @@ -3288,14 +3299,14 @@ IWORK = ITAU + M * * Compute A=L*Q, copying result to VT -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (Workspace: need M+N, prefer M+N*NB) +* (Workspace: need M + N, prefer M + N*NB) * CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -3311,7 +3322,7 @@ IWORK = ITAUP + M * * Bidiagonalize L in U -* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), @@ -3319,14 +3330,14 @@ * * Multiply right bidiagonalizing vectors in U by Q * in VT -* (Workspace: need 3*M+N, prefer 3*M+N*NB) +* (Workspace: need 3*M + N, prefer 3*M + N*NB) * CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in U -* (Workspace: need 4*M, prefer 3*M+M*NB) +* (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -3360,7 +3371,7 @@ IWORK = ITAUP + M * * Bidiagonalize A -* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) +* (Workspace: need 3*M + N, prefer 3*M + (M + N)*NB) * CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, @@ -3369,7 +3380,7 @@ * * If left singular vectors desired in U, copy result to U * and generate left bidiagonalizing vectors in U -* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB) +* (Workspace: need 4*M-1, prefer 3*M + (M-1)*NB) * CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) CALL DORGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ), @@ -3379,7 +3390,7 @@ * * If right singular vectors desired in VT, copy result to * VT and generate right bidiagonalizing vectors in VT -* (Workspace: need 3*M+NRVT, prefer 3*M+NRVT*NB) +* (Workspace: need 3*M + NRVT, prefer 3*M + NRVT*NB) * CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) IF( WNTVA ) @@ -3393,7 +3404,7 @@ * * If left singular vectors desired in A, generate left * bidiagonalizing vectors in A -* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB) +* (Workspace: need 4*M-1, prefer 3*M + (M-1)*NB) * CALL DORGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -3402,7 +3413,7 @@ * * If right singular vectors desired in A, generate right * bidiagonalizing vectors in A -* (Workspace: need 4*M, prefer 3*M+M*NB) +* (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) diff --git a/lib/linalg/dgetf2.f b/lib/linalg/dgetf2.f index 649d0671de..5458a5f3eb 100644 --- a/lib/linalg/dgetf2.f +++ b/lib/linalg/dgetf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGETF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGETF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -128,11 +128,11 @@ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. - DOUBLE PRECISION SFMIN + DOUBLE PRECISION SFMIN INTEGER I, J, JP * .. * .. External Functions .. - DOUBLE PRECISION DLAMCH + DOUBLE PRECISION DLAMCH INTEGER IDAMAX EXTERNAL DLAMCH, IDAMAX * .. @@ -164,9 +164,9 @@ IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * -* Compute machine safe minimum -* - SFMIN = DLAMCH('S') +* Compute machine safe minimum +* + SFMIN = DLAMCH('S') * DO 10 J = 1, MIN( M, N ) * @@ -183,15 +183,15 @@ * * Compute elements J+1:M of J-th column. * - IF( J.LT.M ) THEN - IF( ABS(A( J, J )) .GE. SFMIN ) THEN - CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) - ELSE - DO 20 I = 1, M-J - A( J+I, J ) = A( J+I, J ) / A( J, J ) - 20 CONTINUE - END IF - END IF + IF( J.LT.M ) THEN + IF( ABS(A( J, J )) .GE. SFMIN ) THEN + CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) + ELSE + DO 20 I = 1, M-J + A( J+I, J ) = A( J+I, J ) / A( J, J ) + 20 CONTINUE + END IF + END IF * ELSE IF( INFO.EQ.0 ) THEN * diff --git a/lib/linalg/dgetrf.f b/lib/linalg/dgetrf.f index 45bb97f30c..9a340b60f3 100644 --- a/lib/linalg/dgetrf.f +++ b/lib/linalg/dgetrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGETRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGETRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -131,7 +131,7 @@ INTEGER I, IINFO, J, JB, NB * .. * .. External Subroutines .. - EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA + EXTERNAL DGEMM, DGETRF2, DLASWP, DTRSM, XERBLA * .. * .. External Functions .. INTEGER ILAENV @@ -169,7 +169,7 @@ * * Use unblocked code. * - CALL DGETF2( M, N, A, LDA, IPIV, INFO ) + CALL DGETRF2( M, N, A, LDA, IPIV, INFO ) ELSE * * Use blocked code. @@ -180,7 +180,7 @@ * Factor diagonal and subdiagonal blocks and test for exact * singularity. * - CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) + CALL DGETRF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) * * Adjust INFO and the pivot indices. * diff --git a/lib/linalg/dgetrf2.f b/lib/linalg/dgetrf2.f new file mode 100644 index 0000000000..77948d2305 --- /dev/null +++ b/lib/linalg/dgetrf2.f @@ -0,0 +1,272 @@ +*> \brief \b DGETRF2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGETRF2 computes an LU factorization of a general M-by-N matrix A +*> using partial pivoting with row interchanges. +*> +*> The factorization has the form +*> A = P * L * U +*> where P is a permutation matrix, L is lower triangular with unit +*> diagonal elements (lower trapezoidal if m > n), and U is upper +*> triangular (upper trapezoidal if m < n). +*> +*> This is the recursive version of the algorithm. It divides +*> the matrix into four submatrices: +*> +*> [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 +*> A = [ -----|----- ] with n1 = min(m,n)/2 +*> [ A21 | A22 ] n2 = n-n1 +*> +*> [ A11 ] +*> The subroutine calls itself to factor [ --- ], +*> [ A12 ] +*> [ A12 ] +*> do the swaps on [ --- ], solve A12, update A22, +*> [ A22 ] +*> +*> then calls itself to factor A22 and do the swaps on A21. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix to be factored. +*> On exit, the factors L and U from the factorization +*> A = P*L*U; the unit diagonal elements of L are not stored. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (min(M,N)) +*> The pivot indices; for 1 <= i <= min(M,N), row i of the +*> matrix was interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, U(i,i) is exactly zero. The factorization +*> has been completed, but the factor U is exactly +*> singular, and division by zero will occur if it is used +*> to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION SFMIN, TEMP + INTEGER I, IINFO, N1, N2 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER IDAMAX + EXTERNAL DLAMCH, IDAMAX +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DSCAL, DLASWP, DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETRF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN + + IF ( M.EQ.1 ) THEN +* +* Use unblocked code for one row case +* Just need to handle IPIV and INFO +* + IPIV( 1 ) = 1 + IF ( A(1,1).EQ.ZERO ) + $ INFO = 1 +* + ELSE IF( N.EQ.1 ) THEN +* +* Use unblocked code for one column case +* +* +* Compute machine safe minimum +* + SFMIN = DLAMCH('S') +* +* Find pivot and test for singularity +* + I = IDAMAX( M, A( 1, 1 ), 1 ) + IPIV( 1 ) = I + IF( A( I, 1 ).NE.ZERO ) THEN +* +* Apply the interchange +* + IF( I.NE.1 ) THEN + TEMP = A( 1, 1 ) + A( 1, 1 ) = A( I, 1 ) + A( I, 1 ) = TEMP + END IF +* +* Compute elements 2:M of the column +* + IF( ABS(A( 1, 1 )) .GE. SFMIN ) THEN + CALL DSCAL( M-1, ONE / A( 1, 1 ), A( 2, 1 ), 1 ) + ELSE + DO 10 I = 1, M-1 + A( 1+I, 1 ) = A( 1+I, 1 ) / A( 1, 1 ) + 10 CONTINUE + END IF +* + ELSE + INFO = 1 + END IF +* + ELSE +* +* Use recursive code +* + N1 = MIN( M, N ) / 2 + N2 = N-N1 +* +* [ A11 ] +* Factor [ --- ] +* [ A21 ] +* + CALL DGETRF2( M, N1, A, LDA, IPIV, IINFO ) + + IF ( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO +* +* [ A12 ] +* Apply interchanges to [ --- ] +* [ A22 ] +* + CALL DLASWP( N2, A( 1, N1+1 ), LDA, 1, N1, IPIV, 1 ) +* +* Solve A12 +* + CALL DTRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA, + $ A( 1, N1+1 ), LDA ) +* +* Update A22 +* + CALL DGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA, + $ A( 1, N1+1 ), LDA, ONE, A( N1+1, N1+1 ), LDA ) +* +* Factor A22 +* + CALL DGETRF2( M-N1, N2, A( N1+1, N1+1 ), LDA, IPIV( N1+1 ), + $ IINFO ) +* +* Adjust INFO and the pivot indices +* + IF ( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + N1 + DO 20 I = N1+1, MIN( M, N ) + IPIV( I ) = IPIV( I ) + N1 + 20 CONTINUE +* +* Apply interchanges to A21 +* + CALL DLASWP( N1, A( 1, 1 ), LDA, N1+1, MIN( M, N), IPIV, 1 ) +* + END IF + RETURN +* +* End of DGETRF2 +* + END diff --git a/lib/linalg/dgetri.f b/lib/linalg/dgetri.f index ad5324c07e..9d8cf2ad3e 100644 --- a/lib/linalg/dgetri.f +++ b/lib/linalg/dgetri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGETRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGETRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, N diff --git a/lib/linalg/dgetrs.f b/lib/linalg/dgetrs.f index 02e9832af7..7ac727776e 100644 --- a/lib/linalg/dgetrs.f +++ b/lib/linalg/dgetrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGETRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGETRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDA, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -109,22 +109,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lib/linalg/disnan.f b/lib/linalg/disnan.f index 355b827955..a565ed36d4 100644 --- a/lib/linalg/disnan.f +++ b/lib/linalg/disnan.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DISNAN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DISNAN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * LOGICAL FUNCTION DISNAN( DIN ) -* +* * .. Scalar Arguments .. -* DOUBLE PRECISION DIN +* DOUBLE PRECISION, INTENT(IN) :: DIN * .. -* +* * *> \par Purpose: * ============= @@ -47,25 +47,25 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2017 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== LOGICAL FUNCTION DISNAN( DIN ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2017 * * .. Scalar Arguments .. - DOUBLE PRECISION DIN + DOUBLE PRECISION, INTENT(IN) :: DIN * .. * * ===================================================================== diff --git a/lib/linalg/dlabad.f b/lib/linalg/dlabad.f index 9eda3c91db..01b8158f66 100644 --- a/lib/linalg/dlabad.f +++ b/lib/linalg/dlabad.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLABAD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLABAD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLABAD( SMALL, LARGE ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION LARGE, SMALL * .. -* +* * *> \par Purpose: * ============= @@ -62,22 +62,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLABAD( SMALL, LARGE ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION LARGE, SMALL diff --git a/lib/linalg/dlabrd.f b/lib/linalg/dlabrd.f index 72d148119a..b5e734dc7c 100644 --- a/lib/linalg/dlabrd.f +++ b/lib/linalg/dlabrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLABRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLABRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, * LDY ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDX, LDY, M, N, NB * .. @@ -28,7 +28,7 @@ * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), * $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,7 +110,7 @@ *> *> \param[out] TAUQ *> \verbatim -*> TAUQ is DOUBLE PRECISION array dimension (NB) +*> TAUQ is DOUBLE PRECISION array, dimension (NB) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix Q. See Further Details. *> \endverbatim @@ -151,12 +151,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2017 * *> \ingroup doubleOTHERauxiliary * @@ -210,10 +210,10 @@ SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2017 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, M, N, NB diff --git a/lib/linalg/dlacn2.f b/lib/linalg/dlacn2.f index 9dd3c85ea2..952854043a 100644 --- a/lib/linalg/dlacn2.f +++ b/lib/linalg/dlacn2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLACN2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLACN2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) -* +* * .. Scalar Arguments .. * INTEGER KASE, N * DOUBLE PRECISION EST @@ -28,7 +28,7 @@ * INTEGER ISGN( * ), ISAVE( 3 ) * DOUBLE PRECISION V( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -75,7 +75,7 @@ *> EST is DOUBLE PRECISION *> On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be *> unchanged from the previous call to DLACN2. -*> On exit, EST is an estimate (a lower bound) for norm(A). +*> On exit, EST is an estimate (a lower bound) for norm(A). *> \endverbatim *> *> \param[in,out] KASE @@ -96,12 +96,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -136,10 +136,10 @@ * ===================================================================== SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER KASE, N diff --git a/lib/linalg/dlacpy.f b/lib/linalg/dlacpy.f index a9a23c9454..d1c396724a 100644 --- a/lib/linalg/dlacpy.f +++ b/lib/linalg/dlacpy.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLACPY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLACPY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, M, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -91,22 +91,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lib/linalg/dladiv.f b/lib/linalg/dladiv.f index 306a6b0020..dd8110adf2 100644 --- a/lib/linalg/dladiv.f +++ b/lib/linalg/dladiv.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLADIV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLADIV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLADIV( A, B, C, D, P, Q ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION A, B, C, D, P, Q * .. -* +* * *> \par Purpose: * ============= @@ -36,8 +36,9 @@ *> 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 +*> The algorithm is due to Michael Baudin and Robert L. Smith +*> and can be found in the paper +*> "A Robust Complex Division in Scilab" *> \endverbatim * * Arguments: @@ -78,22 +79,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date January 2013 * -*> \ingroup auxOTHERauxiliary +*> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLADIV( A, B, C, D, P, Q ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* January 2013 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, D, P, Q @@ -101,28 +102,155 @@ * * ===================================================================== * +* .. Parameters .. + DOUBLE PRECISION BS + PARAMETER ( BS = 2.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = 0.5D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) +* * .. Local Scalars .. - DOUBLE PRECISION E, F + DOUBLE PRECISION AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLADIV1 * .. * .. Intrinsic Functions .. - INTRINSIC ABS + INTRINSIC ABS, MAX * .. * .. 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 + AA = A + BB = B + CC = C + DD = D + AB = MAX( ABS(A), ABS(B) ) + CD = MAX( ABS(C), ABS(D) ) + S = 1.0D0 + + OV = DLAMCH( 'Overflow threshold' ) + UN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Epsilon' ) + BE = BS / (EPS*EPS) + + IF( AB >= HALF*OV ) THEN + AA = HALF * AA + BB = HALF * BB + S = TWO * S END IF + IF( CD >= HALF*OV ) THEN + CC = HALF * CC + DD = HALF * DD + S = HALF * S + END IF + IF( AB <= UN*BS/EPS ) THEN + AA = AA * BE + BB = BB * BE + S = S / BE + END IF + IF( CD <= UN*BS/EPS ) THEN + CC = CC * BE + DD = DD * BE + S = S * BE + END IF + IF( ABS( D ).LE.ABS( C ) ) THEN + CALL DLADIV1(AA, BB, CC, DD, P, Q) + ELSE + CALL DLADIV1(BB, AA, DD, CC, P, Q) + Q = -Q + END IF + P = P * S + Q = Q * S * RETURN * * End of DLADIV * END + +*> \ingroup doubleOTHERauxiliary + + + SUBROUTINE DLADIV1( A, B, C, D, P, Q ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2013 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, D, P, Q +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* +* .. Local Scalars .. + DOUBLE PRECISION R, T +* .. +* .. External Functions .. + DOUBLE PRECISION DLADIV2 + EXTERNAL DLADIV2 +* .. +* .. Executable Statements .. +* + R = D / C + T = ONE / (C + D * R) + P = DLADIV2(A, B, C, D, R, T) + A = -A + Q = DLADIV2(B, A, C, D, R, T) +* + RETURN +* +* End of DLADIV1 +* + END + +*> \ingroup doubleOTHERauxiliary + + DOUBLE PRECISION FUNCTION DLADIV2( A, B, C, D, R, T ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2013 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, D, R, T +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +* +* .. Local Scalars .. + DOUBLE PRECISION BR +* .. +* .. Executable Statements .. +* + IF( R.NE.ZERO ) THEN + BR = B * R + IF( BR.NE.ZERO ) THEN + DLADIV2 = (A + BR) * T + ELSE + DLADIV2 = A * T + (B * T) * R + END IF + ELSE + DLADIV2 = (A + D * (B / C)) * T + END IF +* + RETURN +* +* End of DLADIV12 +* + END diff --git a/lib/linalg/dlae2.f b/lib/linalg/dlae2.f index 302eeaa1f7..ed77ff6dfe 100644 --- a/lib/linalg/dlae2.f +++ b/lib/linalg/dlae2.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAE2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAE2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION A, B, C, RT1, RT2 * .. -* +* * *> \par Purpose: * ============= @@ -73,14 +73,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -102,10 +102,10 @@ * ===================================================================== SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, RT1, RT2 diff --git a/lib/linalg/dlaed0.f b/lib/linalg/dlaed0.f index d8d7f53e1d..4e92da98ea 100644 --- a/lib/linalg/dlaed0.f +++ b/lib/linalg/dlaed0.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAED0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAED0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ * .. @@ -29,7 +29,7 @@ * DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -172,10 +172,10 @@ SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, $ WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ diff --git a/lib/linalg/dlaed1.f b/lib/linalg/dlaed1.f index c37c1d2100..30e71fa241 100644 --- a/lib/linalg/dlaed1.f +++ b/lib/linalg/dlaed1.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAED1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAED1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER CUTPNT, INFO, LDQ, N * DOUBLE PRECISION RHO @@ -29,7 +29,7 @@ * INTEGER INDXQ( * ), IWORK( * ) * DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -54,7 +54,7 @@ *> *> The first stage consists of deflating the size of the problem *> when there are multiple eigenvalues or if there is a zero in -*> the Z vector. For each such occurence the dimension of the +*> the Z vector. For each such occurrence the dimension of the *> secular equation problem is reduced by one. This stage is *> performed by the routine DLAED2. *> @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * @@ -163,10 +163,10 @@ SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER CUTPNT, INFO, LDQ, N diff --git a/lib/linalg/dlaed2.f b/lib/linalg/dlaed2.f index a75d72a737..fbcc87a880 100644 --- a/lib/linalg/dlaed2.f +++ b/lib/linalg/dlaed2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAED2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAED2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, * Q2, INDX, INDXC, INDXP, COLTYP, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDQ, N, N1 * DOUBLE PRECISION RHO @@ -31,7 +31,7 @@ * DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), * $ W( * ), Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -192,12 +192,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -212,10 +212,10 @@ SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, $ Q2, INDX, INDXC, INDXP, COLTYP, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDQ, N, N1 @@ -520,10 +520,10 @@ * into the last N - K slots of D and Q respectively. * IF( K.LT.N ) THEN - CALL DLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, + CALL DLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, $ Q( 1, K+1 ), LDQ ) CALL DCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 ) - END IF + END IF * * Copy CTOT into COLTYP for referencing in DLAED3. * diff --git a/lib/linalg/dlaed3.f b/lib/linalg/dlaed3.f index 411d0f890f..d200fc0a22 100644 --- a/lib/linalg/dlaed3.f +++ b/lib/linalg/dlaed3.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAED3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAED3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, * CTOT, W, S, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDQ, N, N1 * DOUBLE PRECISION RHO @@ -30,7 +30,7 @@ * DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), * $ S( * ), W( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,7 +116,7 @@ *> *> \param[in] Q2 *> \verbatim -*> Q2 is DOUBLE PRECISION array, dimension (LDQ2, N) +*> Q2 is DOUBLE PRECISION array, dimension (LDQ2*N) *> The first K columns of this matrix contain the non-deflated *> eigenvectors for the split problem. *> \endverbatim @@ -165,12 +165,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2017 * *> \ingroup auxOTHERcomputational * @@ -185,10 +185,10 @@ SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, $ CTOT, W, S, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2017 * * .. Scalar Arguments .. INTEGER INFO, K, LDQ, N, N1 diff --git a/lib/linalg/dlaed4.f b/lib/linalg/dlaed4.f index c898b5b618..e7dc839df5 100644 --- a/lib/linalg/dlaed4.f +++ b/lib/linalg/dlaed4.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAED4 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAED4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) -* +* * .. Scalar Arguments .. * INTEGER I, INFO, N * DOUBLE PRECISION DLAM, RHO @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( * ), DELTA( * ), Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -145,10 +145,10 @@ * ===================================================================== SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER I, INFO, N diff --git a/lib/linalg/dlaed5.f b/lib/linalg/dlaed5.f index 3ac9aa19a8..3ea9e401cf 100644 --- a/lib/linalg/dlaed5.f +++ b/lib/linalg/dlaed5.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAED5 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAED5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM ) -* +* * .. Scalar Arguments .. * INTEGER I * DOUBLE PRECISION DLAM, RHO @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 ) * .. -* +* * *> \par Purpose: * ============= @@ -90,12 +90,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -108,10 +108,10 @@ * ===================================================================== SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER I diff --git a/lib/linalg/dlaed6.f b/lib/linalg/dlaed6.f index 1ce4932b8e..daa8db39e4 100644 --- a/lib/linalg/dlaed6.f +++ b/lib/linalg/dlaed6.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAED6 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAED6 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL ORGATI * INTEGER INFO, KNITER @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( 3 ), Z( 3 ) * .. -* +* * *> \par Purpose: * ============= @@ -110,12 +110,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -140,10 +140,10 @@ * ===================================================================== SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL ORGATI @@ -175,7 +175,7 @@ INTEGER I, ITER, NITER DOUBLE PRECISION A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F, $ FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1, - $ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4, + $ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4, $ LBD, UBD * .. * .. Intrinsic Functions .. @@ -195,7 +195,7 @@ IF( FINIT .LT. ZERO )THEN LBD = ZERO ELSE - UBD = ZERO + UBD = ZERO END IF * NITER = 1 @@ -363,7 +363,7 @@ * TAU = TAU + ETA IF( TAU .LT. LBD .OR. TAU .GT. UBD ) - $ TAU = ( LBD + UBD )/TWO + $ TAU = ( LBD + UBD )/TWO * FC = ZERO ERRETM = ZERO @@ -381,13 +381,14 @@ DF = DF + TEMP2 DDF = DDF + TEMP3 ELSE - GO TO 60 + GO TO 60 END IF 40 CONTINUE F = FINIT + TAU*FC ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) + $ ABS( TAU )*DF - IF( ABS( F ).LE.EPS*ERRETM ) + IF( ( ABS( F ).LE.FOUR*EPS*ERRETM ) .OR. + $ ( (UBD-LBD).LE.FOUR*EPS*ABS(TAU) ) ) $ GO TO 60 IF( F .LE. ZERO )THEN LBD = TAU diff --git a/lib/linalg/dlaed7.f b/lib/linalg/dlaed7.f index 972c1bc590..9c528added 100644 --- a/lib/linalg/dlaed7.f +++ b/lib/linalg/dlaed7.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAED7 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAED7 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, * PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N, * $ QSIZ, TLVLS @@ -34,7 +34,7 @@ * DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ), * $ QSTORE( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -59,7 +59,7 @@ *> *> The first stage consists of deflating the size of the problem *> when there are multiple eigenvalues or if there is a zero in -*> the Z vector. For each such occurence the dimension of the +*> the Z vector. For each such occurrence the dimension of the *> secular equation problem is reduced by one. This stage is *> performed by the routine DLAED8. *> @@ -239,12 +239,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * @@ -260,10 +260,10 @@ $ PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N, @@ -304,7 +304,7 @@ ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN - INFO = -4 + INFO = -3 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN diff --git a/lib/linalg/dlaed8.f b/lib/linalg/dlaed8.f index 42b4ea1577..c053347b10 100644 --- a/lib/linalg/dlaed8.f +++ b/lib/linalg/dlaed8.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAED8 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAED8 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, * CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, * GIVCOL, GIVNUM, INDXP, INDX, INFO ) -* +* * .. Scalar Arguments .. * INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N, * $ QSIZ @@ -33,7 +33,7 @@ * DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), * $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -223,12 +223,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -243,10 +243,10 @@ $ CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, $ GIVCOL, GIVNUM, INDXP, INDX, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N, @@ -308,8 +308,8 @@ END IF * * Need to initialize GIVPTR to O here in case of quick exit -* to prevent an unspecified code behavior (usually sigfault) -* when IWORK array on entry to *stedc is not zeroed +* to prevent an unspecified code behavior (usually sigfault) +* when IWORK array on entry to *stedc is not zeroed * (or at least some IWORK entries which used in *laed7 for GIVPTR). * GIVPTR = 0 diff --git a/lib/linalg/dlaed9.f b/lib/linalg/dlaed9.f index 8aa0687573..d3be22502a 100644 --- a/lib/linalg/dlaed9.f +++ b/lib/linalg/dlaed9.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAED9 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAED9 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, * S, LDS, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N * DOUBLE PRECISION RHO @@ -29,7 +29,7 @@ * DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ), * $ W( * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -156,10 +156,10 @@ SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, $ S, LDS, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N diff --git a/lib/linalg/dlaeda.f b/lib/linalg/dlaeda.f index 749a7c365a..4ca08a0879 100644 --- a/lib/linalg/dlaeda.f +++ b/lib/linalg/dlaeda.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAEDA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAEDA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, * GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) -* +* * .. Scalar Arguments .. * INTEGER CURLVL, CURPBM, INFO, N, TLVLS * .. @@ -29,7 +29,7 @@ * $ PRMPTR( * ), QPTR( * ) * DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -147,12 +147,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -166,10 +166,10 @@ SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, $ GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER CURLVL, CURPBM, INFO, N, TLVLS diff --git a/lib/linalg/dlaev2.f b/lib/linalg/dlaev2.f index 2e333ddf2c..4906f1a20c 100644 --- a/lib/linalg/dlaev2.f +++ b/lib/linalg/dlaev2.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAEV2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAEV2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 * .. -* +* * *> \par Purpose: * ============= @@ -89,14 +89,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -120,10 +120,10 @@ * ===================================================================== SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 diff --git a/lib/linalg/dlaisnan.f b/lib/linalg/dlaisnan.f index 58595c5c33..c2e87d88a0 100644 --- a/lib/linalg/dlaisnan.f +++ b/lib/linalg/dlaisnan.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAISNAN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAISNAN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) -* +* * .. Scalar Arguments .. -* DOUBLE PRECISION DIN1, DIN2 +* DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2 * .. -* +* * *> \par Purpose: * ============= @@ -62,25 +62,25 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2017 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2017 * * .. Scalar Arguments .. - DOUBLE PRECISION DIN1, DIN2 + DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2 * .. * * ===================================================================== diff --git a/lib/linalg/dlamch.f b/lib/linalg/dlamch.f index 8f830e87cd..76f875cef6 100644 --- a/lib/linalg/dlamch.f +++ b/lib/linalg/dlamch.f @@ -1,47 +1,77 @@ +*> \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 December 2016 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) * -* -- LAPACK auxiliary routine (version 3.2) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 * * .. Scalar Arguments .. CHARACTER CMACH * .. * -* Purpose -* ======= -* -* DLAMCH determines double precision machine parameters. -* -* Arguments -* ========= -* -* CMACH (input) CHARACTER*1 -* 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) -* * ===================================================================== * * .. Parameters .. @@ -49,43 +79,34 @@ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. - LOGICAL FIRST, LRND - INTEGER BETA, IMAX, IMIN, IT - DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, - $ RND, SFMIN, SMALL, T + DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. -* .. External Subroutines .. - EXTERNAL DLAMC2 -* .. -* .. Save statement .. - SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, - $ EMAX, RMAX, PREC -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / +* .. Intrinsic Functions .. + INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, + $ MINEXPONENT, RADIX, TINY * .. * .. Executable Statements .. * - IF( FIRST ) THEN - CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) - BASE = BETA - T = IT - IF( LRND ) THEN - RND = ONE - EPS = ( BASE**( 1-IT ) ) / 2 - ELSE - RND = ZERO - EPS = BASE**( 1-IT ) - END IF - PREC = EPS*BASE - EMIN = IMIN - EMAX = IMAX - SFMIN = RMIN - SMALL = ONE / RMAX +* +* 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 @@ -93,508 +114,66 @@ * SFMIN = SMALL*( ONE+EPS ) END IF - END IF -* - IF( LSAME( CMACH, 'E' ) ) THEN - RMACH = EPS - ELSE IF( LSAME( CMACH, 'S' ) ) THEN RMACH = SFMIN ELSE IF( LSAME( CMACH, 'B' ) ) THEN - RMACH = BASE + RMACH = RADIX(ZERO) ELSE IF( LSAME( CMACH, 'P' ) ) THEN - RMACH = PREC + RMACH = EPS * RADIX(ZERO) ELSE IF( LSAME( CMACH, 'N' ) ) THEN - RMACH = T + RMACH = DIGITS(ZERO) ELSE IF( LSAME( CMACH, 'R' ) ) THEN RMACH = RND ELSE IF( LSAME( CMACH, 'M' ) ) THEN - RMACH = EMIN + RMACH = MINEXPONENT(ZERO) ELSE IF( LSAME( CMACH, 'U' ) ) THEN - RMACH = RMIN + RMACH = tiny(zero) ELSE IF( LSAME( CMACH, 'L' ) ) THEN - RMACH = EMAX + RMACH = MAXEXPONENT(ZERO) ELSE IF( LSAME( CMACH, 'O' ) ) THEN - RMACH = RMAX + RMACH = HUGE(ZERO) + ELSE + RMACH = ZERO END IF * DLAMCH = RMACH - FIRST = .FALSE. RETURN * * End of DLAMCH * END -* ************************************************************************ -* - SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) -* -* -- LAPACK auxiliary routine (version 3.2) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - LOGICAL IEEE1, RND - INTEGER BETA, T -* .. -* -* Purpose -* ======= -* -* DLAMC1 determines the machine parameters given by BETA, T, RND, and -* IEEE1. -* -* Arguments -* ========= -* -* BETA (output) INTEGER -* The base of the machine. -* -* T (output) INTEGER -* The number of ( BETA ) digits in the mantissa. -* -* RND (output) LOGICAL -* Specifies whether proper rounding ( RND = .TRUE. ) or -* chopping ( RND = .FALSE. ) occurs in addition. This may not -* be a reliable guide to the way in which the machine performs -* its arithmetic. -* -* IEEE1 (output) LOGICAL -* Specifies whether rounding appears to be done in the IEEE -* 'round to nearest' style. -* -* Further Details -* =============== -* -* The routine is based on the routine ENVRON by Malcolm and -* incorporates suggestions by Gentleman and Marovich. See -* -* Malcolm M. A. (1972) Algorithms to reveal properties of -* floating-point arithmetic. Comms. of the ACM, 15, 949-951. -* -* Gentleman W. M. and Marovich S. B. (1974) More on algorithms -* that reveal properties of floating point arithmetic units. -* Comms. of the ACM, 17, 276-277. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL FIRST, LIEEE1, LRND - INTEGER LBETA, LT - DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2 -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3 - EXTERNAL DLAMC3 -* .. -* .. Save statement .. - SAVE FIRST, LIEEE1, LBETA, LRND, LT -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / -* .. -* .. Executable Statements .. -* - IF( FIRST ) THEN - ONE = 1 -* -* LBETA, LIEEE1, LT and LRND are the local values of BETA, -* IEEE1, T and RND. -* -* Throughout this routine we use the function DLAMC3 to ensure -* that relevant values are stored and not held in registers, or -* are not affected by optimizers. -* -* Compute a = 2.0**m with the smallest positive integer m such -* that -* -* fl( a + 1.0 ) = a. -* - A = 1 - C = 1 -* -*+ WHILE( C.EQ.ONE )LOOP - 10 CONTINUE - IF( C.EQ.ONE ) THEN - A = 2*A - C = DLAMC3( A, ONE ) - C = DLAMC3( C, -A ) - GO TO 10 - END IF -*+ END WHILE -* -* Now compute b = 2.0**m with the smallest positive integer m -* such that -* -* fl( a + b ) .gt. a. -* - B = 1 - C = DLAMC3( A, B ) -* -*+ WHILE( C.EQ.A )LOOP - 20 CONTINUE - IF( C.EQ.A ) THEN - B = 2*B - C = DLAMC3( A, B ) - GO TO 20 - END IF -*+ END WHILE -* -* Now compute the base. a and c are neighbouring floating point -* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so -* their difference is beta. Adding 0.25 to c is to ensure that it -* is truncated to beta and not ( beta - 1 ). -* - QTR = ONE / 4 - SAVEC = C - C = DLAMC3( C, -A ) - LBETA = C + QTR -* -* Now determine whether rounding or chopping occurs, by adding a -* bit less than beta/2 and a bit more than beta/2 to a. -* - B = LBETA - F = DLAMC3( B / 2, -B / 100 ) - C = DLAMC3( F, A ) - IF( C.EQ.A ) THEN - LRND = .TRUE. - ELSE - LRND = .FALSE. - END IF - F = DLAMC3( B / 2, B / 100 ) - C = DLAMC3( F, A ) - IF( ( LRND ) .AND. ( C.EQ.A ) ) - $ LRND = .FALSE. -* -* Try and decide whether rounding is done in the IEEE 'round to -* nearest' style. B/2 is half a unit in the last place of the two -* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit -* zero, and SAVEC is odd. Thus adding B/2 to A should not change -* A, but adding B/2 to SAVEC should change SAVEC. -* - T1 = DLAMC3( B / 2, A ) - T2 = DLAMC3( B / 2, SAVEC ) - LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND -* -* Now find the mantissa, t. It should be the integer part of -* log to the base beta of a, however it is safer to determine t -* by powering. So we find t as the smallest positive integer for -* which -* -* fl( beta**t + 1.0 ) = 1.0. -* - LT = 0 - A = 1 - C = 1 -* -*+ WHILE( C.EQ.ONE )LOOP - 30 CONTINUE - IF( C.EQ.ONE ) THEN - LT = LT + 1 - A = A*LBETA - C = DLAMC3( A, ONE ) - C = DLAMC3( C, -A ) - GO TO 30 - END IF -*+ END WHILE -* - END IF -* - BETA = LBETA - T = LT - RND = LRND - IEEE1 = LIEEE1 - FIRST = .FALSE. - RETURN -* -* End of DLAMC1 -* - END -* -************************************************************************ -* - SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) -* -* -- LAPACK auxiliary routine (version 3.2) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - LOGICAL RND - INTEGER BETA, EMAX, EMIN, T - DOUBLE PRECISION EPS, RMAX, RMIN -* .. -* -* Purpose -* ======= -* -* DLAMC2 determines the machine parameters specified in its argument -* list. -* -* Arguments -* ========= -* -* BETA (output) INTEGER -* The base of the machine. -* -* T (output) INTEGER -* The number of ( BETA ) digits in the mantissa. -* -* RND (output) LOGICAL -* Specifies whether proper rounding ( RND = .TRUE. ) or -* chopping ( RND = .FALSE. ) occurs in addition. This may not -* be a reliable guide to the way in which the machine performs -* its arithmetic. -* -* EPS (output) DOUBLE PRECISION -* The smallest positive number such that -* -* fl( 1.0 - EPS ) .LT. 1.0, -* -* where fl denotes the computed value. -* -* EMIN (output) INTEGER -* The minimum exponent before (gradual) underflow occurs. -* -* RMIN (output) DOUBLE PRECISION -* The smallest normalized number for the machine, given by -* BASE**( EMIN - 1 ), where BASE is the floating point value -* of BETA. -* -* EMAX (output) INTEGER -* The maximum exponent before overflow occurs. -* -* RMAX (output) DOUBLE PRECISION -* The largest positive number for the machine, given by -* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point -* value of BETA. -* -* Further Details -* =============== -* -* The computation of EPS is based on a routine PARANOIA by -* W. Kahan of the University of California at Berkeley. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND - INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, - $ NGNMIN, NGPMIN - DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, - $ SIXTH, SMALL, THIRD, TWO, ZERO -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3 - EXTERNAL DLAMC3 -* .. -* .. External Subroutines .. - EXTERNAL DLAMC1, DLAMC4, DLAMC5 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. Save statement .. - SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, - $ LRMIN, LT -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / , IWARN / .FALSE. / -* .. -* .. Executable Statements .. -* - IF( FIRST ) THEN - ZERO = 0 - ONE = 1 - TWO = 2 -* -* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of -* BETA, T, RND, EPS, EMIN and RMIN. -* -* Throughout this routine we use the function DLAMC3 to ensure -* that relevant values are stored and not held in registers, or -* are not affected by optimizers. -* -* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. -* - CALL DLAMC1( LBETA, LT, LRND, LIEEE1 ) -* -* Start to find EPS. -* - B = LBETA - A = B**( -LT ) - LEPS = A -* -* Try some tricks to see whether or not this is the correct EPS. -* - B = TWO / 3 - HALF = ONE / 2 - SIXTH = DLAMC3( B, -HALF ) - THIRD = DLAMC3( SIXTH, SIXTH ) - B = DLAMC3( THIRD, -HALF ) - B = DLAMC3( B, SIXTH ) - B = ABS( B ) - IF( B.LT.LEPS ) - $ B = LEPS -* - LEPS = 1 -* -*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP - 10 CONTINUE - IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN - LEPS = B - C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) - C = DLAMC3( HALF, -C ) - B = DLAMC3( HALF, C ) - C = DLAMC3( HALF, -B ) - B = DLAMC3( HALF, C ) - GO TO 10 - END IF -*+ END WHILE -* - IF( A.LT.LEPS ) - $ LEPS = A -* -* Computation of EPS complete. -* -* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). -* Keep dividing A by BETA until (gradual) underflow occurs. This -* is detected when we cannot recover the previous A. -* - RBASE = ONE / LBETA - SMALL = ONE - DO 20 I = 1, 3 - SMALL = DLAMC3( SMALL*RBASE, ZERO ) - 20 CONTINUE - A = DLAMC3( ONE, SMALL ) - CALL DLAMC4( NGPMIN, ONE, LBETA ) - CALL DLAMC4( NGNMIN, -ONE, LBETA ) - CALL DLAMC4( GPMIN, A, LBETA ) - CALL DLAMC4( GNMIN, -A, LBETA ) - IEEE = .FALSE. -* - IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN - IF( NGPMIN.EQ.GPMIN ) THEN - LEMIN = NGPMIN -* ( Non twos-complement machines, no gradual underflow; -* e.g., VAX ) - ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN - LEMIN = NGPMIN - 1 + LT - IEEE = .TRUE. -* ( Non twos-complement machines, with gradual underflow; -* e.g., IEEE standard followers ) - ELSE - LEMIN = MIN( NGPMIN, GPMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -* - ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN - IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN - LEMIN = MAX( NGPMIN, NGNMIN ) -* ( Twos-complement machines, no gradual underflow; -* e.g., CYBER 205 ) - ELSE - LEMIN = MIN( NGPMIN, NGNMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -* - ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. - $ ( GPMIN.EQ.GNMIN ) ) THEN - IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN - LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT -* ( Twos-complement machines with gradual underflow; -* no known machine ) - ELSE - LEMIN = MIN( NGPMIN, NGNMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -* - ELSE - LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF - FIRST = .FALSE. -*** -* Comment out this if block if EMIN is ok - IF( IWARN ) THEN - FIRST = .TRUE. - WRITE( 6, FMT = 9999 )LEMIN - END IF -*** -* -* Assume IEEE arithmetic if we found denormalised numbers above, -* or if arithmetic seems to round in the IEEE style, determined -* in routine DLAMC1. A true IEEE machine should have both things -* true; however, faulty machines may have one or the other. -* - IEEE = IEEE .OR. LIEEE1 -* -* Compute RMIN by successive division by BETA. We could compute -* RMIN as BASE**( EMIN - 1 ), but some machines underflow during -* this computation. -* - LRMIN = 1 - DO 30 I = 1, 1 - LEMIN - LRMIN = DLAMC3( LRMIN*RBASE, ZERO ) - 30 CONTINUE -* -* Finally, call DLAMC5 to compute EMAX and RMAX. -* - CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) - END IF -* - BETA = LBETA - T = LT - RND = LRND - EPS = LEPS - EMIN = LEMIN - RMIN = LRMIN - EMAX = LEMAX - RMAX = LRMAX -* - RETURN -* - 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', - $ ' EMIN = ', I8, / - $ ' If, after inspection, the value EMIN looks', - $ ' acceptable please comment out ', - $ / ' the IF block as marked within the code of routine', - $ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / ) -* -* End of DLAMC2 -* - 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 December 2016 +*> \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.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 +* November 2010 * * .. Scalar Arguments .. DOUBLE PRECISION A, B * .. -* -* Purpose -* ======= -* -* 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. -* -* Arguments -* ========= -* -* A (input) DOUBLE PRECISION -* B (input) DOUBLE PRECISION -* The values A and B. -* * ===================================================================== * * .. Executable Statements .. @@ -608,245 +187,3 @@ END * ************************************************************************ -* - SUBROUTINE DLAMC4( EMIN, START, BASE ) -* -* -- LAPACK auxiliary routine (version 3.2) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER BASE, EMIN - DOUBLE PRECISION START -* .. -* -* Purpose -* ======= -* -* DLAMC4 is a service routine for DLAMC2. -* -* Arguments -* ========= -* -* EMIN (output) INTEGER -* The minimum exponent before (gradual) underflow, computed by -* setting A = START and dividing by BASE until the previous A -* can not be recovered. -* -* START (input) DOUBLE PRECISION -* The starting point for determining EMIN. -* -* BASE (input) INTEGER -* The base of the machine. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I - DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3 - EXTERNAL DLAMC3 -* .. -* .. Executable Statements .. -* - A = START - ONE = 1 - RBASE = ONE / BASE - ZERO = 0 - EMIN = 1 - B1 = DLAMC3( A*RBASE, ZERO ) - C1 = A - C2 = A - D1 = A - D2 = A -*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. -* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP - 10 CONTINUE - IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. - $ ( D2.EQ.A ) ) THEN - EMIN = EMIN - 1 - A = B1 - B1 = DLAMC3( A / BASE, ZERO ) - C1 = DLAMC3( B1*BASE, ZERO ) - D1 = ZERO - DO 20 I = 1, BASE - D1 = D1 + B1 - 20 CONTINUE - B2 = DLAMC3( A*RBASE, ZERO ) - C2 = DLAMC3( B2 / RBASE, ZERO ) - D2 = ZERO - DO 30 I = 1, BASE - D2 = D2 + B2 - 30 CONTINUE - GO TO 10 - END IF -*+ END WHILE -* - RETURN -* -* End of DLAMC4 -* - END -* -************************************************************************ -* - SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) -* -* -- LAPACK auxiliary routine (version 3.2) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - LOGICAL IEEE - INTEGER BETA, EMAX, EMIN, P - DOUBLE PRECISION RMAX -* .. -* -* Purpose -* ======= -* -* DLAMC5 attempts to compute RMAX, the largest machine floating-point -* number, without overflow. It assumes that EMAX + abs(EMIN) sum -* approximately to a power of 2. It will fail on machines where this -* assumption does not hold, for example, the Cyber 205 (EMIN = -28625, -* EMAX = 28718). It will also fail if the value supplied for EMIN is -* too large (i.e. too close to zero), probably with overflow. -* -* Arguments -* ========= -* -* BETA (input) INTEGER -* The base of floating-point arithmetic. -* -* P (input) INTEGER -* The number of base BETA digits in the mantissa of a -* floating-point value. -* -* EMIN (input) INTEGER -* The minimum exponent before (gradual) underflow. -* -* IEEE (input) LOGICAL -* A logical flag specifying whether or not the arithmetic -* system is thought to comply with the IEEE standard. -* -* EMAX (output) INTEGER -* The largest exponent before overflow -* -* RMAX (output) DOUBLE PRECISION -* The largest machine floating-point number. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP - DOUBLE PRECISION OLDY, RECBAS, Y, Z -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3 - EXTERNAL DLAMC3 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. -* .. Executable Statements .. -* -* First compute LEXP and UEXP, two powers of 2 that bound -* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum -* approximately to the bound that is closest to abs(EMIN). -* (EMAX is the exponent of the required number RMAX). -* - LEXP = 1 - EXBITS = 1 - 10 CONTINUE - TRY = LEXP*2 - IF( TRY.LE.( -EMIN ) ) THEN - LEXP = TRY - EXBITS = EXBITS + 1 - GO TO 10 - END IF - IF( LEXP.EQ.-EMIN ) THEN - UEXP = LEXP - ELSE - UEXP = TRY - EXBITS = EXBITS + 1 - END IF -* -* Now -LEXP is less than or equal to EMIN, and -UEXP is greater -* than or equal to EMIN. EXBITS is the number of bits needed to -* store the exponent. -* - IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN - EXPSUM = 2*LEXP - ELSE - EXPSUM = 2*UEXP - END IF -* -* EXPSUM is the exponent range, approximately equal to -* EMAX - EMIN + 1 . -* - EMAX = EXPSUM + EMIN - 1 - NBITS = 1 + EXBITS + P -* -* NBITS is the total number of bits needed to store a -* floating-point number. -* - IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN -* -* Either there are an odd number of bits used to store a -* floating-point number, which is unlikely, or some bits are -* not used in the representation of numbers, which is possible, -* (e.g. Cray machines) or the mantissa has an implicit bit, -* (e.g. IEEE machines, Dec Vax machines), which is perhaps the -* most likely. We have to assume the last alternative. -* If this is true, then we need to reduce EMAX by one because -* there must be some way of representing zero in an implicit-bit -* system. On machines like Cray, we are reducing EMAX by one -* unnecessarily. -* - EMAX = EMAX - 1 - END IF -* - IF( IEEE ) THEN -* -* Assume we are on an IEEE machine which reserves one exponent -* for infinity and NaN. -* - EMAX = EMAX - 1 - END IF -* -* Now create RMAX, the largest machine number, which should -* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . -* -* First compute 1.0 - BETA**(-P), being careful that the -* result is less than 1.0 . -* - RECBAS = ONE / BETA - Z = BETA - ONE - Y = ZERO - DO 20 I = 1, P - Z = Z*RECBAS - IF( Y.LT.ONE ) - $ OLDY = Y - Y = DLAMC3( Y, Z ) - 20 CONTINUE - IF( Y.GE.ONE ) - $ Y = OLDY -* -* Now multiply by BETA**EMAX to get RMAX. -* - DO 30 I = 1, EMAX - Y = DLAMC3( Y*BETA, ZERO ) - 30 CONTINUE -* - RMAX = Y - RETURN -* -* End of DLAMC5 -* - END diff --git a/lib/linalg/dlamrg.f b/lib/linalg/dlamrg.f index 7126053e8a..de19508e45 100644 --- a/lib/linalg/dlamrg.f +++ b/lib/linalg/dlamrg.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAMRG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAMRG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) -* +* * .. Scalar Arguments .. * INTEGER DTRD1, DTRD2, N1, N2 * .. @@ -27,7 +27,7 @@ * INTEGER INDEX( * ) * DOUBLE PRECISION A( * ) * .. -* +* * *> \par Purpose: * ============= @@ -50,7 +50,7 @@ *> \param[in] N2 *> \verbatim *> N2 is INTEGER -*> These arguements contain the respective lengths of the two +*> These arguments contain the respective lengths of the two *> sorted lists to be merged. *> \endverbatim *> @@ -87,22 +87,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER DTRD1, DTRD2, N1, N2 diff --git a/lib/linalg/dlange.f b/lib/linalg/dlange.f index bec815d1ef..9dbf45e818 100644 --- a/lib/linalg/dlange.f +++ b/lib/linalg/dlange.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLANGE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLANGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER LDA, M, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGEauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lib/linalg/dlanst.f b/lib/linalg/dlanst.f index 213b06ada0..e952e2dd21 100644 --- a/lib/linalg/dlanst.f +++ b/lib/linalg/dlanst.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLANST + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLANST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -88,22 +88,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lib/linalg/dlansy.f b/lib/linalg/dlansy.f index bc70ab8eda..2372fce0a8 100644 --- a/lib/linalg/dlansy.f +++ b/lib/linalg/dlansy.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLANSY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLANSY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,22 +110,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleSYauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO diff --git a/lib/linalg/dlapy2.f b/lib/linalg/dlapy2.f index d43b0d5d14..bc01829a24 100644 --- a/lib/linalg/dlapy2.f +++ b/lib/linalg/dlapy2.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAPY2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAPY2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION X, Y * .. -* +* * *> \par Purpose: * ============= @@ -51,22 +51,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2017 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2017 * * .. Scalar Arguments .. DOUBLE PRECISION X, Y @@ -82,20 +82,32 @@ * .. * .. Local Scalars .. DOUBLE PRECISION W, XABS, YABS, Z + LOGICAL X_IS_NAN, Y_IS_NAN +* .. +* .. External Functions .. + LOGICAL DISNAN + EXTERNAL DISNAN * .. * .. 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 ) + X_IS_NAN = DISNAN( X ) + Y_IS_NAN = DISNAN( Y ) + IF ( X_IS_NAN ) DLAPY2 = X + IF ( Y_IS_NAN ) DLAPY2 = Y +* + IF ( .NOT.( X_IS_NAN.OR.Y_IS_NAN ) ) THEN + 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 END IF RETURN * diff --git a/lib/linalg/dlapy3.f b/lib/linalg/dlapy3.f index 23feecc447..3bbba88875 100644 --- a/lib/linalg/dlapy3.f +++ b/lib/linalg/dlapy3.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAPY3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAPY3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION X, Y, Z * .. -* +* * *> \par Purpose: * ============= @@ -56,22 +56,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION X, Y, Z diff --git a/lib/linalg/dlarf.f b/lib/linalg/dlarf.f index 80dca69af7..e99d0bb2a9 100644 --- a/lib/linalg/dlarf.f +++ b/lib/linalg/dlarf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,22 +112,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE diff --git a/lib/linalg/dlarfb.f b/lib/linalg/dlarfb.f index 17218478af..5b2cc2ba80 100644 --- a/lib/linalg/dlarfb.f +++ b/lib/linalg/dlarfb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARFB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARFB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \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 @@ -29,7 +29,7 @@ * DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2013 * *> \ingroup doubleOTHERauxiliary * @@ -195,10 +195,10 @@ SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2013 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS @@ -217,12 +217,11 @@ * .. * .. Local Scalars .. CHARACTER TRANST - INTEGER I, J, LASTV, LASTC, lastv2 + INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILADLR, ILADLC - EXTERNAL LSAME, ILADLR, ILADLC + EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DTRMM @@ -252,58 +251,53 @@ * * 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 ) + CALL DCOPY( N, 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 + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN * -* W := W + C2**T *V2 +* 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 ) + CALL DGEMM( 'Transpose', 'No transpose', N, K, M-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 ) + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**T * - IF( LASTV.GT.K ) THEN + IF( M.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 ) + CALL DGEMM( 'No transpose', 'Transpose', M-K, N, 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 ) + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, + $ ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**T * DO 30 J = 1, K - DO 20 I = 1, LASTC + DO 20 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 20 CONTINUE 30 CONTINUE @@ -311,58 +305,53 @@ 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 ) + CALL DCOPY( M, 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 + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( N.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 ) + CALL DGEMM( 'No transpose', 'No transpose', M, K, N-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 ) + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**T * - IF( LASTV.GT.K ) THEN + IF( N.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 ) + CALL DGEMM( 'No transpose', 'Transpose', M, N-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 ) + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, + $ ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 60 J = 1, K - DO 50 I = 1, LASTC + DO 50 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 50 CONTINUE 60 CONTINUE @@ -378,36 +367,31 @@ * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) -* - LASTC = ILADLC( M, 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( M-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) + CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 70 CONTINUE * * W := W * V2 * - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( M-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * -* W := W + C1**T*V1 +* W := W + C1**T * V1 * - CALL DGEMM( 'Transpose', 'No transpose', - $ LASTC, K, M-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL DGEMM( 'Transpose', 'No transpose', N, K, M-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 ) + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**T * @@ -415,57 +399,51 @@ * * C1 := C1 - V1 * W**T * - CALL DGEMM( 'No transpose', 'Transpose', - $ M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) + CALL DGEMM( 'No transpose', 'Transpose', M-K, N, 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( M-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**T * DO 90 J = 1, K - DO 80 I = 1, LASTC - C( M-K+J, I ) = C( M-K+J, I ) - WORK(I, J) + DO 80 I = 1, N + C( M-K+J, I ) = C( M-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 ) -* - LASTC = ILADLR( M, N, 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 ) + CALL DCOPY( M, 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( N-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1 * - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, K, N-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL DGEMM( 'No transpose', 'No transpose', M, K, N-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 ) + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**T * @@ -473,22 +451,20 @@ * * C1 := C1 - W * V1**T * - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) + CALL DGEMM( 'No transpose', 'Transpose', M, N-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( N-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, + $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W * DO 120 J = 1, K - DO 110 I = 1, LASTC - C( I, N-K+J ) = C( I, N-K+J ) - WORK(I, J) + DO 110 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 110 CONTINUE 120 CONTINUE END IF @@ -505,58 +481,53 @@ * * 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 ) + CALL DCOPY( N, 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 + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN * -* W := W + C2**T*V2**T +* 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 ) + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-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 ) + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**T * W**T * - IF( LASTV.GT.K ) THEN + IF( M.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 ) + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, 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 ) + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**T * DO 150 J = 1, K - DO 140 I = 1, LASTC + DO 140 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 140 CONTINUE 150 CONTINUE @@ -564,58 +535,53 @@ 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 ) + CALL DCOPY( M, 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 + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( N.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 ) + CALL DGEMM( 'No transpose', 'Transpose', M, K, N-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 ) + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * - IF( LASTV.GT.K ) THEN + IF( N.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 ) + CALL DGEMM( 'No transpose', 'No transpose', M, N-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 ) + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 180 J = 1, K - DO 170 I = 1, LASTC + DO 170 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 170 CONTINUE 180 CONTINUE @@ -631,36 +597,31 @@ * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) -* - LASTC = ILADLC( M, 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( M-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) + CALL DCOPY( N, C( M-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, M-K+1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, + $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C1**T * V1**T * - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTC, K, M-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-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 ) + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**T * W**T * @@ -668,58 +629,51 @@ * * C1 := C1 - V1**T * W**T * - CALL DGEMM( 'Transpose', 'Transpose', - $ M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, 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, M-K+1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**T * DO 210 J = 1, K - DO 200 I = 1, LASTC - C( M-K+J, I ) = C( M-K+J, I ) - WORK(I, J) + DO 200 I = 1, N + C( M-K+J, I ) = C( M-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 ) -* - LASTC = ILADLR( M, N, C, LDC ) +* Form C * H or C * H' where C = ( C1 C2 ) * * 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, N-K+J ), 1, - $ WORK( 1, J ), 1 ) + CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 220 CONTINUE * * W := W * V2**T * - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( 1, N-K+1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, + $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1**T * - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, K, N-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL DGEMM( 'No transpose', 'Transpose', M, K, N-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 ) + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * @@ -727,22 +681,20 @@ * * C1 := C1 - W * V1 * - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) + CALL DGEMM( 'No transpose', 'No transpose', M, N-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, N-K+1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 240 J = 1, K - DO 230 I = 1, LASTC - C( I, N-K+J ) = C( I, N-K+J ) - WORK(I, J) + DO 230 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 230 CONTINUE 240 CONTINUE * diff --git a/lib/linalg/dlarfg.f b/lib/linalg/dlarfg.f index ce91d33c1a..cb177a5703 100644 --- a/lib/linalg/dlarfg.f +++ b/lib/linalg/dlarfg.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARFG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARFG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * DOUBLE PRECISION ALPHA, TAU @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lib/linalg/dlarft.f b/lib/linalg/dlarft.f index bc1b53b2ce..e69a6b792e 100644 --- a/lib/linalg/dlarft.f +++ b/lib/linalg/dlarft.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARFT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARFT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, STOREV * INTEGER K, LDT, LDV, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -163,10 +163,10 @@ * ===================================================================== SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV @@ -221,13 +221,13 @@ END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * V( I , J ) - END DO + 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, + 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. @@ -236,7 +236,7 @@ END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * V( J , I ) - END DO + END DO J = MIN( LASTV, PREVLASTV ) * * T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T @@ -280,7 +280,7 @@ END DO DO J = I+1, K T( J, I ) = -TAU( I ) * V( N-K+I , J ) - END DO + 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) @@ -295,7 +295,7 @@ END DO DO J = I+1, K T( J, I ) = -TAU( I ) * V( J, N-K+I ) - END DO + 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 diff --git a/lib/linalg/dlartg.f b/lib/linalg/dlartg.f index bf74c4365c..1c7c46f638 100644 --- a/lib/linalg/dlartg.f +++ b/lib/linalg/dlartg.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARTG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARTG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARTG( F, G, CS, SN, R ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION CS, F, G, R, SN * .. -* +* * *> \par Purpose: * ============= @@ -85,22 +85,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLARTG( F, G, CS, SN, R ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION CS, F, G, R, SN diff --git a/lib/linalg/dlas2.f b/lib/linalg/dlas2.f index 81077f940d..83873bc612 100644 --- a/lib/linalg/dlas2.f +++ b/lib/linalg/dlas2.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION F, G, H, SSMAX, SSMIN * .. -* +* * *> \par Purpose: * ============= @@ -73,14 +73,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -107,10 +107,10 @@ * ===================================================================== SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION F, G, H, SSMAX, SSMIN diff --git a/lib/linalg/dlascl.f b/lib/linalg/dlascl.f index 9b9b33c0c1..03e1000a87 100644 --- a/lib/linalg/dlascl.f +++ b/lib/linalg/dlascl.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASCL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASCL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TYPE * INTEGER INFO, KL, KU, LDA, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,7 +114,11 @@ *> \param[in] LDA *> \verbatim *> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). +*> The leading dimension of the array A. +*> If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M); +*> TYPE = 'B', LDA >= KL+1; +*> TYPE = 'Q', LDA >= KU+1; +*> TYPE = 'Z', LDA >= 2*KL+KU+1. *> \endverbatim *> *> \param[out] INFO @@ -127,22 +131,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER TYPE diff --git a/lib/linalg/dlaset.f b/lib/linalg/dlaset.f index 1ce34662ab..3a0c469a3c 100644 --- a/lib/linalg/dlaset.f +++ b/lib/linalg/dlaset.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASET + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASET + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -77,7 +77,7 @@ *> The constant to which the diagonal elements are to be set. *> \endverbatim *> -*> \param[in,out] A +*> \param[out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On exit, the leading m-by-n submatrix of A is set as follows: @@ -98,22 +98,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lib/linalg/dlasq1.f b/lib/linalg/dlasq1.f index d12fb7a5fd..468676eebd 100644 --- a/lib/linalg/dlasq1.f +++ b/lib/linalg/dlasq1.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASQ1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASQ1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -89,29 +89,29 @@ *> represent a matrix with the same singular values *> which the calling subroutine could use to finish the *> computation, or even feed back into DLASQ1 -*> = 3, termination criterion of outer while loop not met +*> = 3, termination criterion of outer while loop not met *> (program created more than N unreduced blocks) *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N @@ -144,7 +144,7 @@ * INFO = 0 IF( N.LT.0 ) THEN - INFO = -2 + INFO = -1 CALL XERBLA( 'DLASQ1', -INFO ) RETURN ELSE IF( N.EQ.0 ) THEN @@ -189,7 +189,7 @@ CALL DCOPY( N-1, E, 1, WORK( 2 ), 2 ) CALL DLASCL( 'G', 0, 0, SIGMX, SCALE, 2*N-1, 1, WORK, 2*N-1, $ IINFO ) -* +* * Compute the q's and e's. * DO 30 I = 1, 2*N - 1 diff --git a/lib/linalg/dlasq2.f b/lib/linalg/dlasq2.f index df1690d020..68d9228704 100644 --- a/lib/linalg/dlasq2.f +++ b/lib/linalg/dlasq2.f @@ -2,38 +2,38 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASQ2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASQ2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASQ2( N, Z, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * .. * .. Array Arguments .. * DOUBLE PRECISION Z( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> DLASQ2 computes all the eigenvalues of the symmetric positive +*> DLASQ2 computes all the eigenvalues of the symmetric positive *> definite tridiagonal matrix associated with the qd array Z to high *> relative accuracy are computed to high relative accuracy, in the *> absence of denormalization, underflow and overflow. @@ -83,19 +83,19 @@ *> = 2, current block of Z not diagonalized after 100*N *> iterations (in inner while loop). On exit Z holds *> a qd array with the same eigenvalues as the given Z. -*> = 3, termination criterion of outer while loop not met +*> = 3, termination criterion of outer while loop not met *> (program created more than N unreduced blocks) *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -112,10 +112,10 @@ * ===================================================================== SUBROUTINE DLASQ2( N, Z, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N @@ -136,7 +136,7 @@ * .. Local Scalars .. LOGICAL IEEE INTEGER I0, I1, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, - $ K, KMIN, N0, N1, NBIG, NDIV, NFAIL, PP, SPLT, + $ K, KMIN, N0, N1, NBIG, NDIV, NFAIL, PP, SPLT, $ TTYPE DOUBLE PRECISION D, DEE, DEEMIN, DESIG, DMIN, DMIN1, DMIN2, DN, $ DN1, DN2, E, EMAX, EMIN, EPS, G, OLDEMN, QMAX, @@ -155,7 +155,7 @@ INTRINSIC ABS, DBLE, MAX, MIN, SQRT * .. * .. Executable Statements .. -* +* * Test the input arguments. * (in case DLASQ2 is not called by DLASQ1) * @@ -195,7 +195,7 @@ END IF Z( 5 ) = Z( 1 ) + Z( 2 ) + Z( 3 ) IF( Z( 2 ).GT.Z( 3 )*TOL2 ) THEN - T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) ) + T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) ) S = Z( 3 )*( Z( 2 ) / T ) IF( S.LE.T ) THEN S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) ) @@ -264,19 +264,19 @@ Z( 2*N-1 ) = ZERO RETURN END IF -* +* * Check whether the machine is IEEE conformable. -* +* IEEE = ILAENV( 10, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND. - $ ILAENV( 11, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 -* + $ ILAENV( 11, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 +* * Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). * DO 30 K = 2*N, 2, -2 - Z( 2*K ) = ZERO - Z( 2*K-1 ) = Z( K ) - Z( 2*K-2 ) = ZERO - Z( 2*K-3 ) = Z( K-1 ) + Z( 2*K ) = ZERO + Z( 2*K-1 ) = Z( K ) + Z( 2*K-2 ) = ZERO + Z( 2*K-3 ) = Z( K-1 ) 30 CONTINUE * I0 = 1 @@ -333,7 +333,7 @@ D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) ) END IF EMIN = MIN( EMIN, Z( I4-2*PP ) ) - 60 CONTINUE + 60 CONTINUE Z( 4*N0-PP-2 ) = D * * Now find qmax. @@ -364,14 +364,14 @@ NDIV = 2*( N0-I0 ) * DO 160 IWHILA = 1, N + 1 - IF( N0.LT.1 ) + IF( N0.LT.1 ) $ GO TO 170 * -* While array unfinished do +* While array unfinished do * * E(N0) holds the value of SIGMA when submatrix in I0:N0 * splits from the rest of the array, but is negated. -* +* DESIG = ZERO IF( N0.EQ.N ) THEN SIGMA = ZERO @@ -386,7 +386,7 @@ * Find last unreduced submatrix's top index I0, find QMAX and * EMIN. Find Gershgorin-type bound if Q's much greater than E's. * - EMAX = ZERO + EMAX = ZERO IF( N0.GT.I0 ) THEN EMIN = ABS( Z( 4*N0-5 ) ) ELSE @@ -404,7 +404,7 @@ QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) ) EMIN = MIN( EMIN, Z( I4-5 ) ) 90 CONTINUE - I4 = 4 + I4 = 4 * 100 CONTINUE I0 = I4 / 4 @@ -421,7 +421,7 @@ KMIN = ( I4+3 )/4 END IF 110 CONTINUE - IF( (KMIN-I0)*2.LT.N0-KMIN .AND. + IF( (KMIN-I0)*2.LT.N0-KMIN .AND. $ DEEMIN.LE.HALF*Z(4*N0-3) ) THEN IPN4 = 4*( I0+N0 ) PP = 2 @@ -446,15 +446,15 @@ * DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) ) * -* Now I0:N0 is unreduced. +* Now I0:N0 is unreduced. * PP = 0 for ping, PP = 1 for pong. * PP = 2 indicates that flipping was applied to the Z array and -* and that the tests for deflation upon entry in DLASQ3 +* and that the tests for deflation upon entry in DLASQ3 * should not be performed. * NBIG = 100*( N0-I0+1 ) DO 140 IWHILB = 1, NBIG - IF( I0.GT.N0 ) + IF( I0.GT.N0 ) $ GO TO 150 * * While submatrix unfinished take a good dqds step. @@ -497,8 +497,8 @@ 140 CONTINUE * INFO = 2 -* -* Maximum number of iterations exceeded, restore the shift +* +* Maximum number of iterations exceeded, restore the shift * SIGMA and place the new d's and e's in a qd array. * This might need to be done for several blocks * @@ -549,16 +549,16 @@ INFO = 3 RETURN * -* end IWHILA +* end IWHILA * 170 CONTINUE -* +* * Move q's to the front. -* +* DO 180 K = 2, N Z( K ) = Z( 4*K-3 ) 180 CONTINUE -* +* * Sort and compute sum of eigenvalues. * CALL DLASRT( 'D', N, Z, IINFO ) @@ -570,7 +570,7 @@ * * Store trace, sum(eigenvalues) and information on performance. * - Z( 2*N+1 ) = TRACE + Z( 2*N+1 ) = TRACE Z( 2*N+2 ) = E Z( 2*N+3 ) = DBLE( ITER ) Z( 2*N+4 ) = DBLE( NDIV ) / DBLE( N**2 ) diff --git a/lib/linalg/dlasq3.f b/lib/linalg/dlasq3.f index d49d1c5939..c095bdbbb5 100644 --- a/lib/linalg/dlasq3.f +++ b/lib/linalg/dlasq3.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASQ3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASQ3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, * ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, * DN2, G, TAU ) -* +* * .. Scalar Arguments .. * LOGICAL IEEE * INTEGER I0, ITER, N0, NDIV, NFAIL, PP @@ -31,7 +31,7 @@ * .. Array Arguments .. * DOUBLE PRECISION Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -58,9 +58,9 @@ *> Last index. *> \endverbatim *> -*> \param[in] Z +*> \param[in,out] Z *> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( 4*N ) +*> Z is DOUBLE PRECISION array, dimension ( 4*N0 ) *> Z holds the qd array. *> \endverbatim *> @@ -68,8 +68,8 @@ *> \verbatim *> PP is INTEGER *> PP=0 for ping, PP=1 for pong. -*> PP=2 indicates that flipping was applied to the Z array -*> and that the initial tests for deflation should not be +*> PP=2 indicates that flipping was applied to the Z array +*> and that the initial tests for deflation should not be *> performed. *> \endverbatim *> @@ -97,22 +97,22 @@ *> Maximum value of q. *> \endverbatim *> -*> \param[out] NFAIL +*> \param[in,out] NFAIL *> \verbatim *> NFAIL is INTEGER -*> Number of times shift was too big. +*> Increment NFAIL by 1 each time the shift was too big. *> \endverbatim *> -*> \param[out] ITER +*> \param[in,out] ITER *> \verbatim *> ITER is INTEGER -*> Number of iterations. +*> Increment ITER by 1 for each iteration. *> \endverbatim *> -*> \param[out] NDIV +*> \param[in,out] NDIV *> \verbatim *> NDIV is INTEGER -*> Number of divisions. +*> Increment NDIV by 1 for each division. *> \endverbatim *> *> \param[in] IEEE @@ -168,12 +168,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * @@ -182,10 +182,10 @@ $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, $ DN2, G, TAU ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. LOGICAL IEEE @@ -286,7 +286,7 @@ GO TO 10 * 50 CONTINUE - IF( PP.EQ.2 ) + IF( PP.EQ.2 ) $ PP = 0 * * Reverse the qd-array, if warranted. @@ -345,7 +345,7 @@ * GO TO 90 * - ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. + ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND. $ ABS( DN ).LT.TOL*SIGMA ) THEN * @@ -389,7 +389,7 @@ GO TO 70 END IF ELSE -* +* * Possible underflow. Play it safe. * GO TO 80 diff --git a/lib/linalg/dlasq4.f b/lib/linalg/dlasq4.f index 97d9bdeba3..d4ddbbc7b2 100644 --- a/lib/linalg/dlasq4.f +++ b/lib/linalg/dlasq4.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASQ4 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASQ4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, * DN1, DN2, TAU, TTYPE, G ) -* +* * .. Scalar Arguments .. * INTEGER I0, N0, N0IN, PP, TTYPE * DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -56,7 +56,7 @@ *> *> \param[in] Z *> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( 4*N ) +*> Z is DOUBLE PRECISION array, dimension ( 4*N0 ) *> Z holds the qd array. *> \endverbatim *> @@ -122,7 +122,7 @@ *> *> \param[in,out] G *> \verbatim -*> G is REAL +*> G is DOUBLE PRECISION *> G is passed as an argument in order to save its value between *> calls to DLASQ4. *> \endverbatim @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * @@ -151,10 +151,10 @@ SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, $ DN1, DN2, TAU, TTYPE, G ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER I0, N0, N0IN, PP, TTYPE @@ -192,7 +192,7 @@ TTYPE = -1 RETURN END IF -* +* NN = 4*N0 + PP IF( N0IN.EQ.N0 ) THEN * @@ -240,7 +240,6 @@ NP = NN - 9 ELSE NP = NN - 2*PP - B2 = Z( NP-2 ) GAM = DN1 IF( Z( NP-4 ) .GT. Z( NP-2 ) ) $ RETURN @@ -262,7 +261,7 @@ $ RETURN B2 = B2*( Z( I4 ) / Z( I4-2 ) ) A2 = A2 + B2 - IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) + IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) $ GO TO 20 10 CONTINUE 20 CONTINUE @@ -303,7 +302,7 @@ $ RETURN B2 = B2*( Z( I4 ) / Z( I4-2 ) ) A2 = A2 + B2 - IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) + IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) $ GO TO 40 30 CONTINUE 40 CONTINUE @@ -331,7 +330,7 @@ * * One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. * - IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN + IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN * * Cases 7 and 8. * @@ -349,7 +348,7 @@ $ RETURN B1 = B1*( Z( I4 ) / Z( I4-2 ) ) B2 = B2 + B1 - IF( HUNDRD*MAX( B1, A2 ).LT.B2 ) + IF( HUNDRD*MAX( B1, A2 ).LT.B2 ) $ GO TO 60 50 CONTINUE 60 CONTINUE @@ -358,7 +357,7 @@ GAP2 = HALF*DMIN2 - A2 IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) - ELSE + ELSE S = MAX( S, A2*( ONE-CNST2*B2 ) ) TTYPE = -8 END IF @@ -378,7 +377,7 @@ * * Cases 10 and 11. * - IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN + IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN TTYPE = -10 S = THIRD*DMIN2 IF( Z( NN-5 ).GT.Z( NN-7 ) ) @@ -402,7 +401,7 @@ $ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2 IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) - ELSE + ELSE S = MAX( S, A2*( ONE-CNST2*B2 ) ) END IF ELSE @@ -413,7 +412,7 @@ * * Case 12, more than two eigenvalues deflated. No information. * - S = ZERO + S = ZERO TTYPE = -12 END IF * diff --git a/lib/linalg/dlasq5.f b/lib/linalg/dlasq5.f index cdd8cf1ae3..3812c879fa 100644 --- a/lib/linalg/dlasq5.f +++ b/lib/linalg/dlasq5.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASQ5 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASQ5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DN, * DNM1, DNM2, IEEE, EPS ) -* +* * .. Scalar Arguments .. * LOGICAL IEEE * INTEGER I0, N0, PP @@ -29,7 +29,7 @@ * .. Array Arguments .. * DOUBLE PRECISION Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -121,7 +121,7 @@ *> IEEE is LOGICAL *> Flag for IEEE or non IEEE arithmetic. *> \endverbatim -* +*> *> \param[in] EPS *> \verbatim *> EPS is DOUBLE PRECISION @@ -131,12 +131,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2017 * *> \ingroup auxOTHERcomputational * @@ -144,10 +144,10 @@ SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, $ DN, DNM1, DNM2, IEEE, EPS ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2017 * * .. Scalar Arguments .. LOGICAL IEEE @@ -181,7 +181,7 @@ IF( TAU.LT.DTHRESH*HALF ) TAU = ZERO IF( TAU.NE.ZERO ) THEN J4 = 4*I0 + PP - 3 - EMIN = Z( J4+4 ) + EMIN = Z( J4+4 ) D = Z( J4 ) - TAU DMIN = D DMIN1 = -Z( J4 ) @@ -192,7 +192,7 @@ * IF( PP.EQ.0 ) THEN DO 10 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) + Z( J4-2 ) = D + Z( J4-1 ) TEMP = Z( J4+1 ) / Z( J4-2 ) D = D*TEMP - TAU DMIN = MIN( DMIN, D ) @@ -201,7 +201,7 @@ 10 CONTINUE ELSE DO 20 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) + Z( J4-3 ) = D + Z( J4 ) TEMP = Z( J4+2 ) / Z( J4-3 ) D = D*TEMP - TAU DMIN = MIN( DMIN, D ) @@ -210,7 +210,7 @@ 20 CONTINUE END IF * -* Unroll last two steps. +* Unroll last two steps. * DNM2 = D DMIN2 = DMIN @@ -235,10 +235,10 @@ * IF( PP.EQ.0 ) THEN DO 30 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) + Z( J4-2 ) = D + Z( J4-1 ) IF( D.LT.ZERO ) THEN RETURN - ELSE + ELSE Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU END IF @@ -247,10 +247,10 @@ 30 CONTINUE ELSE DO 40 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) + Z( J4-3 ) = D + Z( J4 ) IF( D.LT.ZERO ) THEN RETURN - ELSE + ELSE Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU END IF @@ -259,7 +259,7 @@ 40 CONTINUE END IF * -* Unroll last two steps. +* Unroll last two steps. * DNM2 = D DMIN2 = DMIN @@ -290,17 +290,17 @@ ELSE * This is the version that sets d's to zero if they are small enough J4 = 4*I0 + PP - 3 - EMIN = Z( J4+4 ) + EMIN = Z( J4+4 ) D = Z( J4 ) - TAU DMIN = D DMIN1 = -Z( J4 ) IF( IEEE ) THEN -* +* * Code for IEEE arithmetic. -* +* IF( PP.EQ.0 ) THEN DO 50 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) + Z( J4-2 ) = D + Z( J4-1 ) TEMP = Z( J4+1 ) / Z( J4-2 ) D = D*TEMP - TAU IF( D.LT.DTHRESH ) D = ZERO @@ -310,7 +310,7 @@ 50 CONTINUE ELSE DO 60 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) + Z( J4-3 ) = D + Z( J4 ) TEMP = Z( J4+2 ) / Z( J4-3 ) D = D*TEMP - TAU IF( D.LT.DTHRESH ) D = ZERO @@ -319,9 +319,9 @@ EMIN = MIN( Z( J4-1 ), EMIN ) 60 CONTINUE END IF -* -* Unroll last two steps. -* +* +* Unroll last two steps. +* DNM2 = D DMIN2 = DMIN J4 = 4*( N0-2 ) - PP @@ -330,7 +330,7 @@ Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU DMIN = MIN( DMIN, DNM1 ) -* +* DMIN1 = DMIN J4 = J4 + 4 J4P2 = J4 + 2*PP - 1 @@ -338,17 +338,17 @@ Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU DMIN = MIN( DMIN, DN ) -* +* ELSE -* +* * Code for non IEEE arithmetic. -* +* IF( PP.EQ.0 ) THEN DO 70 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) + Z( J4-2 ) = D + Z( J4-1 ) IF( D.LT.ZERO ) THEN RETURN - ELSE + ELSE Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU END IF @@ -358,10 +358,10 @@ 70 CONTINUE ELSE DO 80 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) + Z( J4-3 ) = D + Z( J4 ) IF( D.LT.ZERO ) THEN RETURN - ELSE + ELSE Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU END IF @@ -370,9 +370,9 @@ EMIN = MIN( EMIN, Z( J4-1 ) ) 80 CONTINUE END IF -* -* Unroll last two steps. -* +* +* Unroll last two steps. +* DNM2 = D DMIN2 = DMIN J4 = 4*( N0-2 ) - PP @@ -385,7 +385,7 @@ DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU END IF DMIN = MIN( DMIN, DNM1 ) -* +* DMIN1 = DMIN J4 = J4 + 4 J4P2 = J4 + 2*PP - 1 @@ -397,10 +397,10 @@ DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU END IF DMIN = MIN( DMIN, DN ) -* +* END IF END IF -* +* Z( J4+2 ) = DN Z( 4*N0-PP ) = EMIN RETURN diff --git a/lib/linalg/dlasq6.f b/lib/linalg/dlasq6.f index 3c8661bbba..d871386bdb 100644 --- a/lib/linalg/dlasq6.f +++ b/lib/linalg/dlasq6.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASQ6 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASQ6 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, * DNM1, DNM2 ) -* +* * .. Scalar Arguments .. * INTEGER I0, N0, PP * DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,12 +106,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -119,10 +119,10 @@ SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, $ DNM1, DNM2 ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER I0, N0, PP @@ -156,13 +156,13 @@ * SAFMIN = DLAMCH( 'Safe minimum' ) J4 = 4*I0 + PP - 3 - EMIN = Z( J4+4 ) + EMIN = Z( J4+4 ) D = Z( J4 ) DMIN = D * IF( PP.EQ.0 ) THEN DO 10 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) + Z( J4-2 ) = D + Z( J4-1 ) IF( Z( J4-2 ).EQ.ZERO ) THEN Z( J4 ) = ZERO D = Z( J4+1 ) @@ -173,7 +173,7 @@ TEMP = Z( J4+1 ) / Z( J4-2 ) Z( J4 ) = Z( J4-1 )*TEMP D = D*TEMP - ELSE + ELSE Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) D = Z( J4+1 )*( D / Z( J4-2 ) ) END IF @@ -182,7 +182,7 @@ 10 CONTINUE ELSE DO 20 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) + Z( J4-3 ) = D + Z( J4 ) IF( Z( J4-3 ).EQ.ZERO ) THEN Z( J4-1 ) = ZERO D = Z( J4+2 ) @@ -193,7 +193,7 @@ TEMP = Z( J4+2 ) / Z( J4-3 ) Z( J4-1 ) = Z( J4 )*TEMP D = D*TEMP - ELSE + ELSE Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) D = Z( J4+2 )*( D / Z( J4-3 ) ) END IF @@ -202,7 +202,7 @@ 20 CONTINUE END IF * -* Unroll last two steps. +* Unroll last two steps. * DNM2 = D DMIN2 = DMIN diff --git a/lib/linalg/dlasr.f b/lib/linalg/dlasr.f index 645d03b3d8..6059c6293a 100644 --- a/lib/linalg/dlasr.f +++ b/lib/linalg/dlasr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, PIVOT, SIDE * INTEGER LDA, M, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -36,35 +36,35 @@ *> *> DLASR applies a sequence of plane rotations to a real matrix A, *> from either the left or the right. -*> +*> *> When SIDE = 'L', the transformation takes the form -*> +*> *> A := P*A -*> +*> *> and when SIDE = 'R', the transformation takes the form -*> +*> *> A := A*P**T -*> +*> *> where P is an orthogonal matrix consisting of a sequence of z plane *> rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', *> and P**T is the transpose of P. -*> +*> *> When DIRECT = 'F' (Forward sequence), then -*> +*> *> P = P(z-1) * ... * P(2) * P(1) -*> +*> *> and when DIRECT = 'B' (Backward sequence), then -*> +*> *> P = P(1) * P(2) * ... * P(z-1) -*> +*> *> where P(k) is a plane rotation matrix defined by the 2-by-2 rotation -*> +*> *> R(k) = ( c(k) s(k) ) *> = ( -s(k) c(k) ). -*> +*> *> When PIVOT = 'V' (Variable pivot), the rotation is performed *> for the plane (k,k+1), i.e., P(k) has the form -*> +*> *> P(k) = ( 1 ) *> ( ... ) *> ( 1 ) @@ -73,13 +73,13 @@ *> ( 1 ) *> ( ... ) *> ( 1 ) -*> +*> *> where R(k) appears as a rank-2 modification to the identity matrix in *> rows and columns k and k+1. -*> +*> *> When PIVOT = 'T' (Top pivot), the rotation is performed for the *> plane (1,k+1), so P(k) has the form -*> +*> *> P(k) = ( c(k) s(k) ) *> ( 1 ) *> ( ... ) @@ -88,12 +88,12 @@ *> ( 1 ) *> ( ... ) *> ( 1 ) -*> +*> *> where R(k) appears in rows and columns 1 and k+1. -*> +*> *> Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is *> performed for the plane (k,z), giving P(k) the form -*> +*> *> P(k) = ( 1 ) *> ( ... ) *> ( 1 ) @@ -102,7 +102,7 @@ *> ( ... ) *> ( 1 ) *> ( -s(k) c(k) ) -*> +*> *> where R(k) appears in rows and columns k and z. The rotations are *> performed without ever forming P(k) explicitly. *> \endverbatim @@ -187,22 +187,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE diff --git a/lib/linalg/dlasrt.f b/lib/linalg/dlasrt.f index f5d0e6cd1a..4705311d78 100644 --- a/lib/linalg/dlasrt.f +++ b/lib/linalg/dlasrt.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASRT( ID, N, D, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER ID * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( * ) * .. -* +* * *> \par Purpose: * ============= @@ -76,22 +76,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DLASRT( ID, N, D, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER ID @@ -123,7 +123,7 @@ * .. * .. Executable Statements .. * -* Test the input paramters. +* Test the input parameters. * INFO = 0 DIR = -1 diff --git a/lib/linalg/dlassq.f b/lib/linalg/dlassq.f index c7c4087e80..885395e3c9 100644 --- a/lib/linalg/dlassq.f +++ b/lib/linalg/dlassq.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASSQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASSQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * DOUBLE PRECISION SCALE, SUMSQ @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -91,22 +91,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lib/linalg/dlasv2.f b/lib/linalg/dlasv2.f index 96aaa1e45c..9371d6d3b2 100644 --- a/lib/linalg/dlasv2.f +++ b/lib/linalg/dlasv2.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASV2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASV2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN * .. -* +* * *> \par Purpose: * ============= @@ -102,14 +102,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -138,10 +138,10 @@ * ===================================================================== SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN diff --git a/lib/linalg/dlaswp.f b/lib/linalg/dlaswp.f index 937e12b2f0..202fd8df1b 100644 --- a/lib/linalg/dlaswp.f +++ b/lib/linalg/dlaswp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASWP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASWP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* +* * .. Scalar Arguments .. * INTEGER INCX, K1, K2, LDA, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -71,34 +71,35 @@ *> \param[in] K2 *> \verbatim *> K2 is INTEGER -*> The last element of IPIV for which a row interchange will -*> be done. +*> (K2-K1+1) is the number of elements of IPIV for which a row +*> interchange will be done. *> \endverbatim *> *> \param[in] IPIV *> \verbatim -*> IPIV is INTEGER array, dimension (K2*abs(INCX)) -*> The vector of pivot indices. Only the elements in positions -*> K1 through K2 of IPIV are accessed. -*> IPIV(K) = L implies rows K and L are to be interchanged. +*> IPIV is INTEGER array, dimension (K1+(K2-K1)*abs(INCX)) +*> The vector of pivot indices. Only the elements in positions +*> K1 through K1+(K2-K1)*abs(INCX) of IPIV are accessed. +*> IPIV(K1+(K-K1)*abs(INCX)) = L implies rows K and L are to be +*> interchanged. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER -*> The increment between successive values of IPIV. If IPIV +*> The increment between successive values of IPIV. If INCX *> is negative, the pivots are applied in reverse order. *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2017 * *> \ingroup doubleOTHERauxiliary * @@ -114,10 +115,10 @@ * ===================================================================== SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2017 * * .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N @@ -135,7 +136,8 @@ * .. * .. Executable Statements .. * -* Interchange row I with row IPIV(I) for each of rows K1 through K2. +* Interchange row I with row IPIV(K1+(I-K1)*abs(INCX)) for each of rows +* K1 through K2. * IF( INCX.GT.0 ) THEN IX0 = K1 @@ -143,7 +145,7 @@ I2 = K2 INC = 1 ELSE IF( INCX.LT.0 ) THEN - IX0 = 1 + ( 1-K2 )*INCX + IX0 = K1 + ( K1-K2 )*INCX I1 = K2 I2 = K1 INC = -1 diff --git a/lib/linalg/dlatrd.f b/lib/linalg/dlatrd.f index 69ec0018be..a1df43e48a 100644 --- a/lib/linalg/dlatrd.f +++ b/lib/linalg/dlatrd.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLATRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLATRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDW, N, NB @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) * .. -* +* * *> \par Purpose: * ============= @@ -134,12 +134,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -198,10 +198,10 @@ * ===================================================================== SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lib/linalg/dlatrs.f b/lib/linalg/dlatrs.f index b34795eb15..5ad5f66c55 100644 --- a/lib/linalg/dlatrs.f +++ b/lib/linalg/dlatrs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLATRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLATRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, * CNORM, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORMIN, TRANS, UPLO * INTEGER INFO, LDA, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), CNORM( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -238,10 +238,10 @@ SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO diff --git a/lib/linalg/dnrm2.f b/lib/linalg/dnrm2.f index 5ea257a200..30552e1d1d 100644 --- a/lib/linalg/dnrm2.f +++ b/lib/linalg/dnrm2.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * .. * .. Array Arguments .. * DOUBLE PRECISION X(*) * .. -* +* * *> \par Purpose: * ============= @@ -29,15 +29,35 @@ *> DNRM2 := sqrt( x'*x ) *> \endverbatim * +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +* * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * @@ -54,10 +74,10 @@ * ===================================================================== DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lib/linalg/dorg2l.f b/lib/linalg/dorg2l.f index b95fa50fc5..36ff4e5d4b 100644 --- a/lib/linalg/dorg2l.f +++ b/lib/linalg/dorg2l.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORG2L + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORG2L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lib/linalg/dorg2r.f b/lib/linalg/dorg2r.f index 86df6dddc7..4b71011a9f 100644 --- a/lib/linalg/dorg2r.f +++ b/lib/linalg/dorg2r.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORG2R + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORG2R + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lib/linalg/dorgbr.f b/lib/linalg/dorgbr.f index ddfa7262a0..cfebda5abd 100644 --- a/lib/linalg/dorgbr.f +++ b/lib/linalg/dorgbr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORGBR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORGBR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER VECT * INTEGER INFO, K, LDA, LWORK, M, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -145,10 +145,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -157,7 +157,7 @@ * ===================================================================== SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 @@ -182,8 +182,7 @@ * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV + EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DORGLQ, DORGQR, XERBLA diff --git a/lib/linalg/dorgl2.f b/lib/linalg/dorgl2.f index 3e8398b73f..5d8985d758 100644 --- a/lib/linalg/dorgl2.f +++ b/lib/linalg/dorgl2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORGL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORGL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lib/linalg/dorglq.f b/lib/linalg/dorglq.f index 88aec15005..912b5de84e 100644 --- a/lib/linalg/dorglq.f +++ b/lib/linalg/dorglq.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORGLQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORGLQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N diff --git a/lib/linalg/dorgql.f b/lib/linalg/dorgql.f index ca4698d799..ea12be91b1 100644 --- a/lib/linalg/dorgql.f +++ b/lib/linalg/dorgql.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORGQL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORGQL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N diff --git a/lib/linalg/dorgqr.f b/lib/linalg/dorgqr.f index 404ab184e6..628eeacba7 100644 --- a/lib/linalg/dorgqr.f +++ b/lib/linalg/dorgqr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORGQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORGQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N diff --git a/lib/linalg/dorgtr.f b/lib/linalg/dorgtr.f index 06a7b6cc1c..72623eac06 100644 --- a/lib/linalg/dorgtr.f +++ b/lib/linalg/dorgtr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORGTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORGTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,22 +111,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lib/linalg/dorm2l.f b/lib/linalg/dorm2l.f index 3ff25869a7..1014cb2378 100644 --- a/lib/linalg/dorm2l.f +++ b/lib/linalg/dorm2l.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORM2L + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORM2L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -159,10 +159,10 @@ SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lib/linalg/dorm2r.f b/lib/linalg/dorm2r.f index b13f12d53c..632b70e740 100644 --- a/lib/linalg/dorm2r.f +++ b/lib/linalg/dorm2r.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORM2R + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORM2R + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -159,10 +159,10 @@ SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lib/linalg/dormbr.f b/lib/linalg/dormbr.f index 7a0d9b9038..f035d0ae66 100644 --- a/lib/linalg/dormbr.f +++ b/lib/linalg/dormbr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORMBR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORMBR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, * LDC, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS, VECT * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -182,12 +182,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -195,10 +195,10 @@ SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, VECT diff --git a/lib/linalg/dorml2.f b/lib/linalg/dorml2.f index 9ae2396e12..2c55c7f1fd 100644 --- a/lib/linalg/dorml2.f +++ b/lib/linalg/dorml2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORML2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORML2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -159,10 +159,10 @@ SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lib/linalg/dormlq.f b/lib/linalg/dormlq.f index ebbd4d26e2..bb5469d273 100644 --- a/lib/linalg/dormlq.f +++ b/lib/linalg/dormlq.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORMLQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORMLQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -136,9 +136,7 @@ *> The dimension of the array WORK. *> If SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). -*> For optimum performance LWORK >= N*NB if SIDE = 'L', and -*> LWORK >= M*NB if SIDE = 'R', where NB is the optimal -*> blocksize. +*> For good performance, LWORK should generally be larger. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns @@ -156,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -169,10 +167,10 @@ SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -185,18 +183,16 @@ * ===================================================================== * * .. Parameters .. - INTEGER NBMAX, LDT - PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) + INTEGER NBMAX, LDT, TSIZE + PARAMETER ( NBMAX = 64, LDT = NBMAX+1, + $ TSIZE = LDT*NBMAX ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN CHARACTER TRANST - INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. -* .. Local Arrays .. - DOUBLE PRECISION T( LDT, NBMAX ) -* .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV @@ -246,12 +242,11 @@ * IF( INFO.EQ.0 ) THEN * -* Determine the block size. NB may be at most NBMAX, where NBMAX -* is used to define the local array T. +* Compute the workspace requirements * NB = MIN( NBMAX, ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N, K, $ -1 ) ) - LWKOPT = MAX( 1, NW )*NB + LWKOPT = MAX( 1, NW )*NB + TSIZE WORK( 1 ) = LWKOPT END IF * @@ -272,14 +267,11 @@ NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN - IWS = NW*NB - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK + IF( LWORK.LT.NW*NB+TSIZE ) THEN + NB = (LWORK-TSIZE) / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DORMLQ', SIDE // TRANS, M, N, K, $ -1 ) ) END IF - ELSE - IWS = NW END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN @@ -292,6 +284,7 @@ * * Use blocked code * + IWT = 1 + NW*NB IF( ( LEFT .AND. NOTRAN ) .OR. $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN I1 = 1 @@ -324,7 +317,7 @@ * H = H(i) H(i+1) . . . H(i+ib-1) * CALL DLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ), - $ LDA, TAU( I ), T, LDT ) + $ LDA, TAU( I ), WORK( IWT ), LDT ) IF( LEFT ) THEN * * H or H**T is applied to C(i:m,1:n) @@ -342,8 +335,8 @@ * Apply H or H**T * CALL DLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB, - $ A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, WORK, - $ LDWORK ) + $ A( I, I ), LDA, WORK( IWT ), LDT, + $ C( IC, JC ), LDC, WORK, LDWORK ) 10 CONTINUE END IF WORK( 1 ) = LWKOPT diff --git a/lib/linalg/dormql.f b/lib/linalg/dormql.f index 96c6f1958e..7d2b5d6c32 100644 --- a/lib/linalg/dormql.f +++ b/lib/linalg/dormql.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORMQL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORMQL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -136,9 +136,7 @@ *> The dimension of the array WORK. *> If SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). -*> For optimum performance LWORK >= N*NB if SIDE = 'L', and -*> LWORK >= M*NB if SIDE = 'R', where NB is the optimal -*> blocksize. +*> For good performance, LWORK should generally be larger. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns @@ -156,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -169,10 +167,10 @@ SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -185,17 +183,15 @@ * ===================================================================== * * .. Parameters .. - INTEGER NBMAX, LDT - PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) + INTEGER NBMAX, LDT, TSIZE + PARAMETER ( NBMAX = 64, LDT = NBMAX+1, + $ TSIZE = LDT*NBMAX ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN - INTEGER I, I1, I2, I3, IB, IINFO, IWS, LDWORK, LWKOPT, + INTEGER I, I1, I2, I3, IB, IINFO, IWT, LDWORK, LWKOPT, $ MI, NB, NBMIN, NI, NQ, NW * .. -* .. Local Arrays .. - DOUBLE PRECISION T( LDT, NBMAX ) -* .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV @@ -239,25 +235,22 @@ INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 + ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN + INFO = -12 END IF * IF( INFO.EQ.0 ) THEN +* +* Compute the workspace requirements +* IF( M.EQ.0 .OR. N.EQ.0 ) THEN LWKOPT = 1 ELSE -* -* Determine the block size. NB may be at most NBMAX, where -* NBMAX is used to define the local array T. -* NB = MIN( NBMAX, ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N, $ K, -1 ) ) - LWKOPT = NW*NB + LWKOPT = NW*NB + TSIZE END IF WORK( 1 ) = LWKOPT -* - IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF END IF * IF( INFO.NE.0 ) THEN @@ -276,14 +269,11 @@ NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN - IWS = NW*NB - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK + IF( LWORK.LT.NW*NB+TSIZE ) THEN + NB = (LWORK-TSIZE) / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DORMQL', SIDE // TRANS, M, N, K, $ -1 ) ) END IF - ELSE - IWS = NW END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN @@ -296,6 +286,7 @@ * * Use blocked code * + IWT = 1 + NW*NB IF( ( LEFT .AND. NOTRAN ) .OR. $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN I1 = 1 @@ -320,7 +311,7 @@ * H = H(i+ib-1) . . . H(i+1) H(i) * CALL DLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB, - $ A( 1, I ), LDA, TAU( I ), T, LDT ) + $ A( 1, I ), LDA, TAU( I ), WORK( IWT ), LDT ) IF( LEFT ) THEN * * H or H**T is applied to C(1:m-k+i+ib-1,1:n) @@ -336,8 +327,8 @@ * Apply H or H**T * CALL DLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI, - $ IB, A( 1, I ), LDA, T, LDT, C, LDC, WORK, - $ LDWORK ) + $ IB, A( 1, I ), LDA, WORK( IWT ), LDT, C, LDC, + $ WORK, LDWORK ) 10 CONTINUE END IF WORK( 1 ) = LWKOPT diff --git a/lib/linalg/dormqr.f b/lib/linalg/dormqr.f index c0767ecf61..7f2ebb9ace 100644 --- a/lib/linalg/dormqr.f +++ b/lib/linalg/dormqr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORMQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORMQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -136,9 +136,7 @@ *> The dimension of the array WORK. *> If SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). -*> For optimum performance LWORK >= N*NB if SIDE = 'L', and -*> LWORK >= M*NB if SIDE = 'R', where NB is the optimal -*> blocksize. +*> For good performance, LWORK should generally be larger. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns @@ -156,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -169,10 +167,10 @@ SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -185,17 +183,15 @@ * ===================================================================== * * .. Parameters .. - INTEGER NBMAX, LDT - PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) + INTEGER NBMAX, LDT, TSIZE + PARAMETER ( NBMAX = 64, LDT = NBMAX+1, + $ TSIZE = LDT*NBMAX ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN - INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. -* .. Local Arrays .. - DOUBLE PRECISION T( LDT, NBMAX ) -* .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV @@ -245,12 +241,11 @@ * IF( INFO.EQ.0 ) THEN * -* Determine the block size. NB may be at most NBMAX, where NBMAX -* is used to define the local array T. +* Compute the workspace requirements * NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, $ -1 ) ) - LWKOPT = MAX( 1, NW )*NB + LWKOPT = MAX( 1, NW )*NB + TSIZE WORK( 1 ) = LWKOPT END IF * @@ -271,14 +266,11 @@ NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN - IWS = NW*NB - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK + IF( LWORK.LT.NW*NB+TSIZE ) THEN + NB = (LWORK-TSIZE) / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, $ -1 ) ) END IF - ELSE - IWS = NW END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN @@ -291,6 +283,7 @@ * * Use blocked code * + IWT = 1 + NW*NB IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 @@ -317,7 +310,7 @@ * H = H(i) H(i+1) . . . H(i+ib-1) * CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), - $ LDA, TAU( I ), T, LDT ) + $ LDA, TAU( I ), WORK( IWT ), LDT ) IF( LEFT ) THEN * * H or H**T is applied to C(i:m,1:n) @@ -335,8 +328,8 @@ * Apply H or H**T * CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, - $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, - $ WORK, LDWORK ) + $ IB, A( I, I ), LDA, WORK( IWT ), LDT, + $ C( IC, JC ), LDC, WORK, LDWORK ) 10 CONTINUE END IF WORK( 1 ) = LWKOPT diff --git a/lib/linalg/dormtr.f b/lib/linalg/dormtr.f index 00fff4dda2..d2443c1dac 100644 --- a/lib/linalg/dormtr.f +++ b/lib/linalg/dormtr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORMTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORMTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS, UPLO * INTEGER INFO, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -171,10 +171,10 @@ SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, UPLO diff --git a/lib/linalg/dpotf2.f b/lib/linalg/dpotf2.f index 6003e19b05..1fb60a903b 100644 --- a/lib/linalg/dpotf2.f +++ b/lib/linalg/dpotf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPOTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPOTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doublePOcomputational * * ===================================================================== SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lib/linalg/dpotrf.f b/lib/linalg/dpotrf.f index 3457230b56..1fa75a4654 100644 --- a/lib/linalg/dpotrf.f +++ b/lib/linalg/dpotrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPOTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPOTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -95,22 +95,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doublePOcomputational * * ===================================================================== SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -136,7 +136,7 @@ EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. - EXTERNAL DGEMM, DPOTF2, DSYRK, DTRSM, XERBLA + EXTERNAL DGEMM, DPOTRF2, DSYRK, DTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -171,7 +171,7 @@ * * Use unblocked code. * - CALL DPOTF2( UPLO, N, A, LDA, INFO ) + CALL DPOTRF2( UPLO, N, A, LDA, INFO ) ELSE * * Use blocked code. @@ -188,7 +188,7 @@ JB = MIN( NB, N-J+1 ) CALL DSYRK( 'Upper', 'Transpose', JB, J-1, -ONE, $ A( 1, J ), LDA, ONE, A( J, J ), LDA ) - CALL DPOTF2( 'Upper', JB, A( J, J ), LDA, INFO ) + CALL DPOTRF2( 'Upper', JB, A( J, J ), LDA, INFO ) IF( INFO.NE.0 ) $ GO TO 30 IF( J+JB.LE.N ) THEN @@ -216,7 +216,7 @@ JB = MIN( NB, N-J+1 ) CALL DSYRK( 'Lower', 'No transpose', JB, J-1, -ONE, $ A( J, 1 ), LDA, ONE, A( J, J ), LDA ) - CALL DPOTF2( 'Lower', JB, A( J, J ), LDA, INFO ) + CALL DPOTRF2( 'Lower', JB, A( J, J ), LDA, INFO ) IF( INFO.NE.0 ) $ GO TO 30 IF( J+JB.LE.N ) THEN diff --git a/lib/linalg/drot.f b/lib/linalg/drot.f index 1615ef6a87..0d33ea76c8 100644 --- a/lib/linalg/drot.f +++ b/lib/linalg/drot.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION C,S * INTEGER INCX,INCY,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION DX(*),DY(*) * .. -* +* * *> \par Purpose: * ============= @@ -27,15 +27,56 @@ *> DROT applies a plane rotation. *> \endverbatim * +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in,out] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +*> +*> \param[in,out] DY +*> \verbatim +*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of DY +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] S +*> \verbatim +*> S is DOUBLE PRECISION +*> \endverbatim +* * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * @@ -51,10 +92,10 @@ * ===================================================================== SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION C,S diff --git a/lib/linalg/drscl.f b/lib/linalg/drscl.f index 21ba19c11a..9251143680 100644 --- a/lib/linalg/drscl.f +++ b/lib/linalg/drscl.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DRSCL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DRSCL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DRSCL( N, SA, SX, INCX ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * DOUBLE PRECISION SA @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION SX( * ) * .. -* +* * *> \par Purpose: * ============= @@ -72,22 +72,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DRSCL( N, SA, SX, INCX ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lib/linalg/dscal.f b/lib/linalg/dscal.f index 3337de8e63..e0a92de6ba 100644 --- a/lib/linalg/dscal.f +++ b/lib/linalg/dscal.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSCAL(N,DA,DX,INCX) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION DA * INTEGER INCX,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION DX(*) * .. -* +* * *> \par Purpose: * ============= @@ -25,18 +25,44 @@ *> \verbatim *> *> DSCAL scales a vector by a constant. -*> uses unrolled loops for increment equal to one. +*> uses unrolled loops for increment equal to 1. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DA +*> \verbatim +*> DA is DOUBLE PRECISION +*> On entry, DA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in,out] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * @@ -53,10 +79,10 @@ * ===================================================================== SUBROUTINE DSCAL(N,DA,DX,INCX) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION DA diff --git a/lib/linalg/dstedc.f b/lib/linalg/dstedc.f index b59e1c3bbd..61b44bc06b 100644 --- a/lib/linalg/dstedc.f +++ b/lib/linalg/dstedc.f @@ -1,26 +1,26 @@ -*> \brief \b DSTEBZ +*> \brief \b DSTEDC * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSTEDC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSTEDC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, * LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, LIWORK, LWORK, N @@ -29,7 +29,7 @@ * INTEGER IWORK( * ) * DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,8 +105,7 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is DOUBLE PRECISION array, -*> dimension (LWORK) +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> @@ -169,12 +168,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2017 * *> \ingroup auxOTHERcomputational * @@ -189,10 +188,10 @@ SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* June 2017 * * .. Scalar Arguments .. CHARACTER COMPZ @@ -443,38 +442,32 @@ * * endwhile * -* If the problem split any number of times, then the eigenvalues -* will not be properly ordered. Here we permute the eigenvalues -* (and the associated eigenvectors) into ascending order. + IF( ICOMPZ.EQ.0 ) THEN * - IF( M.NE.N ) THEN - IF( ICOMPZ.EQ.0 ) THEN +* Use Quick Sort * -* Use Quick Sort + CALL DLASRT( 'I', N, D, INFO ) * - CALL DLASRT( 'I', N, D, INFO ) + ELSE * - ELSE +* Use Selection Sort to minimize swaps of eigenvectors * -* Use Selection Sort to minimize swaps of eigenvectors -* - DO 40 II = 2, N - I = II - 1 - K = I - P = D( I ) - DO 30 J = II, N - IF( D( J ).LT.P ) THEN - K = J - P = D( J ) - END IF - 30 CONTINUE - IF( K.NE.I ) THEN - D( K ) = D( I ) - D( I ) = P - CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) - END IF - 40 CONTINUE - END IF + DO 40 II = 2, N + I = II - 1 + K = I + P = D( I ) + DO 30 J = II, N + IF( D( J ).LT.P ) THEN + K = J + P = D( J ) + END IF + 30 CONTINUE + IF( K.NE.I ) THEN + D( K ) = D( I ) + D( I ) = P + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) + END IF + 40 CONTINUE END IF END IF * diff --git a/lib/linalg/dsteqr.f b/lib/linalg/dsteqr.f index 9e165bb6bb..c34a548984 100644 --- a/lib/linalg/dsteqr.f +++ b/lib/linalg/dsteqr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSTEQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSTEQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -119,22 +119,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPZ diff --git a/lib/linalg/dsterf.f b/lib/linalg/dsterf.f index b93cc13dd6..3401894819 100644 --- a/lib/linalg/dsterf.f +++ b/lib/linalg/dsterf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSTERF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSTERF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTERF( N, D, E, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -74,22 +74,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DSTERF( N, D, E, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N @@ -190,7 +190,7 @@ ANORM = DLANST( 'M', LEND-L+1, D( L ), E( L ) ) ISCALE = 0 IF( ANORM.EQ.ZERO ) - $ GO TO 10 + $ GO TO 10 IF( (ANORM.GT.SSFMAX) ) THEN ISCALE = 1 CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, diff --git a/lib/linalg/dswap.f b/lib/linalg/dswap.f index e567bd93ec..94dfea3bb9 100644 --- a/lib/linalg/dswap.f +++ b/lib/linalg/dswap.f @@ -2,40 +2,71 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * DOUBLE PRECISION DX(*),DY(*) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> interchanges two vectors. -*> uses unrolled loops for increments equal one. +*> DSWAP interchanges two vectors. +*> uses unrolled loops for increments equal to 1. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in,out] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +*> +*> \param[in,out] DY +*> \verbatim +*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of DY *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * @@ -51,10 +82,10 @@ * ===================================================================== SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N diff --git a/lib/linalg/dsyev.f b/lib/linalg/dsyev.f index 64b39ed847..ee8c479abe 100644 --- a/lib/linalg/dsyev.f +++ b/lib/linalg/dsyev.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDA, LWORK, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,22 +120,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleSYeigen * * ===================================================================== SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lib/linalg/dsyevd.f b/lib/linalg/dsyevd.f index 3c9545ac31..2db67846dc 100644 --- a/lib/linalg/dsyevd.f +++ b/lib/linalg/dsyevd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYEVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYEVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, * LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDA, LIWORK, LWORK, N @@ -29,7 +29,7 @@ * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -162,12 +162,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleSYeigen * @@ -185,10 +185,10 @@ SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lib/linalg/dsygs2.f b/lib/linalg/dsygs2.f index 644dcfff1b..a54955c01e 100644 --- a/lib/linalg/dsygs2.f +++ b/lib/linalg/dsygs2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYGS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYGS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, ITYPE, LDA, LDB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleSYcomputational * * ===================================================================== SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lib/linalg/dsygst.f b/lib/linalg/dsygst.f index f1d5311c9a..5055acdf1d 100644 --- a/lib/linalg/dsygst.f +++ b/lib/linalg/dsygst.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYGST + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYGST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, ITYPE, LDA, LDB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleSYcomputational * * ===================================================================== SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lib/linalg/dsygv.f b/lib/linalg/dsygv.f index e556318518..651abc5c7b 100644 --- a/lib/linalg/dsygv.f +++ b/lib/linalg/dsygv.f @@ -1,26 +1,26 @@ -*> \brief \b DSYGST +*> \brief \b DSYGV * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDA, LDB, LWORK, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -162,12 +162,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleSYeigen * @@ -175,10 +175,10 @@ SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lib/linalg/dsygvd.f b/lib/linalg/dsygvd.f index 171aa175ff..29c78283a7 100644 --- a/lib/linalg/dsygvd.f +++ b/lib/linalg/dsygvd.f @@ -1,26 +1,26 @@ -*> \brief \b DSYGST +*> \brief \b DSYGVD * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYGVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYGVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, * LWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDA, LDB, LIWORK, LWORK, N @@ -29,7 +29,7 @@ * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -198,12 +198,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleSYeigen * @@ -227,10 +227,10 @@ SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lib/linalg/dsymm.f b/lib/linalg/dsymm.f index ee8df4df4b..622d2469f1 100644 --- a/lib/linalg/dsymm.f +++ b/lib/linalg/dsymm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA,BETA * INTEGER LDA,LDB,LDC,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -87,7 +87,7 @@ *> *> \param[in] A *> \verbatim -*> A is DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is +*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is *> m when SIDE = 'L' or 'l' and is n otherwise. *> Before entry with SIDE = 'L' or 'l', the m by m part of *> the array A must contain the symmetric matrix, such that @@ -122,7 +122,7 @@ *> *> \param[in] B *> \verbatim -*> B is DOUBLE PRECISION array of DIMENSION ( LDB, n ). +*> B is DOUBLE PRECISION array, dimension ( LDB, N ) *> Before entry, the leading m by n part of the array B must *> contain the matrix B. *> \endverbatim @@ -144,7 +144,7 @@ *> *> \param[in,out] C *> \verbatim -*> C is DOUBLE PRECISION array of DIMENSION ( LDC, n ). +*> C is DOUBLE PRECISION array, dimension ( LDC, N ) *> Before entry, the leading m by n part of the array C must *> contain the matrix C, except when beta is zero, in which *> case C need not be set on entry. @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level3 * @@ -189,10 +189,10 @@ * ===================================================================== SUBROUTINE DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA,BETA diff --git a/lib/linalg/dsymv.f b/lib/linalg/dsymv.f index 5522023834..4bf973f10a 100644 --- a/lib/linalg/dsymv.f +++ b/lib/linalg/dsymv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA,BETA * INTEGER INCX,INCY,LDA,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -65,7 +65,7 @@ *> *> \param[in] A *> \verbatim -*> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ). +*> A is DOUBLE PRECISION array, dimension ( LDA, N ) *> Before entry with UPLO = 'U' or 'u', the leading n by n *> upper triangular part of the array A must contain the upper *> triangular part of the symmetric matrix and the strictly @@ -86,7 +86,7 @@ *> *> \param[in] X *> \verbatim -*> X is DOUBLE PRECISION array of dimension at least +*> X is DOUBLE PRECISION array, dimension at least *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element vector x. @@ -108,7 +108,7 @@ *> *> \param[in,out] Y *> \verbatim -*> Y is DOUBLE PRECISION array of dimension at least +*> Y is DOUBLE PRECISION array, dimension at least *> ( 1 + ( n - 1 )*abs( INCY ) ). *> Before entry, the incremented array Y must contain the n *> element vector y. On exit, Y is overwritten by the updated @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level2 * @@ -152,10 +152,10 @@ * ===================================================================== SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA,BETA diff --git a/lib/linalg/dsyr2.f b/lib/linalg/dsyr2.f index 05e148105c..8970c4dcfd 100644 --- a/lib/linalg/dsyr2.f +++ b/lib/linalg/dsyr2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA * INTEGER INCX,INCY,LDA,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -65,7 +65,7 @@ *> *> \param[in] X *> \verbatim -*> X is DOUBLE PRECISION array of dimension at least +*> X is DOUBLE PRECISION array, dimension at least *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element vector x. @@ -80,7 +80,7 @@ *> *> \param[in] Y *> \verbatim -*> Y is DOUBLE PRECISION array of dimension at least +*> Y is DOUBLE PRECISION array, dimension at least *> ( 1 + ( n - 1 )*abs( INCY ) ). *> Before entry, the incremented array Y must contain the n *> element vector y. @@ -95,7 +95,7 @@ *> *> \param[in,out] A *> \verbatim -*> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ). +*> A is DOUBLE PRECISION array, dimension ( LDA, N ) *> Before entry with UPLO = 'U' or 'u', the leading n by n *> upper triangular part of the array A must contain the upper *> triangular part of the symmetric matrix and the strictly @@ -121,12 +121,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level2 * @@ -147,10 +147,10 @@ * ===================================================================== SUBROUTINE DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA diff --git a/lib/linalg/dsyr2k.f b/lib/linalg/dsyr2k.f index 2dde293eae..f3a5940c7f 100644 --- a/lib/linalg/dsyr2k.f +++ b/lib/linalg/dsyr2k.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA,BETA * INTEGER K,LDA,LDB,LDC,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -95,7 +95,7 @@ *> *> \param[in] A *> \verbatim -*> A is DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is +*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is *> k when TRANS = 'N' or 'n', and is n otherwise. *> Before entry with TRANS = 'N' or 'n', the leading n by k *> part of the array A must contain the matrix A, otherwise @@ -114,7 +114,7 @@ *> *> \param[in] B *> \verbatim -*> B is DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is +*> B is DOUBLE PRECISION array, dimension ( LDB, kb ), where kb is *> k when TRANS = 'N' or 'n', and is n otherwise. *> Before entry with TRANS = 'N' or 'n', the leading n by k *> part of the array B must contain the matrix B, otherwise @@ -139,7 +139,7 @@ *> *> \param[in,out] C *> \verbatim -*> C is DOUBLE PRECISION array of DIMENSION ( LDC, n ). +*> C is DOUBLE PRECISION array, dimension ( LDC, N ) *> Before entry with UPLO = 'U' or 'u', the leading n by n *> upper triangular part of the array C must contain the upper *> triangular part of the symmetric matrix and the strictly @@ -165,12 +165,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level3 * @@ -192,10 +192,10 @@ * ===================================================================== SUBROUTINE DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA,BETA diff --git a/lib/linalg/dsyrk.f b/lib/linalg/dsyrk.f index d91c3369f6..4be4d8d3c4 100644 --- a/lib/linalg/dsyrk.f +++ b/lib/linalg/dsyrk.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA,BETA * INTEGER K,LDA,LDC,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -92,7 +92,7 @@ *> *> \param[in] A *> \verbatim -*> A is DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is +*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is *> k when TRANS = 'N' or 'n', and is n otherwise. *> Before entry with TRANS = 'N' or 'n', the leading n by k *> part of the array A must contain the matrix A, otherwise @@ -117,7 +117,7 @@ *> *> \param[in,out] C *> \verbatim -*> C is DOUBLE PRECISION array of DIMENSION ( LDC, n ). +*> C is DOUBLE PRECISION array, dimension ( LDC, N ) *> Before entry with UPLO = 'U' or 'u', the leading n by n *> upper triangular part of the array C must contain the upper *> triangular part of the symmetric matrix and the strictly @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level3 * @@ -169,10 +169,10 @@ * ===================================================================== SUBROUTINE DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA,BETA diff --git a/lib/linalg/dsytd2.f b/lib/linalg/dsytd2.f index a238f9ab3b..6fb4d5507e 100644 --- a/lib/linalg/dsytd2.f +++ b/lib/linalg/dsytd2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYTD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYTD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,12 +115,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleSYcomputational * @@ -173,10 +173,10 @@ * ===================================================================== SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lib/linalg/dsytrd.f b/lib/linalg/dsytrd.f index b268f4c1e4..d330b241fa 100644 --- a/lib/linalg/dsytrd.f +++ b/lib/linalg/dsytrd.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYTRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYTRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -134,12 +134,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleSYcomputational * @@ -192,10 +192,10 @@ * ===================================================================== SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lib/linalg/dtrmm.f b/lib/linalg/dtrmm.f index cbd5ce7034..0241c4d146 100644 --- a/lib/linalg/dtrmm.f +++ b/lib/linalg/dtrmm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA * INTEGER LDA,LDB,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),B(LDB,*) * .. -* +* * *> \par Purpose: * ============= @@ -109,7 +109,7 @@ *> *> \param[in] A *> \verbatim -*> A is DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m +*> A is DOUBLE PRECISION array, dimension ( LDA, k ), where k is m *> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. *> Before entry with UPLO = 'U' or 'u', the leading k by k *> upper triangular part of the array A must contain the upper @@ -134,7 +134,7 @@ *> *> \param[in,out] B *> \verbatim -*> B is DOUBLE PRECISION array of DIMENSION ( LDB, n ). +*> B is DOUBLE PRECISION array, dimension ( LDB, N ) *> Before entry, the leading m by n part of the array B must *> contain the matrix B, and on exit is overwritten by the *> transformed matrix. @@ -151,12 +151,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level3 * @@ -177,10 +177,10 @@ * ===================================================================== SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA diff --git a/lib/linalg/dtrmv.f b/lib/linalg/dtrmv.f index 71459fe7c8..11c12ac724 100644 --- a/lib/linalg/dtrmv.f +++ b/lib/linalg/dtrmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,LDA,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -80,7 +80,7 @@ *> *> \param[in] A *> \verbatim -*> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ). +*> A is DOUBLE PRECISION array, dimension ( LDA, N ) *> Before entry with UPLO = 'U' or 'u', the leading n by n *> upper triangular part of the array A must contain the upper *> triangular matrix and the strictly lower triangular part of @@ -103,11 +103,11 @@ *> *> \param[in,out] X *> \verbatim -*> X is DOUBLE PRECISION array of dimension at least +*> X is DOUBLE PRECISION array, dimension at least *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element vector x. On exit, X is overwritten with the -*> tranformed vector x. +*> transformed vector x. *> \endverbatim *> *> \param[in] INCX @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level2 * @@ -147,10 +147,10 @@ * ===================================================================== SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,LDA,N diff --git a/lib/linalg/dtrsm.f b/lib/linalg/dtrsm.f index 065df9a153..5a92bcafd0 100644 --- a/lib/linalg/dtrsm.f +++ b/lib/linalg/dtrsm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA * INTEGER LDA,LDB,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),B(LDB,*) * .. -* +* * *> \par Purpose: * ============= @@ -111,8 +111,8 @@ *> *> \param[in] A *> \verbatim -*> A is DOUBLE PRECISION array of DIMENSION ( LDA, k ), -*> where k is m when SIDE = 'L' or 'l' +*> A is DOUBLE PRECISION array, dimension ( LDA, k ), +*> where k is m when SIDE = 'L' or 'l' *> and k is n when SIDE = 'R' or 'r'. *> Before entry with UPLO = 'U' or 'u', the leading k by k *> upper triangular part of the array A must contain the upper @@ -137,7 +137,7 @@ *> *> \param[in,out] B *> \verbatim -*> B is DOUBLE PRECISION array of DIMENSION ( LDB, n ). +*> B is DOUBLE PRECISION array, dimension ( LDB, N ) *> Before entry, the leading m by n part of the array B must *> contain the right-hand side matrix B, and on exit is *> overwritten by the solution matrix X. @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level3 * @@ -181,10 +181,10 @@ * ===================================================================== SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA diff --git a/lib/linalg/dtrsv.f b/lib/linalg/dtrsv.f index e54303a93a..331f1d4311 100644 --- a/lib/linalg/dtrsv.f +++ b/lib/linalg/dtrsv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,LDA,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -83,7 +83,7 @@ *> *> \param[in] A *> \verbatim -*> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ). +*> A is DOUBLE PRECISION array, dimension ( LDA, N ) *> Before entry with UPLO = 'U' or 'u', the leading n by n *> upper triangular part of the array A must contain the upper *> triangular matrix and the strictly lower triangular part of @@ -106,7 +106,7 @@ *> *> \param[in,out] X *> \verbatim -*> X is DOUBLE PRECISION array of dimension at least +*> X is DOUBLE PRECISION array, dimension at least *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element right-hand side vector b. On exit, X is overwritten @@ -131,22 +131,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * * ===================================================================== SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,LDA,N diff --git a/lib/linalg/dtrti2.f b/lib/linalg/dtrti2.f index edf1b5b003..0a9d5b696c 100644 --- a/lib/linalg/dtrti2.f +++ b/lib/linalg/dtrti2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTRTI2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTRTI2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -98,22 +98,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lib/linalg/dtrtri.f b/lib/linalg/dtrtri.f index 5d27ca56af..d34b40bcc0 100644 --- a/lib/linalg/dtrtri.f +++ b/lib/linalg/dtrtri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTRTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTRTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lib/linalg/dznrm2.f b/lib/linalg/dznrm2.f index b5713a2bfa..e5a71d98f6 100644 --- a/lib/linalg/dznrm2.f +++ b/lib/linalg/dznrm2.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DZNRM2(N,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * .. * .. Array Arguments .. * COMPLEX*16 X(*) * .. -* +* * *> \par Purpose: * ============= @@ -29,15 +29,36 @@ *> DZNRM2 := sqrt( x**H*x ) *> \endverbatim * +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (N) +*> complex vector with N elements +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of X +*> \endverbatim +* * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * @@ -54,10 +75,10 @@ * ===================================================================== DOUBLE PRECISION FUNCTION DZNRM2(N,X,INCX) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lib/linalg/idamax.f b/lib/linalg/idamax.f index 4233fcc273..17041680a4 100644 --- a/lib/linalg/idamax.f +++ b/lib/linalg/idamax.f @@ -2,39 +2,59 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * INTEGER FUNCTION IDAMAX(N,DX,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * .. * .. Array Arguments .. * DOUBLE PRECISION DX(*) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> IDAMAX finds the index of element having max. absolute value. +*> IDAMAX finds the index of the first element having maximum absolute value. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of SX *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup aux_blas * @@ -51,10 +71,10 @@ * ===================================================================== INTEGER FUNCTION IDAMAX(N,DX,INCX) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lib/linalg/ieeeck.f b/lib/linalg/ieeeck.f index 132e436770..2655958b4a 100644 --- a/lib/linalg/ieeeck.f +++ b/lib/linalg/ieeeck.f @@ -2,29 +2,29 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download IEEECK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download IEEECK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) -* +* * .. Scalar Arguments .. * INTEGER ISPEC * REAL ONE, ZERO * .. -* +* * *> \par Purpose: * ============= @@ -70,22 +70,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER ISPEC diff --git a/lib/linalg/iladlc.f b/lib/linalg/iladlc.f index b56387d320..c6476113d1 100644 --- a/lib/linalg/iladlc.f +++ b/lib/linalg/iladlc.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ILADLC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ILADLC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILADLC( M, N, A, LDA ) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -66,22 +66,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILADLC( M, N, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER M, N, LDA diff --git a/lib/linalg/iladlr.f b/lib/linalg/iladlr.f index fe155af075..e8951d86cc 100644 --- a/lib/linalg/iladlr.f +++ b/lib/linalg/iladlr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ILADLR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ILADLR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILADLR( M, N, A, LDA ) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -66,22 +66,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILADLR( M, N, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER M, N, LDA diff --git a/lib/linalg/ilaenv.f b/lib/linalg/ilaenv.f index 867464de35..2be0581517 100644 --- a/lib/linalg/ilaenv.f +++ b/lib/linalg/ilaenv.f @@ -2,29 +2,29 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ILAENV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ILAENV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) -* +* * .. Scalar Arguments .. * CHARACTER*( * ) NAME, OPTS * INTEGER ISPEC, N1, N2, N3, N4 * .. -* +* * *> \par Purpose: * ============= @@ -82,7 +82,7 @@ *> =10: ieee NaN arithmetic can be trusted not to trap *> =11: infinity arithmetic can be trusted not to trap *> 12 <= ISPEC <= 16: -*> xHSEQR or one of its subroutines, +*> xHSEQR or related subroutines, *> see IPARMQ for detailed explanation *> \endverbatim *> @@ -127,14 +127,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -162,10 +162,10 @@ * ===================================================================== INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*( * ) NAME, OPTS @@ -183,13 +183,14 @@ INTRINSIC CHAR, ICHAR, INT, MIN, REAL * .. * .. External Functions .. - INTEGER IEEECK, IPARMQ - EXTERNAL IEEECK, IPARMQ + INTEGER IEEECK, IPARMQ, IPARAM2STAGE + EXTERNAL IEEECK, IPARMQ, IPARAM2STAGE * .. * .. Executable Statements .. * GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, - $ 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC + $ 130, 140, 150, 160, 160, 160, 160, 160, + $ 170, 170, 170, 170, 170 )ISPEC * * Invalid value for ISPEC * @@ -283,6 +284,52 @@ ELSE NB = 32 END IF + ELSE IF( C3.EQ.'QR ') THEN + IF( N3 .EQ. 1) THEN + IF( SNAME ) THEN +* M*N + IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN + NB = N1 + ELSE + NB = 32768/N2 + END IF + ELSE + IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN + NB = N1 + ELSE + NB = 32768/N2 + END IF + END IF + ELSE + IF( SNAME ) THEN + NB = 1 + ELSE + NB = 1 + END IF + END IF + ELSE IF( C3.EQ.'LQ ') THEN + IF( N3 .EQ. 2) THEN + IF( SNAME ) THEN +* M*N + IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN + NB = N1 + ELSE + NB = 32768/N2 + END IF + ELSE + IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN + NB = N1 + ELSE + NB = 32768/N2 + END IF + END IF + ELSE + IF( SNAME ) THEN + NB = 1 + ELSE + NB = 1 + END IF + END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NB = 32 @@ -397,6 +444,12 @@ ELSE NB = 64 END IF + ELSE IF ( C3.EQ.'EVC' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF END IF ELSE IF( C2.EQ.'LA' ) THEN IF( C3.EQ.'UUM' ) THEN @@ -410,6 +463,15 @@ IF( C3.EQ.'EBZ' ) THEN NB = 1 END IF + ELSE IF( C2.EQ.'GG' ) THEN + NB = 32 + IF( C3.EQ.'HD3' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + END IF END IF ILAENV = NB RETURN @@ -488,6 +550,11 @@ NBMIN = 2 END IF END IF + ELSE IF( C2.EQ.'GG' ) THEN + NBMIN = 2 + IF( C3.EQ.'HD3' ) THEN + NBMIN = 2 + END IF END IF ILAENV = NBMIN RETURN @@ -542,6 +609,11 @@ NX = 128 END IF END IF + ELSE IF( C2.EQ.'GG' ) THEN + NX = 128 + IF( C3.EQ.'HD3' ) THEN + NX = 128 + END IF END IF ILAENV = NX RETURN @@ -614,10 +686,17 @@ * 160 CONTINUE * -* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. +* 12 <= ISPEC <= 16: xHSEQR or related subroutines. * ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) RETURN +* + 170 CONTINUE +* +* 17 <= ISPEC <= 21: 2stage eigenvalues and SVD or related subroutines. +* + ILAENV = IPARAM2STAGE( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) + RETURN * * End of ILAENV * diff --git a/lib/linalg/ilazlc.f b/lib/linalg/ilazlc.f index 718b277dfa..07dfc93e31 100644 --- a/lib/linalg/ilazlc.f +++ b/lib/linalg/ilazlc.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ILAZLC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ILAZLC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILAZLC( M, N, A, LDA ) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -66,22 +66,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILAZLC( M, N, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER M, N, LDA diff --git a/lib/linalg/ilazlr.f b/lib/linalg/ilazlr.f index 44697214c7..4ca4ed1a44 100644 --- a/lib/linalg/ilazlr.f +++ b/lib/linalg/ilazlr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ILAZLR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ILAZLR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILAZLR( M, N, A, LDA ) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -66,22 +66,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILAZLR( M, N, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER M, N, LDA diff --git a/lib/linalg/iparam2stage.F b/lib/linalg/iparam2stage.F new file mode 100644 index 0000000000..60bd0b696b --- /dev/null +++ b/lib/linalg/iparam2stage.F @@ -0,0 +1,386 @@ +*> \brief \b IPARAM2STAGE +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download IPARAM2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION IPARAM2STAGE( ISPEC, NAME, OPTS, +* NI, NBI, IBI, NXI ) +* #if defined(_OPENMP) +* use omp_lib +* #endif +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER*( * ) NAME, OPTS +* INTEGER ISPEC, NI, NBI, IBI, NXI +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This program sets problem and machine dependent parameters +*> useful for xHETRD_2STAGE, xHETRD_H@2HB, xHETRD_HB2ST, +*> xGEBRD_2STAGE, xGEBRD_GE2GB, xGEBRD_GB2BD +*> and related subroutines for eigenvalue problems. +*> It is called whenever ILAENV is called with 17 <= ISPEC <= 21 +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ISPEC +*> \verbatim +*> ISPEC is integer scalar +*> ISPEC specifies which tunable parameter IPARAM2STAGE should +*> return. +*> +*> ISPEC=17: the optimal blocksize nb for the reduction to +* BAND +*> +*> ISPEC=18: the optimal blocksize ib for the eigenvectors +*> singular vectors update routine +*> +*> ISPEC=19: The length of the array that store the Housholder +*> representation for the second stage +*> Band to Tridiagonal or Bidiagonal +*> +*> ISPEC=20: The workspace needed for the routine in input. +*> +*> ISPEC=21: For future release. +*> \endverbatim +*> +*> \param[in] NAME +*> \verbatim +*> NAME is character string +*> Name of the calling subroutine +*> \endverbatim +*> +*> \param[in] OPTS +*> \verbatim +*> OPTS is CHARACTER*(*) +*> The character options to the subroutine NAME, concatenated +*> into a single character string. For example, UPLO = 'U', +*> TRANS = 'T', and DIAG = 'N' for a triangular routine would +*> be specified as OPTS = 'UTN'. +*> \endverbatim +*> +*> \param[in] NI +*> \verbatim +*> NI is INTEGER which is the size of the matrix +*> \endverbatim +*> +*> \param[in] NBI +*> \verbatim +*> NBI is INTEGER which is the used in the reduciton, +* (e.g., the size of the band), needed to compute workspace +* and LHOUS2. +*> \endverbatim +*> +*> \param[in] IBI +*> \verbatim +*> IBI is INTEGER which represent the IB of the reduciton, +* needed to compute workspace and LHOUS2. +*> \endverbatim +*> +*> \param[in] NXI +*> \verbatim +*> NXI is INTEGER needed in the future release. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup auxOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All detail are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION IPARAM2STAGE( ISPEC, NAME, OPTS, + $ NI, NBI, IBI, NXI ) +#if defined(_OPENMP) + use omp_lib +#endif + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER*( * ) NAME, OPTS + INTEGER ISPEC, NI, NBI, IBI, NXI +* +* ================================================================ +* .. +* .. Local Scalars .. + INTEGER I, IC, IZ, KD, IB, LHOUS, LWORK, NTHREADS, + $ FACTOPTNB, QROPTNB, LQOPTNB + LOGICAL RPREC, CPREC + CHARACTER PREC*1, ALGO*3, STAG*5, SUBNAM*12, VECT*1 +* .. +* .. Intrinsic Functions .. + INTRINSIC CHAR, ICHAR, MAX +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Invalid value for ISPEC +* + IF( (ISPEC.LT.17).OR.(ISPEC.GT.21) ) THEN + IPARAM2STAGE = -1 + RETURN + ENDIF +* +* Get the number of threads +* + NTHREADS = 1 +#if defined(_OPENMP) +!$OMP PARALLEL + NTHREADS = OMP_GET_NUM_THREADS() +!$OMP END PARALLEL +#endif +* WRITE(*,*) 'IPARAM VOICI NTHREADS ISPEC ',NTHREADS, ISPEC +* + IF( ISPEC .NE. 19 ) THEN +* +* Convert NAME to upper case if the first character is lower case. +* + IPARAM2STAGE = -1 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1: 1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 100 I = 2, 12 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 100 CONTINUE + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1: 1 ) = CHAR( IC+64 ) + DO 110 I = 2, 12 + IC = ICHAR( SUBNAM( I: I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: + $ I ) = CHAR( IC+64 ) + 110 CONTINUE + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 120 I = 2, 12 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 120 CONTINUE + END IF + END IF +* + PREC = SUBNAM( 1: 1 ) + ALGO = SUBNAM( 4: 6 ) + STAG = SUBNAM( 8:12 ) + RPREC = PREC.EQ.'S' .OR. PREC.EQ.'D' + CPREC = PREC.EQ.'C' .OR. PREC.EQ.'Z' +* +* Invalid value for PRECISION +* + IF( .NOT.( RPREC .OR. CPREC ) ) THEN + IPARAM2STAGE = -1 + RETURN + ENDIF + ENDIF +* WRITE(*,*),'RPREC,CPREC ',RPREC,CPREC, +* $ ' ALGO ',ALGO,' STAGE ',STAG +* +* + IF (( ISPEC .EQ. 17 ) .OR. ( ISPEC .EQ. 18 )) THEN +* +* ISPEC = 17, 18: block size KD, IB +* Could be also dependent from N but for now it +* depend only on sequential or parallel +* + IF( NTHREADS.GT.4 ) THEN + IF( CPREC ) THEN + KD = 128 + IB = 32 + ELSE + KD = 160 + IB = 40 + ENDIF + ELSE IF( NTHREADS.GT.1 ) THEN + IF( CPREC ) THEN + KD = 64 + IB = 32 + ELSE + KD = 64 + IB = 32 + ENDIF + ELSE + IF( CPREC ) THEN + KD = 16 + IB = 16 + ELSE + KD = 32 + IB = 16 + ENDIF + ENDIF + IF( ISPEC.EQ.17 ) IPARAM2STAGE = KD + IF( ISPEC.EQ.18 ) IPARAM2STAGE = IB +* + ELSE IF ( ISPEC .EQ. 19 ) THEN +* +* ISPEC = 19: +* LHOUS length of the Houselholder representation +* matrix (V,T) of the second stage. should be >= 1. +* +* Will add the VECT OPTION HERE next release + VECT = OPTS(1:1) + IF( VECT.EQ.'N' ) THEN + LHOUS = MAX( 1, 4*NI ) + ELSE +* This is not correct, it need to call the ALGO and the stage2 + LHOUS = MAX( 1, 4*NI ) + IBI + ENDIF + IF( LHOUS.GE.0 ) THEN + IPARAM2STAGE = LHOUS + ELSE + IPARAM2STAGE = -1 + ENDIF +* + ELSE IF ( ISPEC .EQ. 20 ) THEN +* +* ISPEC = 20: (21 for future use) +* LWORK length of the workspace for +* either or both stages for TRD and BRD. should be >= 1. +* TRD: +* TRD_stage 1: = LT + LW + LS1 + LS2 +* = LDT*KD + N*KD + N*MAX(KD,FACTOPTNB) + LDS2*KD +* where LDT=LDS2=KD +* = N*KD + N*max(KD,FACTOPTNB) + 2*KD*KD +* TRD_stage 2: = (2NB+1)*N + KD*NTHREADS +* TRD_both : = max(stage1,stage2) + AB ( AB=(KD+1)*N ) +* = N*KD + N*max(KD+1,FACTOPTNB) +* + max(2*KD*KD, KD*NTHREADS) +* + (KD+1)*N + LWORK = -1 + SUBNAM(1:1) = PREC + SUBNAM(2:6) = 'GEQRF' + QROPTNB = ILAENV( 1, SUBNAM, ' ', NI, NBI, -1, -1 ) + SUBNAM(2:6) = 'GELQF' + LQOPTNB = ILAENV( 1, SUBNAM, ' ', NBI, NI, -1, -1 ) +* Could be QR or LQ for TRD and the max for BRD + FACTOPTNB = MAX(QROPTNB, LQOPTNB) + IF( ALGO.EQ.'TRD' ) THEN + IF( STAG.EQ.'2STAG' ) THEN + LWORK = NI*NBI + NI*MAX(NBI+1,FACTOPTNB) + $ + MAX(2*NBI*NBI, NBI*NTHREADS) + $ + (NBI+1)*NI + ELSE IF( (STAG.EQ.'HE2HB').OR.(STAG.EQ.'SY2SB') ) THEN + LWORK = NI*NBI + NI*MAX(NBI,FACTOPTNB) + 2*NBI*NBI + ELSE IF( (STAG.EQ.'HB2ST').OR.(STAG.EQ.'SB2ST') ) THEN + LWORK = (2*NBI+1)*NI + NBI*NTHREADS + ENDIF + ELSE IF( ALGO.EQ.'BRD' ) THEN + IF( STAG.EQ.'2STAG' ) THEN + LWORK = 2*NI*NBI + NI*MAX(NBI+1,FACTOPTNB) + $ + MAX(2*NBI*NBI, NBI*NTHREADS) + $ + (NBI+1)*NI + ELSE IF( STAG.EQ.'GE2GB' ) THEN + LWORK = NI*NBI + NI*MAX(NBI,FACTOPTNB) + 2*NBI*NBI + ELSE IF( STAG.EQ.'GB2BD' ) THEN + LWORK = (3*NBI+1)*NI + NBI*NTHREADS + ENDIF + ENDIF + LWORK = MAX ( 1, LWORK ) + + IF( LWORK.GT.0 ) THEN + IPARAM2STAGE = LWORK + ELSE + IPARAM2STAGE = -1 + ENDIF +* + ELSE IF ( ISPEC .EQ. 21 ) THEN +* +* ISPEC = 21 for future use + IPARAM2STAGE = NXI + ENDIF +* +* ==== End of IPARAM2STAGE ==== +* + END diff --git a/lib/linalg/iparmq.f b/lib/linalg/iparmq.f index bd5bd7a0db..e576e0db01 100644 --- a/lib/linalg/iparmq.f +++ b/lib/linalg/iparmq.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download IPARMQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download IPARMQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, ISPEC, LWORK, N * CHARACTER NAME*( * ), OPTS*( * ) -* +* * *> \par Purpose: * ============= @@ -31,8 +31,9 @@ *> \verbatim *> *> This program sets problem and machine dependent parameters -*> useful for xHSEQR and its subroutines. It is called whenever -*> ILAENV is called with 12 <= ISPEC <= 16 +*> useful for xHSEQR and related subroutines for eigenvalue +*> problems. It is called whenever +*> IPARMQ is called with 12 <= ISPEC <= 16 *> \endverbatim * * Arguments: @@ -40,7 +41,7 @@ * *> \param[in] ISPEC *> \verbatim -*> ISPEC is integer scalar +*> ISPEC is INTEGER *> ISPEC specifies which tunable parameter IPARMQ should *> return. *> @@ -75,19 +76,26 @@ *> *> ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the *> following meanings. -*> 0: During the multi-shift QR sweep, -*> xLAQR5 does not accumulate reflections and -*> does not use matrix-matrix multiply to -*> update the far-from-diagonal matrix -*> entries. -*> 1: During the multi-shift QR sweep, -*> xLAQR5 and/or xLAQRaccumulates reflections and uses -*> matrix-matrix multiply to update the +*> 0: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are not +*> accumulated when updating the *> far-from-diagonal matrix entries. -*> 2: During the multi-shift QR sweep. -*> xLAQR5 accumulates reflections and takes -*> advantage of 2-by-2 block structure during -*> matrix-matrix multiplies. +*> 1: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are +*> accumulated, and matrix-matrix +*> multiplication is used to update the +*> far-from-diagonal matrix entries. +*> 2: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are +*> accumulated, and 2-by-2 block structure +*> is exploited during matrix-matrix +*> multiplies. *> (If xTRMM is slower than xGEMM, then *> IPARMQ(ISPEC=16)=1 may be more efficient than *> IPARMQ(ISPEC=16)=2 despite the greater level of @@ -109,7 +117,7 @@ *> *> \param[in] N *> \verbatim -*> N is integer scalar +*> N is INTEGER *> N is the order of the Hessenberg matrix H. *> \endverbatim *> @@ -127,21 +135,21 @@ *> *> \param[in] LWORK *> \verbatim -*> LWORK is integer scalar +*> LWORK is INTEGER *> The amount of workspace available. *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2017 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -214,10 +222,10 @@ * ===================================================================== INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* June 2017 * * .. Scalar Arguments .. INTEGER IHI, ILO, ISPEC, LWORK, N @@ -236,6 +244,8 @@ * .. * .. Local Scalars .. INTEGER NH, NS + INTEGER I, IC, IZ + CHARACTER SUBNAM*6 * .. * .. Intrinsic Functions .. INTRINSIC LOG, MAX, MOD, NINT, REAL @@ -304,12 +314,75 @@ * . doing it. A small amount of work could be saved * . by making this choice dependent also upon the * . NH=IHI-ILO+1. +* +* +* Convert NAME to upper case if the first character is lower case. * IPARMQ = 0 - IF( NS.GE.KACMIN ) - $ IPARMQ = 1 - IF( NS.GE.K22MIN ) - $ IPARMQ = 2 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1: 1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + END DO + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1: 1 ) = CHAR( IC+64 ) + DO I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: + $ I ) = CHAR( IC+64 ) + END DO + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + END DO + END IF + END IF +* + IF( SUBNAM( 2:6 ).EQ.'GGHRD' .OR. + $ SUBNAM( 2:6 ).EQ.'GGHD3' ) THEN + IPARMQ = 1 + IF( NH.GE.K22MIN ) + $ IPARMQ = 2 + ELSE IF ( SUBNAM( 4:6 ).EQ.'EXC' ) THEN + IF( NH.GE.KACMIN ) + $ IPARMQ = 1 + IF( NH.GE.K22MIN ) + $ IPARMQ = 2 + ELSE IF ( SUBNAM( 2:6 ).EQ.'HSEQR' .OR. + $ SUBNAM( 2:5 ).EQ.'LAQR' ) THEN + IF( NS.GE.KACMIN ) + $ IPARMQ = 1 + IF( NS.GE.K22MIN ) + $ IPARMQ = 2 + END IF * ELSE * ===== invalid value of ispec ===== diff --git a/lib/linalg/lsame.f b/lib/linalg/lsame.f index f19f9cda9e..d819478696 100644 --- a/lib/linalg/lsame.f +++ b/lib/linalg/lsame.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * LOGICAL FUNCTION LSAME(CA,CB) -* +* * .. Scalar Arguments .. * CHARACTER CA,CB * .. -* +* * *> \par Purpose: * ============= @@ -41,12 +41,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup aux_blas * @@ -56,7 +56,7 @@ * -- Reference BLAS level1 routine (version 3.1) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER CA,CB diff --git a/lib/linalg/xerbla.f b/lib/linalg/xerbla.f index 3e93bc4e0e..4a0350988c 100644 --- a/lib/linalg/xerbla.f +++ b/lib/linalg/xerbla.f @@ -2,29 +2,29 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download XERBLA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download XERBLA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE XERBLA( SRNAME, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER*(*) SRNAME * INTEGER INFO * .. -* +* * *> \par Purpose: * ============= @@ -58,22 +58,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE XERBLA( SRNAME, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*(*) SRNAME diff --git a/lib/linalg/zaxpy.f b/lib/linalg/zaxpy.f index e6f5e1f6db..b7b9ee69e4 100644 --- a/lib/linalg/zaxpy.f +++ b/lib/linalg/zaxpy.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZAXPY(N,ZA,ZX,INCX,ZY,INCY) -* +* * .. Scalar Arguments .. * COMPLEX*16 ZA * INTEGER INCX,INCY,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 ZX(*),ZY(*) * .. -* +* * *> \par Purpose: * ============= @@ -27,15 +27,52 @@ *> ZAXPY constant times a vector plus a vector. *> \endverbatim * +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZA +*> \verbatim +*> ZA is COMPLEX*16 +*> On entry, ZA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[in,out] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level1 * @@ -51,10 +88,10 @@ * ===================================================================== SUBROUTINE ZAXPY(N,ZA,ZX,INCX,ZY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ZA diff --git a/lib/linalg/zcopy.f b/lib/linalg/zcopy.f index baeafd5c3b..3777079730 100644 --- a/lib/linalg/zcopy.f +++ b/lib/linalg/zcopy.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZCOPY(N,ZX,INCX,ZY,INCY) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * COMPLEX*16 ZX(*),ZY(*) * .. -* +* * *> \par Purpose: * ============= @@ -26,15 +26,46 @@ *> ZCOPY copies a vector, x, to a vector, y. *> \endverbatim * +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[out] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level1 * @@ -50,10 +81,10 @@ * ===================================================================== SUBROUTINE ZCOPY(N,ZX,INCX,ZY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N diff --git a/lib/linalg/zdotc.f b/lib/linalg/zdotc.f index 660648bbe1..e6cd11b21d 100644 --- a/lib/linalg/zdotc.f +++ b/lib/linalg/zdotc.f @@ -2,39 +2,72 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * COMPLEX*16 FUNCTION ZDOTC(N,ZX,INCX,ZY,INCY) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * COMPLEX*16 ZX(*),ZY(*) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> ZDOTC forms the dot product of a vector. +*> ZDOTC forms the dot product of two complex vectors +*> ZDOTC = X^H * Y +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[in] ZY +*> \verbatim +*> ZY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level1 * @@ -50,10 +83,10 @@ * ===================================================================== COMPLEX*16 FUNCTION ZDOTC(N,ZX,INCX,ZY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N diff --git a/lib/linalg/zdscal.f b/lib/linalg/zdscal.f index 57a9490237..71d4da55be 100644 --- a/lib/linalg/zdscal.f +++ b/lib/linalg/zdscal.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZDSCAL(N,DA,ZX,INCX) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION DA * INTEGER INCX,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 ZX(*) * .. -* +* * *> \par Purpose: * ============= @@ -27,15 +27,41 @@ *> ZDSCAL scales a vector by a constant. *> \endverbatim * +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DA +*> \verbatim +*> DA is DOUBLE PRECISION +*> On entry, DA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in,out] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +* * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level1 * @@ -52,10 +78,10 @@ * ===================================================================== SUBROUTINE ZDSCAL(N,DA,ZX,INCX) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION DA diff --git a/lib/linalg/zgemm.f b/lib/linalg/zgemm.f index f423315508..c3ac7551d1 100644 --- a/lib/linalg/zgemm.f +++ b/lib/linalg/zgemm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA,BETA * INTEGER K,LDA,LDB,LDC,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -97,7 +97,7 @@ *> *> \param[in] A *> \verbatim -*> A is COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is +*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is *> k when TRANSA = 'N' or 'n', and is m otherwise. *> Before entry with TRANSA = 'N' or 'n', the leading m by k *> part of the array A must contain the matrix A, otherwise @@ -116,7 +116,7 @@ *> *> \param[in] B *> \verbatim -*> B is COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is +*> B is COMPLEX*16 array, dimension ( LDB, kb ), where kb is *> n when TRANSB = 'N' or 'n', and is k otherwise. *> Before entry with TRANSB = 'N' or 'n', the leading k by n *> part of the array B must contain the matrix B, otherwise @@ -142,7 +142,7 @@ *> *> \param[in,out] C *> \verbatim -*> C is COMPLEX*16 array of DIMENSION ( LDC, n ). +*> C is COMPLEX*16 array, dimension ( LDC, N ) *> Before entry, the leading m by n part of the array C must *> contain the matrix C, except when beta is zero, in which *> case C need not be set on entry. @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level3 * @@ -187,10 +187,10 @@ * ===================================================================== SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA,BETA @@ -317,12 +317,10 @@ 60 CONTINUE END IF DO 80 L = 1,K - IF (B(L,J).NE.ZERO) THEN - TEMP = ALPHA*B(L,J) - DO 70 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 70 CONTINUE - END IF + TEMP = ALPHA*B(L,J) + DO 70 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE 80 CONTINUE 90 CONTINUE ELSE IF (CONJA) THEN @@ -376,17 +374,15 @@ 170 CONTINUE END IF DO 190 L = 1,K - IF (B(J,L).NE.ZERO) THEN - TEMP = ALPHA*DCONJG(B(J,L)) - DO 180 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 180 CONTINUE - END IF + TEMP = ALPHA*DCONJG(B(J,L)) + DO 180 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 180 CONTINUE 190 CONTINUE 200 CONTINUE ELSE * -* Form C := alpha*A*B**T + beta*C +* Form C := alpha*A*B**T + beta*C * DO 250 J = 1,N IF (BETA.EQ.ZERO) THEN @@ -399,12 +395,10 @@ 220 CONTINUE END IF DO 240 L = 1,K - IF (B(J,L).NE.ZERO) THEN - TEMP = ALPHA*B(J,L) - DO 230 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 230 CONTINUE - END IF + TEMP = ALPHA*B(J,L) + DO 230 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 230 CONTINUE 240 CONTINUE 250 CONTINUE END IF diff --git a/lib/linalg/zgemv.f b/lib/linalg/zgemv.f index 4e174c956c..7088d383f4 100644 --- a/lib/linalg/zgemv.f +++ b/lib/linalg/zgemv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA,BETA * INTEGER INCX,INCY,LDA,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -73,7 +73,7 @@ *> *> \param[in] A *> \verbatim -*> A is COMPLEX*16 array of DIMENSION ( LDA, n ). +*> A is COMPLEX*16 array, dimension ( LDA, N ) *> Before entry, the leading m by n part of the array A must *> contain the matrix of coefficients. *> \endverbatim @@ -88,7 +88,7 @@ *> *> \param[in] X *> \verbatim -*> X is COMPLEX*16 array of DIMENSION at least +*> X is COMPLEX*16 array, dimension at least *> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' *> and at least *> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. @@ -112,7 +112,7 @@ *> *> \param[in,out] Y *> \verbatim -*> Y is COMPLEX*16 array of DIMENSION at least +*> Y is COMPLEX*16 array, dimension at least *> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' *> and at least *> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. @@ -131,12 +131,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -158,10 +158,10 @@ * ===================================================================== SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA,BETA @@ -285,24 +285,20 @@ JX = KX IF (INCY.EQ.1) THEN DO 60 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = ALPHA*X(JX) - DO 50 I = 1,M - Y(I) = Y(I) + TEMP*A(I,J) - 50 CONTINUE - END IF + TEMP = ALPHA*X(JX) + DO 50 I = 1,M + Y(I) = Y(I) + TEMP*A(I,J) + 50 CONTINUE JX = JX + INCX 60 CONTINUE ELSE DO 80 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = ALPHA*X(JX) - IY = KY - DO 70 I = 1,M - Y(IY) = Y(IY) + TEMP*A(I,J) - IY = IY + INCY - 70 CONTINUE - END IF + TEMP = ALPHA*X(JX) + IY = KY + DO 70 I = 1,M + Y(IY) = Y(IY) + TEMP*A(I,J) + IY = IY + INCY + 70 CONTINUE JX = JX + INCX 80 CONTINUE END IF diff --git a/lib/linalg/zgerc.f b/lib/linalg/zgerc.f index accfeafc05..058dccfc1c 100644 --- a/lib/linalg/zgerc.f +++ b/lib/linalg/zgerc.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA * INTEGER INCX,INCY,LDA,M,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -57,7 +57,7 @@ *> *> \param[in] X *> \verbatim -*> X is COMPLEX*16 array of dimension at least +*> X is COMPLEX*16 array, dimension at least *> ( 1 + ( m - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the m *> element vector x. @@ -72,7 +72,7 @@ *> *> \param[in] Y *> \verbatim -*> Y is COMPLEX*16 array of dimension at least +*> Y is COMPLEX*16 array, dimension at least *> ( 1 + ( n - 1 )*abs( INCY ) ). *> Before entry, the incremented array Y must contain the n *> element vector y. @@ -87,7 +87,7 @@ *> *> \param[in,out] A *> \verbatim -*> A is COMPLEX*16 array of DIMENSION ( LDA, n ). +*> A is COMPLEX*16 array, dimension ( LDA, N ) *> Before entry, the leading m by n part of the array A must *> contain the matrix of coefficients. On exit, A is *> overwritten by the updated matrix. @@ -104,12 +104,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -130,10 +130,10 @@ * ===================================================================== SUBROUTINE ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA diff --git a/lib/linalg/zheev.f b/lib/linalg/zheev.f index adba990f0a..3e87778740 100644 --- a/lib/linalg/zheev.f +++ b/lib/linalg/zheev.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHEEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHEEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDA, LWORK, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION RWORK( * ), W( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16HEeigen * @@ -140,10 +140,10 @@ SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lib/linalg/zhemv.f b/lib/linalg/zhemv.f index 34216fbfff..3ea0753f40 100644 --- a/lib/linalg/zhemv.f +++ b/lib/linalg/zhemv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA,BETA * INTEGER INCX,INCY,LDA,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -65,7 +65,7 @@ *> *> \param[in] A *> \verbatim -*> A is COMPLEX*16 array of DIMENSION ( LDA, n ). +*> A is COMPLEX*16 array, dimension ( LDA, N ) *> Before entry with UPLO = 'U' or 'u', the leading n by n *> upper triangular part of the array A must contain the upper *> triangular part of the hermitian matrix and the strictly @@ -88,7 +88,7 @@ *> *> \param[in] X *> \verbatim -*> X is COMPLEX*16 array of dimension at least +*> X is COMPLEX*16 array, dimension at least *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element vector x. @@ -110,7 +110,7 @@ *> *> \param[in,out] Y *> \verbatim -*> Y is COMPLEX*16 array of dimension at least +*> Y is COMPLEX*16 array, dimension at least *> ( 1 + ( n - 1 )*abs( INCY ) ). *> Before entry, the incremented array Y must contain the n *> element vector y. On exit, Y is overwritten by the updated @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -154,10 +154,10 @@ * ===================================================================== SUBROUTINE ZHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA,BETA diff --git a/lib/linalg/zher2.f b/lib/linalg/zher2.f index e2a02c3c68..e3a383189d 100644 --- a/lib/linalg/zher2.f +++ b/lib/linalg/zher2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA * INTEGER INCX,INCY,LDA,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -65,7 +65,7 @@ *> *> \param[in] X *> \verbatim -*> X is COMPLEX*16 array of dimension at least +*> X is COMPLEX*16 array, dimension at least *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element vector x. @@ -80,7 +80,7 @@ *> *> \param[in] Y *> \verbatim -*> Y is COMPLEX*16 array of dimension at least +*> Y is COMPLEX*16 array, dimension at least *> ( 1 + ( n - 1 )*abs( INCY ) ). *> Before entry, the incremented array Y must contain the n *> element vector y. @@ -95,7 +95,7 @@ *> *> \param[in,out] A *> \verbatim -*> A is COMPLEX*16 array of DIMENSION ( LDA, n ). +*> A is COMPLEX*16 array, dimension ( LDA, N ) *> Before entry with UPLO = 'U' or 'u', the leading n by n *> upper triangular part of the array A must contain the upper *> triangular part of the hermitian matrix and the strictly @@ -124,12 +124,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -150,10 +150,10 @@ * ===================================================================== SUBROUTINE ZHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA diff --git a/lib/linalg/zher2k.f b/lib/linalg/zher2k.f index 0b91bd2cbb..474c65e575 100644 --- a/lib/linalg/zher2k.f +++ b/lib/linalg/zher2k.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA * DOUBLE PRECISION BETA @@ -19,7 +19,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -95,7 +95,7 @@ *> *> \param[in] A *> \verbatim -*> A is COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is +*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is *> k when TRANS = 'N' or 'n', and is n otherwise. *> Before entry with TRANS = 'N' or 'n', the leading n by k *> part of the array A must contain the matrix A, otherwise @@ -114,7 +114,7 @@ *> *> \param[in] B *> \verbatim -*> B is COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is +*> B is COMPLEX*16 array, dimension ( LDB, kb ), where kb is *> k when TRANS = 'N' or 'n', and is n otherwise. *> Before entry with TRANS = 'N' or 'n', the leading n by k *> part of the array B must contain the matrix B, otherwise @@ -140,7 +140,7 @@ *> *> \param[in,out] C *> \verbatim -*> C is COMPLEX*16 array of DIMENSION ( LDC, n ). +*> C is COMPLEX*16 array, dimension ( LDC, N ) *> Before entry with UPLO = 'U' or 'u', the leading n by n *> upper triangular part of the array C must contain the upper *> triangular part of the hermitian matrix and the strictly @@ -169,12 +169,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level3 * @@ -198,10 +198,10 @@ * ===================================================================== SUBROUTINE ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA diff --git a/lib/linalg/zhetd2.f b/lib/linalg/zhetd2.f index dd8f9cf014..6c5b8aae3d 100644 --- a/lib/linalg/zhetd2.f +++ b/lib/linalg/zhetd2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHETD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHETD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * DOUBLE PRECISION D( * ), E( * ) * COMPLEX*16 A( LDA, * ), TAU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16HEcomputational * @@ -175,10 +175,10 @@ * ===================================================================== SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lib/linalg/zhetrd.f b/lib/linalg/zhetrd.f index c607484637..51c9fc2ec9 100644 --- a/lib/linalg/zhetrd.f +++ b/lib/linalg/zhetrd.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHETRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHETRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * DOUBLE PRECISION D( * ), E( * ) * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -134,12 +134,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16HEcomputational * @@ -192,10 +192,10 @@ * ===================================================================== SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lib/linalg/zhpr.f b/lib/linalg/zhpr.f index 42e61196ba..af82dfbd8c 100644 --- a/lib/linalg/zhpr.f +++ b/lib/linalg/zhpr.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZHPR(UPLO,N,ALPHA,X,INCX,AP) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA * INTEGER INCX,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 AP(*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -65,7 +65,7 @@ *> *> \param[in] X *> \verbatim -*> X is COMPLEX*16 array of dimension at least +*> X is COMPLEX*16 array, dimension at least *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element vector x. @@ -80,7 +80,7 @@ *> *> \param[in,out] AP *> \verbatim -*> AP is COMPLEX*16 array of DIMENSION at least +*> AP is COMPLEX*16 array, dimension at least *> ( ( n*( n + 1 ) )/2 ). *> Before entry with UPLO = 'U' or 'u', the array AP must *> contain the upper triangular part of the hermitian matrix @@ -104,12 +104,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -130,10 +130,10 @@ * ===================================================================== SUBROUTINE ZHPR(UPLO,N,ALPHA,X,INCX,AP) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA diff --git a/lib/linalg/zlacgv.f b/lib/linalg/zlacgv.f index 315c4de5ce..1e3ca6e73f 100644 --- a/lib/linalg/zlacgv.f +++ b/lib/linalg/zlacgv.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLACGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLACGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLACGV( N, X, INCX ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * .. * .. Array Arguments .. * COMPLEX*16 X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -62,22 +62,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLACGV( N, X, INCX ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lib/linalg/zladiv.f b/lib/linalg/zladiv.f index 8f01fe3e63..0bf6ea87d5 100644 --- a/lib/linalg/zladiv.f +++ b/lib/linalg/zladiv.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLADIV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLADIV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * COMPLEX*16 FUNCTION ZLADIV( X, Y ) -* +* * .. Scalar Arguments .. * COMPLEX*16 X, Y * .. -* +* * *> \par Purpose: * ============= @@ -52,22 +52,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== COMPLEX*16 FUNCTION ZLADIV( X, Y ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 X, Y diff --git a/lib/linalg/zlanhe.f b/lib/linalg/zlanhe.f index 3093a151af..7c7f7f3be4 100644 --- a/lib/linalg/zlanhe.f +++ b/lib/linalg/zlanhe.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLANHE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLANHE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER LDA, N @@ -28,7 +28,7 @@ * DOUBLE PRECISION WORK( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,22 +112,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16HEauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO diff --git a/lib/linalg/zlarf.f b/lib/linalg/zlarf.f index f51e1d7383..f1be80d37b 100644 --- a/lib/linalg/zlarf.f +++ b/lib/linalg/zlarf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLARF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLARF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE diff --git a/lib/linalg/zlarfb.f b/lib/linalg/zlarfb.f index 99490f5827..b4a2b4d1a0 100644 --- a/lib/linalg/zlarfb.f +++ b/lib/linalg/zlarfb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLARFB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLARFB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \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 @@ -29,7 +29,7 @@ * COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2013 * *> \ingroup complex16OTHERauxiliary * @@ -195,10 +195,10 @@ SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2013 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS @@ -217,12 +217,11 @@ * .. * .. Local Scalars .. CHARACTER TRANST - INTEGER I, J, LASTV, LASTC + INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAZLR, ILAZLC - EXTERNAL LSAME, ILAZLR, ILAZLC + EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM @@ -255,36 +254,33 @@ * * 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 ) + CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL ZLACGV( N, 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 + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN * -* W := W + C2**H *V2 +* 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 ) + CALL ZGEMM( 'Conjugate transpose', 'No transpose', N, + $ K, M-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 ) + CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**H * @@ -293,20 +289,19 @@ * 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 ) + $ M-K, N, 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 ) + $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**H * DO 30 J = 1, K - DO 20 I = 1, LASTC + DO 20 I = 1, N C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) 20 CONTINUE 30 CONTINUE @@ -314,58 +309,53 @@ 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 ) + CALL ZCOPY( M, 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 + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( N.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 ) + CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-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 ) + CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**H * - IF( LASTV.GT.K ) THEN + IF( N.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 ) + CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, + $ N-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 ) + $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 60 J = 1, K - DO 50 I = 1, LASTC + DO 50 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 50 CONTINUE 60 CONTINUE @@ -381,38 +371,33 @@ * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) -* - LASTC = ILAZLC( M, 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( M-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) - CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) + CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL ZLACGV( N, WORK( 1, J ), 1 ) 70 CONTINUE * * W := W * V2 * - CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( M-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * -* W := W + C1**H*V1 +* W := W + C1**H * V1 * - CALL ZGEMM( 'Conjugate transpose', 'No transpose', - $ LASTC, K, M-K, - $ ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL ZGEMM( 'Conjugate transpose', 'No transpose', N, + $ K, M-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 ) + CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**H * @@ -421,21 +406,20 @@ * C1 := C1 - V1 * W**H * CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ M-K, LASTC, K, - $ -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) + $ M-K, N, 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( M-K+1, 1 ), LDV, - $ WORK, LDWORK ) + $ 'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK, + $ LDWORK ) * * C2 := C2 - W**H * DO 90 J = 1, K - DO 80 I = 1, LASTC + DO 80 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - $ DCONJG( WORK( I, J ) ) 80 CONTINUE @@ -444,36 +428,31 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) -* - LASTC = ILAZLR( M, N, C, LDC ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C2 * DO 100 J = 1, K - CALL ZCOPY( LASTC, C( 1, N-K+J ), 1, - $ WORK( 1, J ), 1 ) + CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 100 CONTINUE * * W := W * V2 * - CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( N-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1 * - CALL ZGEMM( 'No transpose', 'No transpose', - $ LASTC, K, N-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-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 ) + CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**H * @@ -481,23 +460,22 @@ * * C1 := C1 - W * V1**H * - CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) + CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, + $ N-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( N-K+1, 1 ), LDV, - $ WORK, LDWORK ) + $ 'Unit', M, K, ONE, V( N-K+1, 1 ), LDV, WORK, + $ LDWORK ) * * C2 := C2 - W * DO 120 J = 1, K - DO 110 I = 1, LASTC - C( I, N-K+J ) = C( I, N-K+J ) - $ - WORK( I, J ) + DO 110 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 110 CONTINUE 120 CONTINUE END IF @@ -514,59 +492,56 @@ * * 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 ) + CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL ZLACGV( N, 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 + $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN * -* W := W + C2**H*V2**H +* 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 ) + $ 'Conjugate transpose', N, K, M-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 ) + CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**H * W**H * - IF( LASTV.GT.K ) THEN + IF( M.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 ) + $ 'Conjugate transpose', M-K, N, 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 ) + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**H * DO 150 J = 1, K - DO 140 I = 1, LASTC + DO 140 I = 1, N C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) 140 CONTINUE 150 CONTINUE @@ -574,57 +549,53 @@ 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 ) + CALL ZCOPY( M, 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 + $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) + IF( N.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 ) + CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, + $ K, N-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 ) + CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * - IF( LASTV.GT.K ) THEN + IF( N.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 ) + CALL ZGEMM( 'No transpose', 'No transpose', M, N-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 ) + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 180 J = 1, K - DO 170 I = 1, LASTC + DO 170 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 170 CONTINUE 180 CONTINUE @@ -640,37 +611,34 @@ * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) -* - LASTC = ILAZLC( M, 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( M-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) - CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) + CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL ZLACGV( N, WORK( 1, J ), 1 ) 190 CONTINUE * * W := W * V2**H * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V( 1, M-K+1 ), LDV, - $ WORK, LDWORK ) + $ 'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK, + $ LDWORK ) IF( M.GT.K ) THEN * * W := W + C1**H * V1**H * CALL ZGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', LASTC, K, M-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + $ 'Conjugate transpose', N, K, M-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 ) + CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**H * W**H * @@ -679,20 +647,19 @@ * C1 := C1 - V1**H * W**H * CALL ZGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', M-K, LASTC, K, - $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) + $ 'Conjugate transpose', M-K, N, 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, M-K+1 ), LDV, - $ WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**H * DO 210 J = 1, K - DO 200 I = 1, LASTC + DO 200 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - $ DCONJG( WORK( I, J ) ) 200 CONTINUE @@ -701,36 +668,33 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) -* - LASTC = ILAZLR( M, N, 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, N-K+J ), 1, - $ WORK( 1, J ), 1 ) + CALL ZCOPY( M, C( 1, N-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, N-K+1 ), LDV, - $ WORK, LDWORK ) + $ 'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK, + $ LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1**H * - CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ LASTC, K, N-K, ONE, C, LDC, V, LDV, ONE, - $ WORK, LDWORK ) + CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, + $ K, N-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 ) + CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * @@ -738,21 +702,19 @@ * * C1 := C1 - W * V1 * - CALL ZGEMM( 'No transpose', 'No transpose', - $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) + CALL ZGEMM( 'No transpose', 'No transpose', M, N-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, N-K+1 ), LDV, - $ WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 240 J = 1, K - DO 230 I = 1, LASTC + DO 230 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 230 CONTINUE 240 CONTINUE diff --git a/lib/linalg/zlarfg.f b/lib/linalg/zlarfg.f index e37c683fc9..f8a795d547 100644 --- a/lib/linalg/zlarfg.f +++ b/lib/linalg/zlarfg.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLARFG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLARFG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * COMPLEX*16 ALPHA, TAU @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lib/linalg/zlarft.f b/lib/linalg/zlarft.f index 2278d11d2b..78ad2f1481 100644 --- a/lib/linalg/zlarft.f +++ b/lib/linalg/zlarft.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLARFT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLARFT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, STOREV * INTEGER K, LDT, LDV, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complex16OTHERauxiliary * @@ -163,10 +163,10 @@ * ===================================================================== SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV @@ -187,7 +187,7 @@ INTEGER I, J, PREVLASTV, LASTV * .. * .. External Subroutines .. - EXTERNAL ZGEMV, ZLACGV, ZTRMV + EXTERNAL ZGEMV, ZTRMV, ZGEMM * .. * .. External Functions .. LOGICAL LSAME @@ -222,13 +222,13 @@ END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * CONJG( V( I , J ) ) - END DO + 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, + $ -TAU( I ), V( I+1, 1 ), LDV, $ V( I+1, I ), 1, ONE, T( 1, I ), 1 ) ELSE * Skip any trailing zeros. @@ -237,14 +237,14 @@ END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * V( J , I ) - END DO + 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 ) + $ ONE, T( 1, I ), LDT ) END IF * * T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) @@ -281,7 +281,7 @@ END DO DO J = I+1, K T( J, I ) = -TAU( I ) * CONJG( V( N-K+I , J ) ) - END DO + 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) @@ -296,14 +296,14 @@ END DO DO J = I+1, K T( J, I ) = -TAU( I ) * V( J, N-K+I ) - END DO + 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 ) + $ 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) diff --git a/lib/linalg/zlascl.f b/lib/linalg/zlascl.f index 51a4f0f614..c53c6f5ad7 100644 --- a/lib/linalg/zlascl.f +++ b/lib/linalg/zlascl.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLASCL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLASCL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TYPE * INTEGER INFO, KL, KU, LDA, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,7 +114,11 @@ *> \param[in] LDA *> \verbatim *> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). +*> The leading dimension of the array A. +*> If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M); +*> TYPE = 'B', LDA >= KL+1; +*> TYPE = 'Q', LDA >= KU+1; +*> TYPE = 'Z', LDA >= 2*KL+KU+1. *> \endverbatim *> *> \param[out] INFO @@ -127,22 +131,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER TYPE diff --git a/lib/linalg/zlaset.f b/lib/linalg/zlaset.f index 11f82361b7..796678217b 100644 --- a/lib/linalg/zlaset.f +++ b/lib/linalg/zlaset.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLASET + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLASET + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -77,7 +77,7 @@ *> All the diagonal array elements are set to BETA. *> \endverbatim *> -*> \param[in,out] A +*> \param[out] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) *> On entry, the m by n matrix A. @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lib/linalg/zlasr.f b/lib/linalg/zlasr.f index 5243d8304a..69891ba522 100644 --- a/lib/linalg/zlasr.f +++ b/lib/linalg/zlasr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLASR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLASR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, PIVOT, SIDE * INTEGER LDA, M, N @@ -28,7 +28,7 @@ * DOUBLE PRECISION C( * ), S( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -49,23 +49,23 @@ *> where P is an orthogonal matrix consisting of a sequence of z plane *> rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', *> and P**T is the transpose of P. -*> +*> *> When DIRECT = 'F' (Forward sequence), then -*> +*> *> P = P(z-1) * ... * P(2) * P(1) -*> +*> *> and when DIRECT = 'B' (Backward sequence), then -*> +*> *> P = P(1) * P(2) * ... * P(z-1) -*> +*> *> where P(k) is a plane rotation matrix defined by the 2-by-2 rotation -*> +*> *> R(k) = ( c(k) s(k) ) *> = ( -s(k) c(k) ). -*> +*> *> When PIVOT = 'V' (Variable pivot), the rotation is performed *> for the plane (k,k+1), i.e., P(k) has the form -*> +*> *> P(k) = ( 1 ) *> ( ... ) *> ( 1 ) @@ -74,13 +74,13 @@ *> ( 1 ) *> ( ... ) *> ( 1 ) -*> +*> *> where R(k) appears as a rank-2 modification to the identity matrix in *> rows and columns k and k+1. -*> +*> *> When PIVOT = 'T' (Top pivot), the rotation is performed for the *> plane (1,k+1), so P(k) has the form -*> +*> *> P(k) = ( c(k) s(k) ) *> ( 1 ) *> ( ... ) @@ -89,12 +89,12 @@ *> ( 1 ) *> ( ... ) *> ( 1 ) -*> +*> *> where R(k) appears in rows and columns 1 and k+1. -*> +*> *> Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is *> performed for the plane (k,z), giving P(k) the form -*> +*> *> P(k) = ( 1 ) *> ( ... ) *> ( 1 ) @@ -103,7 +103,7 @@ *> ( ... ) *> ( 1 ) *> ( -s(k) c(k) ) -*> +*> *> where R(k) appears in rows and columns k and z. The rotations are *> performed without ever forming P(k) explicitly. *> \endverbatim @@ -188,22 +188,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE diff --git a/lib/linalg/zlassq.f b/lib/linalg/zlassq.f index 5b7e66c30b..fd13811bd9 100644 --- a/lib/linalg/zlassq.f +++ b/lib/linalg/zlassq.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLASSQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLASSQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * DOUBLE PRECISION SCALE, SUMSQ @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lib/linalg/zlatrd.f b/lib/linalg/zlatrd.f index 619d7280c4..ccc040993f 100644 --- a/lib/linalg/zlatrd.f +++ b/lib/linalg/zlatrd.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLATRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLATRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDW, N, NB @@ -28,7 +28,7 @@ * DOUBLE PRECISION E( * ) * COMPLEX*16 A( LDA, * ), TAU( * ), W( LDW, * ) * .. -* +* * *> \par Purpose: * ============= @@ -135,12 +135,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -199,10 +199,10 @@ * ===================================================================== SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lib/linalg/zpptrf.f b/lib/linalg/zpptrf.f index c34aff332a..6e50b46828 100644 --- a/lib/linalg/zpptrf.f +++ b/lib/linalg/zpptrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPPTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPPTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPPTRF( UPLO, N, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -87,12 +87,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -119,10 +119,10 @@ * ===================================================================== SUBROUTINE ZPPTRF( UPLO, N, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lib/linalg/zpptri.f b/lib/linalg/zpptri.f index 0946797450..cde2f6dc72 100644 --- a/lib/linalg/zpptri.f +++ b/lib/linalg/zpptri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPPTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPPTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPPTRI( UPLO, N, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -81,22 +81,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZPPTRI( UPLO, N, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lib/linalg/zscal.f b/lib/linalg/zscal.f index ad28a10a9b..9f6d4b1d39 100644 --- a/lib/linalg/zscal.f +++ b/lib/linalg/zscal.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZSCAL(N,ZA,ZX,INCX) -* +* * .. Scalar Arguments .. * COMPLEX*16 ZA * INTEGER INCX,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 ZX(*) * .. -* +* * *> \par Purpose: * ============= @@ -27,15 +27,41 @@ *> ZSCAL scales a vector by a constant. *> \endverbatim * +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZA +*> \verbatim +*> ZA is COMPLEX*16 +*> On entry, ZA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in,out] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +* * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level1 * @@ -52,10 +78,10 @@ * ===================================================================== SUBROUTINE ZSCAL(N,ZA,ZX,INCX) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ZA diff --git a/lib/linalg/zsteqr.f b/lib/linalg/zsteqr.f index 33af78e854..ac47890685 100644 --- a/lib/linalg/zsteqr.f +++ b/lib/linalg/zsteqr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSTEQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSTEQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, N @@ -28,7 +28,7 @@ * DOUBLE PRECISION D( * ), E( * ), WORK( * ) * COMPLEX*16 Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,22 +120,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPZ diff --git a/lib/linalg/zswap.f b/lib/linalg/zswap.f index ca2f347211..6768d5e6e0 100644 --- a/lib/linalg/zswap.f +++ b/lib/linalg/zswap.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * COMPLEX*16 ZX(*),ZY(*) * .. -* +* * *> \par Purpose: * ============= @@ -26,15 +26,46 @@ *> ZSWAP interchanges two vectors. *> \endverbatim * +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in,out] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[in,out] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level1 * @@ -50,10 +81,10 @@ * ===================================================================== SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N diff --git a/lib/linalg/ztpmv.f b/lib/linalg/ztpmv.f index e277ec1a6e..65aa2a0abc 100644 --- a/lib/linalg/ztpmv.f +++ b/lib/linalg/ztpmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 AP(*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -80,7 +80,7 @@ *> *> \param[in] AP *> \verbatim -*> AP is COMPLEX*16 array of DIMENSION at least +*> AP is COMPLEX*16 array, dimension at least *> ( ( n*( n + 1 ) )/2 ). *> Before entry with UPLO = 'U' or 'u', the array AP must *> contain the upper triangular matrix packed sequentially, @@ -96,13 +96,13 @@ *> A are not referenced, but are assumed to be unity. *> \endverbatim *> -*> \param[in] X +*> \param[in,out] X *> \verbatim -*> X is (input/output) COMPLEX*16 array of dimension at least +*> X is COMPLEX*16 array, dimension at least *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element vector x. On exit, X is overwritten with the -*> tranformed vector x. +*> transformed vector x. *> \endverbatim *> *> \param[in] INCX @@ -115,12 +115,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -142,10 +142,10 @@ * ===================================================================== SUBROUTINE ZTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lib/linalg/ztpsv.f b/lib/linalg/ztpsv.f index 0e75f9facf..538888424a 100644 --- a/lib/linalg/ztpsv.f +++ b/lib/linalg/ztpsv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 AP(*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -83,7 +83,7 @@ *> *> \param[in] AP *> \verbatim -*> AP is COMPLEX*16 array of DIMENSION at least +*> AP is COMPLEX*16 array, dimension at least *> ( ( n*( n + 1 ) )/2 ). *> Before entry with UPLO = 'U' or 'u', the array AP must *> contain the upper triangular matrix packed sequentially, @@ -101,7 +101,7 @@ *> *> \param[in,out] X *> \verbatim -*> X is COMPLEX*16 array of dimension at least +*> X is COMPLEX*16 array, dimension at least *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element right-hand side vector b. On exit, X is overwritten @@ -118,12 +118,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -144,10 +144,10 @@ * ===================================================================== SUBROUTINE ZTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lib/linalg/ztptri.f b/lib/linalg/ztptri.f index 187c9ccac1..35388194c3 100644 --- a/lib/linalg/ztptri.f +++ b/lib/linalg/ztptri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTPTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTPTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTPTRI( UPLO, DIAG, N, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -86,12 +86,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -117,10 +117,10 @@ * ===================================================================== SUBROUTINE ZTPTRI( UPLO, DIAG, N, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lib/linalg/ztrmm.f b/lib/linalg/ztrmm.f index ba7aead68b..0f445f52a7 100644 --- a/lib/linalg/ztrmm.f +++ b/lib/linalg/ztrmm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA * INTEGER LDA,LDB,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),B(LDB,*) * .. -* +* * *> \par Purpose: * ============= @@ -109,7 +109,7 @@ *> *> \param[in] A *> \verbatim -*> A is COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m +*> A is COMPLEX*16 array, dimension ( LDA, k ), where k is m *> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. *> Before entry with UPLO = 'U' or 'u', the leading k by k *> upper triangular part of the array A must contain the upper @@ -132,9 +132,9 @@ *> then LDA must be at least max( 1, n ). *> \endverbatim *> -*> \param[in] B +*> \param[in,out] B *> \verbatim -*> B is (input/output) COMPLEX*16 array of DIMENSION ( LDB, n ). +*> B is COMPLEX*16 array, dimension ( LDB, N ). *> Before entry, the leading m by n part of the array B must *> contain the matrix B, and on exit is overwritten by the *> transformed matrix. @@ -151,12 +151,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level3 * @@ -177,10 +177,10 @@ * ===================================================================== SUBROUTINE ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA diff --git a/lib/linalg/ztrmv.f b/lib/linalg/ztrmv.f index 8d7974a059..52d1ae6799 100644 --- a/lib/linalg/ztrmv.f +++ b/lib/linalg/ztrmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,LDA,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -80,7 +80,7 @@ *> *> \param[in] A *> \verbatim -*> A is COMPLEX*16 array of DIMENSION ( LDA, n ). +*> A is COMPLEX*16 array, dimension ( LDA, N ). *> Before entry with UPLO = 'U' or 'u', the leading n by n *> upper triangular part of the array A must contain the upper *> triangular matrix and the strictly lower triangular part of @@ -101,13 +101,13 @@ *> max( 1, n ). *> \endverbatim *> -*> \param[in] X +*> \param[in,out] X *> \verbatim -*> X is (input/output) COMPLEX*16 array of dimension at least +*> X is COMPLEX*16 array, dimension at least *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element vector x. On exit, X is overwritten with the -*> tranformed vector x. +*> transformed vector x. *> \endverbatim *> *> \param[in] INCX @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -147,10 +147,10 @@ * ===================================================================== SUBROUTINE ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,LDA,N diff --git a/lib/linalg/zung2l.f b/lib/linalg/zung2l.f index f8fd3667d2..1a48c4d6bc 100644 --- a/lib/linalg/zung2l.f +++ b/lib/linalg/zung2l.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNG2L + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNG2L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lib/linalg/zung2r.f b/lib/linalg/zung2r.f index 63783ac01b..4a3fed0f0d 100644 --- a/lib/linalg/zung2r.f +++ b/lib/linalg/zung2r.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNG2R + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNG2R + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lib/linalg/zungl2.f b/lib/linalg/zungl2.f index 44acba12a6..0774cc4405 100644 --- a/lib/linalg/zungl2.f +++ b/lib/linalg/zungl2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNGL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNGL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lib/linalg/zungql.f b/lib/linalg/zungql.f index 5c77abbd46..c63a47db56 100644 --- a/lib/linalg/zungql.f +++ b/lib/linalg/zungql.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNGQL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNGQL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N diff --git a/lib/linalg/zungqr.f b/lib/linalg/zungqr.f index 6b3e9220cd..5f95b64e88 100644 --- a/lib/linalg/zungqr.f +++ b/lib/linalg/zungqr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNGQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNGQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N diff --git a/lib/linalg/zungtr.f b/lib/linalg/zungtr.f index 422a55a921..728854332f 100644 --- a/lib/linalg/zungtr.f +++ b/lib/linalg/zungtr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNGTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNGTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,22 +111,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO From f312fbfe32e581ca842d55b82cab8ec12a7fa6d7 Mon Sep 17 00:00:00 2001 From: Axel Kohlmeyer Date: Fri, 15 Jun 2018 15:16:10 -0400 Subject: [PATCH 8/9] update Install.py to use a specific numbered release version instead of master --- lib/mscg/Install.py | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lib/mscg/Install.py b/lib/mscg/Install.py index 76c986ef6d..ec70f13f6e 100644 --- a/lib/mscg/Install.py +++ b/lib/mscg/Install.py @@ -30,9 +30,10 @@ make lib-mscg args="-p /usr/local/mscg-release " # use existing MS-CG installati # settings -url = "http://github.com/uchicago-voth/MSCG-release/archive/master.tar.gz" -tarfile = "MS-CG-master.tar.gz" -tardir = "MSCG-release-master" +mscgver = "1.7.3.1" +url = "https://github.com/uchicago-voth/MSCG-release/archive/%s.tar.gz" % mscgver +tarfile = "MS-CG-%s.tar.gz" % mscgver +tardir = "MSCG-release-%s" % mscgver # print error message or help From fe483a769f53d260caf1364277b4bc63287badee Mon Sep 17 00:00:00 2001 From: Axel Kohlmeyer Date: Fri, 15 Jun 2018 15:35:34 -0400 Subject: [PATCH 9/9] update makefiles in lib/linalg to support .F files in addition to .f files --- lib/linalg/Makefile.gfortran | 7 ++++--- lib/linalg/Makefile.mpi | 7 ++++--- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/lib/linalg/Makefile.gfortran b/lib/linalg/Makefile.gfortran index 7e1d97a5bc..2a777099e9 100644 --- a/lib/linalg/Makefile.gfortran +++ b/lib/linalg/Makefile.gfortran @@ -7,13 +7,14 @@ SHELL = /bin/sh # ------ FILES ------ SRC = $(wildcard *.f) +SRC1 = $(wildcard *.F) -FILES = $(SRC) Makefile.* README +FILES = $(SRC) $(SRC1) Makefile.* README # ------ DEFINITIONS ------ LIB = liblinalg.a -OBJ = $(SRC:.f=.o) +OBJ = $(SRC:.f=.o) $(SRC1:.F=.o) # ------ SETTINGS ------ @@ -34,7 +35,7 @@ lib: $(OBJ) # ------ COMPILE RULES ------ %.o:%.F - $(F90) $(F90FLAGS) -c $< + $(FC) $(FFLAGS) -c $< %.o:%.f $(FC) $(FFLAGS) -c $< diff --git a/lib/linalg/Makefile.mpi b/lib/linalg/Makefile.mpi index dd22ff134c..26bfab4c80 100644 --- a/lib/linalg/Makefile.mpi +++ b/lib/linalg/Makefile.mpi @@ -7,13 +7,14 @@ SHELL = /bin/sh # ------ FILES ------ SRC = $(wildcard *.f) +SRC1 = $(wildcard *.F) -FILES = $(SRC) Makefile.* README +FILES = $(SRC) $(SRC1) Makefile.* README # ------ DEFINITIONS ------ LIB = liblinalg.a -OBJ = $(SRC:.f=.o) +OBJ = $(SRC:.f=.o) $(SRC1:.F=.o) # ------ SETTINGS ------ @@ -34,7 +35,7 @@ lib: $(OBJ) # ------ COMPILE RULES ------ %.o:%.F - $(F90) $(F90FLAGS) -c $< + $(FC) $(FFLAGS) -c $< %.o:%.f $(FC) $(FFLAGS) -c $<