diff --git a/lib/linalg/README b/lib/linalg/README index 68f17d9986..6c04225d17 100644 --- a/lib/linalg/README +++ b/lib/linalg/README @@ -1,10 +1,13 @@ This directory has generic BLAS and LAPACK source files needed by the ATC, AWPMD, ELECTRODE, LATTE, and ML-POD packages (and possibly by other packages) in the future that can be used instead of platform or vendor -optimized BLAS/LAPACK library. For increased portability, the -BLAS/LAPACK source files have been translated to C++ with f2c. A few -subroutines using Fortran runtime functions have been re-implemented -in C++. Please see the convert.sh script for how the conversion was done. +optimized BLAS/LAPACK library. To simplify installation, these files +have been translated from the Fortran versions of the BLAS and LAPACK +references source files at https://netlib.org/lapack/ to C++ with f2c. +The package with the tools to do the translation and the matching +original Fortran sources are at https://github.com/lammps/linalg. +Please note that even through the files are C++ source code the +resulting library will follow the Fortran binary conventions. Note that this is an *incomplete* subset of full BLAS/LAPACK. diff --git a/lib/linalg/convert.sh b/lib/linalg/convert.sh deleted file mode 100755 index 0dba27c9e3..0000000000 --- a/lib/linalg/convert.sh +++ /dev/null @@ -1,65 +0,0 @@ -#!/bin/bash - -has_f2c=$(type f2c > /dev/null 2>&1 && echo 1 || echo 0) -if test ${has_f2c} -eq 0 -then - echo "Must have f2c installed to run this script" - exit 1 -fi - -# cleanup -rm -f *.c *.cpp *.P *~ *.orig *.bak *.rej - -# translate original files directly -for f in fortran/*.f -do \ - b=$(basename $f .f) - # skip files for which we have replacements - if test $b == dgetrf2 || test $b == disnan || test $b == dlaisnan || \ - test $b == dlamch || test $b == dlarft || test $b == dpotrf2 || \ - test $b == lsame || test $b == xerbla || test $b == zlarft - then - echo Skipping $b - else - # convert to C++ with f2c, make local variables dynamic, - # strip comments, and reindent with clang-format. - f2c -C++ -a -f < $f \ - | g++ -fpreprocessed -dD -P -E - \ - | clang-format -style=file:static/.clang-format > $b.cpp || exit 2 - # silence c++ compiler warnings about string constants, use custom f2c header - sed -i -e 's/\("[^"]\+"\)/(char *)\1/g' -e 's/^extern.*"C"/extern "C"/' \ - -e 's/^#include.*"f2c.h"/#include "lmp_f2c.h"/' $b.cpp - # replace libf2c functions with local versions under different names - sed -i -e 's/s_\(cat\|cmp\|copy\)(/s_lmp_\1(/g' \ - -e 's/d_\(sign\|cnjg\|imag\|lg10\)(/d_lmp_\1(/g' \ - -e 's/z_\(abs\|div\)(/z_lmp_\1(/g' \ - -e 's/i_\(len\|nint\|dnnt\)(/i_lmp_\1(/g' \ - -e 's/pow_\(dd\|di\|ii\)(/pow_lmp_\1(/g' $b.cpp - fi -done - -# translate modified versions -for f in static/*.f -do \ - b=$(basename $f .f) - # convert to C++ with f2c, make local variables dynamic, - # strip comments, and reindent with clang-format. - f2c -C++ -a -f < $f \ - | g++ -fpreprocessed -dD -P -E - \ - | clang-format -style=file:static/.clang-format > $b.cpp || exit 2 - # silence c++ compiler warnings about string constants, use custom f2c header - sed -i -e 's/\("[^"]\+"\)/(char *)\1/g' -e 's/^extern.*"C"/extern "C"/' \ - -e 's/^#include.*"f2c.h"/#include "lmp_f2c.h"/' $b.cpp - # replace libf2c functions with local versions under different names - sed -i -e 's/s_\(cat\|cmp\|copy\)(/s_lmp_\1(/g' \ - -e 's/d_\(sign\|cnjg\|imag\|lg10\)(/d_lmp_\1(/g' \ - -e 's/z_\(abs\|div\)(/z_lmp_\1(/g' \ - -e 's/i_\(len\|nint\|dnnt\)(/i_lmp_\1(/g' \ - -e 's/pow_\(dd\|di\|ii\)(/pow_lmp_\1(/g' $b.cpp -done - -# copy direct C++ alternatives -for c in static/*.cpp -do \ - cp -v $c . -done diff --git a/lib/linalg/fortran/dasum.f b/lib/linalg/fortran/dasum.f deleted file mode 100644 index 9a360b5acd..0000000000 --- a/lib/linalg/fortran/dasum.f +++ /dev/null @@ -1,131 +0,0 @@ -*> \brief \b DASUM -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) -* -* .. Scalar Arguments .. -* INTEGER INCX,N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION DX(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DASUM takes the sum of the absolute values. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in] DX -*> \verbatim -*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of DX -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, linpack, 3/11/78. -*> modified 3/93 to return if incx .le. 0. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I,M,MP1,NINCX -* .. -* .. Intrinsic Functions .. - INTRINSIC DABS,MOD -* .. - DASUM = 0.0d0 - DTEMP = 0.0d0 - IF (N.LE.0 .OR. INCX.LE.0) RETURN - IF (INCX.EQ.1) THEN -* code for increment equal to 1 -* -* -* clean-up loop -* - M = MOD(N,6) - IF (M.NE.0) THEN - DO I = 1,M - DTEMP = DTEMP + DABS(DX(I)) - END DO - IF (N.LT.6) THEN - DASUM = DTEMP - RETURN - END IF - END IF - MP1 = M + 1 - DO I = MP1,N,6 - DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I+1)) + - $ DABS(DX(I+2)) + DABS(DX(I+3)) + - $ DABS(DX(I+4)) + DABS(DX(I+5)) - END DO - ELSE -* -* code for increment not equal to 1 -* - NINCX = N*INCX - DO I = 1,NINCX,INCX - DTEMP = DTEMP + DABS(DX(I)) - END DO - END IF - DASUM = DTEMP - RETURN -* -* End of DASUM -* - END diff --git a/lib/linalg/fortran/daxpy.f b/lib/linalg/fortran/daxpy.f deleted file mode 100644 index 421f7c630b..0000000000 --- a/lib/linalg/fortran/daxpy.f +++ /dev/null @@ -1,152 +0,0 @@ -*> \brief \b DAXPY -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION DA -* INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION DX(*),DY(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DAXPY constant times a vector plus a vector. -*> uses unrolled loops for increments equal to one. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in] DA -*> \verbatim -*> DA is DOUBLE PRECISION -*> On entry, DA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] DX -*> \verbatim -*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of DX -*> \endverbatim -*> -*> \param[in,out] DY -*> \verbatim -*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> storage spacing between elements of DY -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, linpack, 3/11/78. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION DA - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0) RETURN - IF (DA.EQ.0.0d0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,4) - IF (M.NE.0) THEN - DO I = 1,M - DY(I) = DY(I) + DA*DX(I) - END DO - END IF - IF (N.LT.4) RETURN - MP1 = M + 1 - DO I = MP1,N,4 - DY(I) = DY(I) + DA*DX(I) - DY(I+1) = DY(I+1) + DA*DX(I+1) - DY(I+2) = DY(I+2) + DA*DX(I+2) - DY(I+3) = DY(I+3) + DA*DX(I+3) - END DO - ELSE -* -* code for unequal increments or equal increments -* not equal to 1 -* - IX = 1 - IY = 1 - IF (INCX.LT.0) IX = (-N+1)*INCX + 1 - IF (INCY.LT.0) IY = (-N+1)*INCY + 1 - DO I = 1,N - DY(IY) = DY(IY) + DA*DX(IX) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN -* -* End of DAXPY -* - END diff --git a/lib/linalg/fortran/dbdsqr.f b/lib/linalg/fortran/dbdsqr.f deleted file mode 100644 index c220a5875d..0000000000 --- a/lib/linalg/fortran/dbdsqr.f +++ /dev/null @@ -1,864 +0,0 @@ -*> \brief \b DBDSQR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DBDSQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), -* $ VT( LDVT, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DBDSQR computes the singular values and, optionally, the right and/or -*> 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 -*> subroutine actually returns U*Q instead of Q, and, if right singular -*> vectors are requested, this subroutine returns P**T*VT instead of -*> P**T, for given real input matrices U and VT. When U and VT are the -*> orthogonal matrices that reduce a general matrix A to bidiagonal -*> form: A = U*B*VT, as computed by DGEBRD, then -*> -*> A = (U*Q) * S * (P**T*VT) -*> -*> is the SVD of A. Optionally, the subroutine may also compute Q**T*C -*> for a given real input matrix C. -*> -*> See "Computing Small Singular Values of Bidiagonal Matrices With -*> Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, -*> LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, -*> no. 5, pp. 873-912, Sept 1990) and -*> "Accurate singular values and differential qd algorithms," by -*> B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics -*> Department, University of California at Berkeley, July 1992 -*> for a detailed description of the algorithm. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': B is upper bidiagonal; -*> = 'L': B is lower bidiagonal. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix B. N >= 0. -*> \endverbatim -*> -*> \param[in] NCVT -*> \verbatim -*> NCVT is INTEGER -*> The number of columns of the matrix VT. NCVT >= 0. -*> \endverbatim -*> -*> \param[in] NRU -*> \verbatim -*> NRU is INTEGER -*> The number of rows of the matrix U. NRU >= 0. -*> \endverbatim -*> -*> \param[in] NCC -*> \verbatim -*> NCC is INTEGER -*> The number of columns of the matrix C. NCC >= 0. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the n diagonal elements of the bidiagonal matrix B. -*> On exit, if INFO=0, the singular values of B in decreasing -*> order. -*> \endverbatim -*> -*> \param[in,out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> On entry, the N-1 offdiagonal elements of the bidiagonal -*> 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 -*> as input. -*> \endverbatim -*> -*> \param[in,out] VT -*> \verbatim -*> VT is DOUBLE PRECISION array, dimension (LDVT, NCVT) -*> On entry, an N-by-NCVT matrix VT. -*> On exit, VT is overwritten by P**T * VT. -*> Not referenced if NCVT = 0. -*> \endverbatim -*> -*> \param[in] LDVT -*> \verbatim -*> LDVT is INTEGER -*> The leading dimension of the array VT. -*> LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. -*> \endverbatim -*> -*> \param[in,out] U -*> \verbatim -*> U is DOUBLE PRECISION array, dimension (LDU, N) -*> On entry, an NRU-by-N matrix U. -*> On exit, U is overwritten by U * Q. -*> Not referenced if NRU = 0. -*> \endverbatim -*> -*> \param[in] LDU -*> \verbatim -*> LDU is INTEGER -*> The leading dimension of the array U. LDU >= max(1,NRU). -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC, NCC) -*> On entry, an N-by-NCC matrix C. -*> On exit, C is overwritten by Q**T * C. -*> Not referenced if NCC = 0. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. -*> LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (4*(N-1)) -*> \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 NCVT = NRU = NCC = 0, -*> = 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 -*> (program created more than N unreduced blocks) -*> else NCVT = NRU = NCC = 0, -*> the algorithm did not converge; D and E contain the -*> elements of a bidiagonal matrix which is orthogonally -*> similar to the input matrix B; if INFO = i, i -*> elements of E have not converged to zero. -*> \endverbatim -* -*> \par Internal Parameters: -* ========================= -*> -*> \verbatim -*> TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8))) -*> TOLMUL controls the convergence criterion of the QR loop. -*> If it is positive, TOLMUL*EPS is the desired relative -*> precision in the computed singular values. -*> If it is negative, abs(TOLMUL*EPS*sigma_max) is the -*> desired absolute accuracy in the computed singular -*> values (corresponds to relative accuracy -*> abs(TOLMUL*EPS) in the largest singular value. -*> abs(TOLMUL) should be between 1 and 1/EPS, and preferably -*> between 10 (for fast convergence) and .1/EPS -*> (for there to be some accuracy in the results). -*> Default is to lose at either one eighth or 2 of the -*> available decimal digits in each computed singular value -*> (whichever is smaller). -*> -*> MAXITR INTEGER, default = 6 -*> MAXITR controls the maximum number of passes of the -*> 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. -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, - $ LDU, C, LDC, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), - $ VT( LDVT, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION NEGONE - PARAMETER ( NEGONE = -1.0D0 ) - DOUBLE PRECISION HNDRTH - PARAMETER ( HNDRTH = 0.01D0 ) - DOUBLE PRECISION TEN - PARAMETER ( TEN = 10.0D0 ) - DOUBLE PRECISION HNDRD - PARAMETER ( HNDRD = 100.0D0 ) - DOUBLE PRECISION MEIGTH - PARAMETER ( MEIGTH = -0.125D0 ) - INTEGER MAXITR - PARAMETER ( MAXITR = 6 ) -* .. -* .. Local Scalars .. - LOGICAL LOWER, ROTATE - 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, - $ SN, THRESH, TOL, TOLMUL, UNFL -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DLARTG, DLAS2, DLASQ1, DLASR, DLASV2, DROT, - $ DSCAL, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - LOWER = LSAME( UPLO, 'L' ) - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NCVT.LT.0 ) THEN - INFO = -3 - ELSE IF( NRU.LT.0 ) THEN - INFO = -4 - ELSE IF( NCC.LT.0 ) THEN - INFO = -5 - ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR. - $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN - INFO = -9 - ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN - INFO = -11 - ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR. - $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN - INFO = -13 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DBDSQR', -INFO ) - RETURN - END IF - IF( N.EQ.0 ) - $ RETURN - IF( N.EQ.1 ) - $ GO TO 160 -* -* ROTATE is true if any singular vectors desired, false otherwise -* - ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 ) -* -* If no singular vectors desired, use qd algorithm -* - IF( .NOT.ROTATE ) THEN - 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 -* - NM1 = N - 1 - NM12 = NM1 + NM1 - NM13 = NM12 + NM1 - IDIR = 0 -* -* Get machine constants -* - EPS = DLAMCH( 'Epsilon' ) - UNFL = DLAMCH( 'Safe minimum' ) -* -* If matrix lower bidiagonal, rotate to be upper bidiagonal -* by applying Givens rotations on the left -* - IF( LOWER ) 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 ) - WORK( I ) = CS - WORK( NM1+I ) = SN - 10 CONTINUE -* -* Update singular vectors if desired -* - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), WORK( N ), U, - $ LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), WORK( N ), C, - $ LDC ) - END IF -* -* Compute singular values to relative accuracy TOL -* (By setting TOL to be negative, algorithm will compute -* singular values to absolute accuracy ABS(TOL)*norm(input matrix)) -* - TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) ) - TOL = TOLMUL*EPS -* -* Compute approximate maximum, minimum singular values -* - SMAX = ZERO - DO 20 I = 1, N - SMAX = MAX( SMAX, ABS( D( I ) ) ) - 20 CONTINUE - DO 30 I = 1, N - 1 - SMAX = MAX( SMAX, ABS( E( I ) ) ) - 30 CONTINUE - SMINL = ZERO - IF( TOL.GE.ZERO ) THEN -* -* Relative accuracy desired -* - SMINOA = ABS( D( 1 ) ) - IF( SMINOA.EQ.ZERO ) - $ GO TO 50 - MU = SMINOA - DO 40 I = 2, N - MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) ) - SMINOA = MIN( SMINOA, MU ) - IF( SMINOA.EQ.ZERO ) - $ GO TO 50 - 40 CONTINUE - 50 CONTINUE - SMINOA = SMINOA / SQRT( DBLE( N ) ) - THRESH = MAX( TOL*SMINOA, MAXITR*(N*(N*UNFL)) ) - ELSE -* -* Absolute accuracy desired -* - 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.) -* - MAXITDIVN = MAXITR*N - ITERDIVN = 0 - ITER = -1 - OLDLL = -1 - OLDM = -1 -* -* M points to last element of unconverged part of matrix -* - M = N -* -* Begin main iteration loop -* - 60 CONTINUE -* -* Check for convergence or exceeding iteration count -* - IF( M.LE.1 ) - $ GO TO 160 -* - 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 -* - IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH ) - $ D( M ) = ZERO - SMAX = ABS( D( M ) ) - SMIN = SMAX - DO 70 LLL = 1, M - 1 - LL = M - LLL - ABSS = ABS( D( LL ) ) - ABSE = ABS( E( LL ) ) - IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH ) - $ D( LL ) = ZERO - IF( ABSE.LE.THRESH ) - $ GO TO 80 - SMIN = MIN( SMIN, ABSS ) - SMAX = MAX( SMAX, ABSS, ABSE ) - 70 CONTINUE - LL = 0 - GO TO 90 - 80 CONTINUE - E( LL ) = ZERO -* -* Matrix splits since E(LL) = 0 -* - IF( LL.EQ.M-1 ) THEN -* -* Convergence of bottom singular value, return to top of loop -* - M = M - 1 - GO TO 60 - END IF - 90 CONTINUE - LL = LL + 1 -* -* E(LL) through E(M-1) are nonzero, E(LL-1) is zero -* - IF( LL.EQ.M-1 ) THEN -* -* 2 by 2 block, handle separately -* - CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR, - $ COSR, SINL, COSL ) - D( M-1 ) = SIGMX - E( M-1 ) = ZERO - D( M ) = SIGMN -* -* Compute singular vectors, if desired -* - IF( NCVT.GT.0 ) - $ CALL DROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, COSR, - $ SINR ) - IF( NRU.GT.0 ) - $ CALL DROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL ) - IF( NCC.GT.0 ) - $ CALL DROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL, - $ SINL ) - M = M - 2 - GO TO 60 - END IF -* -* If working on new submatrix, choose shift direction -* (from larger end diagonal element towards smaller) -* - IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN - IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN -* -* Chase bulge from top (big end) to bottom (small end) -* - IDIR = 1 - ELSE -* -* Chase bulge from bottom (big end) to top (small end) -* - IDIR = 2 - END IF - END IF -* -* Apply convergence tests -* - IF( IDIR.EQ.1 ) THEN -* -* Run convergence test in forward direction -* First apply standard test to bottom of matrix -* - IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR. - $ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN - E( M-1 ) = ZERO - GO TO 60 - END IF -* - IF( TOL.GE.ZERO ) THEN -* -* If relative accuracy desired, -* apply convergence criterion forward -* - MU = ABS( D( LL ) ) - SMINL = MU - DO 100 LLL = LL, M - 1 - IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN - E( LLL ) = ZERO - GO TO 60 - END IF - MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) - SMINL = MIN( SMINL, MU ) - 100 CONTINUE - END IF -* - ELSE -* -* Run convergence test in backward direction -* First apply standard test to top of matrix -* - IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR. - $ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN - E( LL ) = ZERO - GO TO 60 - END IF -* - IF( TOL.GE.ZERO ) THEN -* -* If relative accuracy desired, -* apply convergence criterion backward -* - MU = ABS( D( M ) ) - SMINL = MU - DO 110 LLL = M - 1, LL, -1 - IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN - E( LLL ) = ZERO - GO TO 60 - END IF - MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) - SMINL = MIN( SMINL, MU ) - 110 CONTINUE - END IF - END IF - OLDLL = LL - OLDM = M -* -* Compute shift. First, test if shifting would ruin relative -* accuracy, and if so set the shift to zero. -* - IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE. - $ MAX( EPS, HNDRTH*TOL ) ) THEN -* -* Use a zero shift to avoid loss of relative accuracy -* - SHIFT = ZERO - ELSE -* -* Compute the shift from 2-by-2 block at end of matrix -* - IF( IDIR.EQ.1 ) THEN - SLL = ABS( D( LL ) ) - CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R ) - ELSE - SLL = ABS( D( M ) ) - CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R ) - END IF -* -* Test if shift negligible, and if so set to zero -* - IF( SLL.GT.ZERO ) THEN - IF( ( SHIFT / SLL )**2.LT.EPS ) - $ SHIFT = ZERO - END IF - END IF -* -* Increment iteration count -* - ITER = ITER + M - LL -* -* If SHIFT = 0, do simplified QR iteration -* - IF( SHIFT.EQ.ZERO ) THEN - IF( IDIR.EQ.1 ) THEN -* -* Chase bulge from top to bottom -* Save cosines and sines for later singular vector updates -* - CS = ONE - OLDCS = ONE - DO 120 I = LL, M - 1 - CALL DLARTG( D( I )*CS, E( I ), CS, SN, R ) - IF( I.GT.LL ) - $ E( I-1 ) = OLDSN*R - CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) ) - WORK( I-LL+1 ) = CS - WORK( I-LL+1+NM1 ) = SN - WORK( I-LL+1+NM12 ) = OLDCS - WORK( I-LL+1+NM13 ) = OLDSN - 120 CONTINUE - H = D( M )*CS - D( M ) = H*OLDCS - E( M-1 ) = H*OLDSN -* -* Update singular vectors -* - IF( NCVT.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ), - $ WORK( N ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ), - $ WORK( NM13+1 ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ), - $ WORK( NM13+1 ), C( LL, 1 ), LDC ) -* -* Test convergence -* - IF( ABS( E( M-1 ) ).LE.THRESH ) - $ E( M-1 ) = ZERO -* - ELSE -* -* Chase bulge from bottom to top -* Save cosines and sines for later singular vector updates -* - CS = ONE - OLDCS = ONE - DO 130 I = M, LL + 1, -1 - CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R ) - IF( I.LT.M ) - $ E( I ) = OLDSN*R - CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) ) - WORK( I-LL ) = CS - WORK( I-LL+NM1 ) = -SN - WORK( I-LL+NM12 ) = OLDCS - WORK( I-LL+NM13 ) = -OLDSN - 130 CONTINUE - H = D( LL )*CS - D( LL ) = H*OLDCS - E( LL ) = H*OLDSN -* -* Update singular vectors -* - IF( NCVT.GT.0 ) - $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ), - $ WORK( NM13+1 ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ), - $ WORK( N ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ), - $ WORK( N ), C( LL, 1 ), LDC ) -* -* Test convergence -* - IF( ABS( E( LL ) ).LE.THRESH ) - $ E( LL ) = ZERO - END IF - ELSE -* -* Use nonzero shift -* - IF( IDIR.EQ.1 ) THEN -* -* Chase bulge from top to bottom -* Save cosines and sines for later singular vector updates -* - F = ( ABS( D( LL ) )-SHIFT )* - $ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) ) - G = E( LL ) - DO 140 I = LL, M - 1 - CALL DLARTG( F, G, COSR, SINR, R ) - IF( I.GT.LL ) - $ E( I-1 ) = R - F = COSR*D( I ) + SINR*E( I ) - E( I ) = COSR*E( I ) - SINR*D( I ) - G = SINR*D( I+1 ) - D( I+1 ) = COSR*D( I+1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( I ) = R - F = COSL*E( I ) + SINL*D( I+1 ) - D( I+1 ) = COSL*D( I+1 ) - SINL*E( I ) - IF( I.LT.M-1 ) THEN - G = SINL*E( I+1 ) - E( I+1 ) = COSL*E( I+1 ) - END IF - WORK( I-LL+1 ) = COSR - WORK( I-LL+1+NM1 ) = SINR - WORK( I-LL+1+NM12 ) = COSL - WORK( I-LL+1+NM13 ) = SINL - 140 CONTINUE - E( M-1 ) = F -* -* Update singular vectors -* - IF( NCVT.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ), - $ WORK( N ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ), - $ WORK( NM13+1 ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ), - $ WORK( NM13+1 ), C( LL, 1 ), LDC ) -* -* Test convergence -* - IF( ABS( E( M-1 ) ).LE.THRESH ) - $ E( M-1 ) = ZERO -* - ELSE -* -* Chase bulge from bottom to top -* Save cosines and sines for later singular vector updates -* - F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT / - $ D( M ) ) - G = E( M-1 ) - DO 150 I = M, LL + 1, -1 - CALL DLARTG( F, G, COSR, SINR, R ) - IF( I.LT.M ) - $ E( I ) = R - F = COSR*D( I ) + SINR*E( I-1 ) - E( I-1 ) = COSR*E( I-1 ) - SINR*D( I ) - G = SINR*D( I-1 ) - D( I-1 ) = COSR*D( I-1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( I ) = R - F = COSL*E( I-1 ) + SINL*D( I-1 ) - D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 ) - IF( I.GT.LL+1 ) THEN - G = SINL*E( I-2 ) - E( I-2 ) = COSL*E( I-2 ) - END IF - WORK( I-LL ) = COSR - WORK( I-LL+NM1 ) = -SINR - WORK( I-LL+NM12 ) = COSL - WORK( I-LL+NM13 ) = -SINL - 150 CONTINUE - E( LL ) = F -* -* Test convergence -* - IF( ABS( E( LL ) ).LE.THRESH ) - $ E( LL ) = ZERO -* -* Update singular vectors if desired -* - IF( NCVT.GT.0 ) - $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ), - $ WORK( NM13+1 ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ), - $ WORK( N ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ), - $ WORK( N ), C( LL, 1 ), LDC ) - END IF - END IF -* -* QR iteration finished, go back and check convergence -* - GO TO 60 -* -* All singular values converged, so make them positive -* - 160 CONTINUE - DO 170 I = 1, N - IF( D( I ).LT.ZERO ) THEN - D( I ) = -D( I ) -* -* Change sign of singular vectors, if desired -* - IF( NCVT.GT.0 ) - $ CALL DSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT ) - END IF - 170 CONTINUE -* -* Sort the singular values into decreasing order (insertion sort on -* singular values, but only one transposition per singular vector) -* - DO 190 I = 1, N - 1 -* -* Scan for smallest D(I) -* - ISUB = 1 - SMIN = D( 1 ) - DO 180 J = 2, N + 1 - I - IF( D( J ).LE.SMIN ) THEN - ISUB = J - SMIN = D( J ) - END IF - 180 CONTINUE - IF( ISUB.NE.N+1-I ) THEN -* -* Swap singular values and vectors -* - D( ISUB ) = D( N+1-I ) - D( N+1-I ) = SMIN - IF( NCVT.GT.0 ) - $ CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ), - $ LDVT ) - IF( NRU.GT.0 ) - $ CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 ) - IF( NCC.GT.0 ) - $ CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC ) - END IF - 190 CONTINUE - GO TO 220 -* -* Maximum number of iterations exceeded, failure to converge -* - 200 CONTINUE - INFO = 0 - DO 210 I = 1, N - 1 - IF( E( I ).NE.ZERO ) - $ INFO = INFO + 1 - 210 CONTINUE - 220 CONTINUE - RETURN -* -* End of DBDSQR -* - END diff --git a/lib/linalg/fortran/dcabs1.f b/lib/linalg/fortran/dcabs1.f deleted file mode 100644 index f6212a8595..0000000000 --- a/lib/linalg/fortran/dcabs1.f +++ /dev/null @@ -1,66 +0,0 @@ -*> \brief \b DCABS1 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DCABS1(Z) -* -* .. Scalar Arguments .. -* COMPLEX*16 Z -* .. -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DCABS1 computes |Re(.)| + |Im(.)| of a double complex number -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] Z -*> \verbatim -*> Z is COMPLEX*16 -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level1 -* -* ===================================================================== - DOUBLE PRECISION FUNCTION DCABS1(Z) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 Z -* .. -* .. -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC ABS,DBLE,DIMAG -* - DCABS1 = ABS(DBLE(Z)) + ABS(DIMAG(Z)) - RETURN -* -* End of DCABS1 -* - END diff --git a/lib/linalg/fortran/dcopy.f b/lib/linalg/fortran/dcopy.f deleted file mode 100644 index ded46c5ecf..0000000000 --- a/lib/linalg/fortran/dcopy.f +++ /dev/null @@ -1,146 +0,0 @@ -*> \brief \b DCOPY -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) -* -* .. Scalar Arguments .. -* INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION DX(*),DY(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DCOPY copies a vector, x, to a vector, y. -*> uses unrolled loops for increments equal to 1. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in] DX -*> \verbatim -*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of DX -*> \endverbatim -*> -*> \param[out] DY -*> \verbatim -*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> storage spacing between elements of DY -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, linpack, 3/11/78. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,7) - IF (M.NE.0) THEN - DO I = 1,M - DY(I) = DX(I) - END DO - IF (N.LT.7) RETURN - END IF - MP1 = M + 1 - DO I = MP1,N,7 - DY(I) = DX(I) - DY(I+1) = DX(I+1) - DY(I+2) = DX(I+2) - DY(I+3) = DX(I+3) - DY(I+4) = DX(I+4) - DY(I+5) = DX(I+5) - DY(I+6) = DX(I+6) - END DO - ELSE -* -* code for unequal increments or equal increments -* not equal to 1 -* - IX = 1 - IY = 1 - IF (INCX.LT.0) IX = (-N+1)*INCX + 1 - IF (INCY.LT.0) IY = (-N+1)*INCY + 1 - DO I = 1,N - DY(IY) = DX(IX) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN -* -* End of DCOPY -* - END diff --git a/lib/linalg/fortran/ddot.f b/lib/linalg/fortran/ddot.f deleted file mode 100644 index 683a04bd46..0000000000 --- a/lib/linalg/fortran/ddot.f +++ /dev/null @@ -1,148 +0,0 @@ -*> \brief \b DDOT -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) -* -* .. Scalar Arguments .. -* INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION DX(*),DY(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DDOT forms the dot product of two vectors. -*> uses unrolled loops for increments equal to one. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in] DX -*> \verbatim -*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of DX -*> \endverbatim -*> -*> \param[in] DY -*> \verbatim -*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> storage spacing between elements of DY -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, linpack, 3/11/78. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - DDOT = 0.0d0 - DTEMP = 0.0d0 - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,5) - IF (M.NE.0) THEN - DO I = 1,M - DTEMP = DTEMP + DX(I)*DY(I) - END DO - IF (N.LT.5) THEN - DDOT=DTEMP - RETURN - END IF - END IF - MP1 = M + 1 - DO I = MP1,N,5 - DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) + - $ DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4) - END DO - ELSE -* -* code for unequal increments or equal increments -* not equal to 1 -* - IX = 1 - IY = 1 - IF (INCX.LT.0) IX = (-N+1)*INCX + 1 - IF (INCY.LT.0) IY = (-N+1)*INCY + 1 - DO I = 1,N - DTEMP = DTEMP + DX(IX)*DY(IY) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - DDOT = DTEMP - RETURN -* -* End of DDOT -* - END diff --git a/lib/linalg/fortran/dgebd2.f b/lib/linalg/fortran/dgebd2.f deleted file mode 100644 index daaa187aff..0000000000 --- a/lib/linalg/fortran/dgebd2.f +++ /dev/null @@ -1,317 +0,0 @@ -*> \brief \b DGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGEBD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), -* $ TAUQ( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGEBD2 reduces a real general m by n matrix A to upper or lower -*> bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. -*> -*> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows in the matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns in 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 general matrix to be reduced. -*> On exit, -*> if m >= n, the diagonal and the first superdiagonal are -*> overwritten with the upper bidiagonal matrix B; the -*> elements below the diagonal, with the array TAUQ, represent -*> the orthogonal matrix Q as a product of elementary -*> reflectors, and the elements above the first superdiagonal, -*> with the array TAUP, represent the orthogonal matrix P as -*> a product of elementary reflectors; -*> if m < n, the diagonal and the first subdiagonal are -*> overwritten with the lower bidiagonal matrix B; the -*> elements below the first subdiagonal, with the array TAUQ, -*> represent the orthogonal matrix Q as a product of -*> elementary reflectors, and the elements above the diagonal, -*> with the array TAUP, represent the orthogonal matrix P as -*> a product of elementary reflectors. -*> See Further Details. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (min(M,N)) -*> The diagonal elements of the bidiagonal matrix B: -*> D(i) = A(i,i). -*> \endverbatim -*> -*> \param[out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (min(M,N)-1) -*> The off-diagonal elements of the bidiagonal matrix B: -*> if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; -*> if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. -*> \endverbatim -*> -*> \param[out] TAUQ -*> \verbatim -*> 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 -*> -*> \param[out] TAUP -*> \verbatim -*> TAUP is DOUBLE PRECISION array, dimension (min(M,N)) -*> The scalar factors of the elementary reflectors which -*> represent the orthogonal matrix P. See Further Details. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (max(M,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. -* -*> \ingroup doubleGEcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The matrices Q and P are represented as products of elementary -*> reflectors: -*> -*> If m >= n, -*> -*> Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) -*> -*> Each H(i) and G(i) has the form: -*> -*> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T -*> -*> where tauq and taup are real scalars, and v and u are real vectors; -*> v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); -*> u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); -*> tauq is stored in TAUQ(i) and taup in TAUP(i). -*> -*> If m < n, -*> -*> Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) -*> -*> Each H(i) and G(i) has the form: -*> -*> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T -*> -*> where tauq and taup are real scalars, and v and u are real vectors; -*> v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); -*> u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); -*> tauq is stored in TAUQ(i) and taup in TAUP(i). -*> -*> The contents of A on exit are illustrated by the following examples: -*> -*> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): -*> -*> ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) -*> ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) -*> ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) -*> ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) -*> ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) -*> ( v1 v2 v3 v4 v5 ) -*> -*> where d and e denote diagonal and off-diagonal elements of B, vi -*> denotes an element of the vector defining H(i), and ui an element of -*> the vector defining G(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), - $ TAUQ( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, 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.LT.0 ) THEN - CALL XERBLA( 'DGEBD2', -INFO ) - RETURN - END IF -* - IF( M.GE.N ) THEN -* -* Reduce to upper bidiagonal form -* - DO 10 I = 1, N -* -* Generate elementary reflector H(i) to annihilate A(i+1:m,i) -* - CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, - $ TAUQ( I ) ) - D( I ) = A( I, I ) - A( I, I ) = ONE -* -* Apply H(i) to A(i:m,i+1:n) from the left -* - IF( I.LT.N ) - $ CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ), - $ A( I, I+1 ), LDA, WORK ) - A( I, I ) = D( I ) -* - IF( I.LT.N ) THEN -* -* Generate elementary reflector G(i) to annihilate -* A(i,i+2:n) -* - CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), - $ LDA, TAUP( I ) ) - E( I ) = A( I, I+1 ) - A( I, I+1 ) = ONE -* -* Apply G(i) to A(i+1:m,i+1:n) from the right -* - CALL DLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA, - $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) - A( I, I+1 ) = E( I ) - ELSE - TAUP( I ) = ZERO - END IF - 10 CONTINUE - ELSE -* -* Reduce to lower bidiagonal form -* - DO 20 I = 1, M -* -* Generate elementary reflector G(i) to annihilate A(i,i+1:n) -* - CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, - $ TAUP( I ) ) - D( I ) = A( I, I ) - A( I, I ) = ONE -* -* Apply G(i) to A(i+1:m,i:n) from the right -* - IF( I.LT.M ) - $ CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ TAUP( I ), A( I+1, I ), LDA, WORK ) - A( I, I ) = D( I ) -* - IF( I.LT.M ) THEN -* -* Generate elementary reflector H(i) to annihilate -* A(i+2:m,i) -* - CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, - $ TAUQ( I ) ) - E( I ) = A( I+1, I ) - A( I+1, I ) = ONE -* -* Apply H(i) to A(i+1:m,i+1:n) from the left -* - CALL DLARF( 'Left', M-I, N-I, A( I+1, I ), 1, TAUQ( I ), - $ A( I+1, I+1 ), LDA, WORK ) - A( I+1, I ) = E( I ) - ELSE - TAUQ( I ) = ZERO - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DGEBD2 -* - END diff --git a/lib/linalg/fortran/dgebrd.f b/lib/linalg/fortran/dgebrd.f deleted file mode 100644 index 0f0d1651a7..0000000000 --- a/lib/linalg/fortran/dgebrd.f +++ /dev/null @@ -1,349 +0,0 @@ -*> \brief \b DGEBRD -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGEBRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, -* INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), -* $ TAUQ( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGEBRD reduces a general real M-by-N matrix A to upper or lower -*> bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. -*> -*> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows in the matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns in 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 general matrix to be reduced. -*> On exit, -*> if m >= n, the diagonal and the first superdiagonal are -*> overwritten with the upper bidiagonal matrix B; the -*> elements below the diagonal, with the array TAUQ, represent -*> the orthogonal matrix Q as a product of elementary -*> reflectors, and the elements above the first superdiagonal, -*> with the array TAUP, represent the orthogonal matrix P as -*> a product of elementary reflectors; -*> if m < n, the diagonal and the first subdiagonal are -*> overwritten with the lower bidiagonal matrix B; the -*> elements below the first subdiagonal, with the array TAUQ, -*> represent the orthogonal matrix Q as a product of -*> elementary reflectors, and the elements above the diagonal, -*> with the array TAUP, represent the orthogonal matrix P as -*> a product of elementary reflectors. -*> See Further Details. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (min(M,N)) -*> The diagonal elements of the bidiagonal matrix B: -*> D(i) = A(i,i). -*> \endverbatim -*> -*> \param[out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (min(M,N)-1) -*> The off-diagonal elements of the bidiagonal matrix B: -*> if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; -*> if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. -*> \endverbatim -*> -*> \param[out] TAUQ -*> \verbatim -*> 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 -*> -*> \param[out] TAUP -*> \verbatim -*> TAUP is DOUBLE PRECISION array, dimension (min(M,N)) -*> The scalar factors of the elementary reflectors which -*> represent the orthogonal matrix P. See Further Details. -*> \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 length of the array WORK. LWORK >= max(1,M,N). -*> For optimum performance LWORK >= (M+N)*NB, where NB -*> is the optimal blocksize. -*> -*> 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. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The matrices Q and P are represented as products of elementary -*> reflectors: -*> -*> If m >= n, -*> -*> Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) -*> -*> Each H(i) and G(i) has the form: -*> -*> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T -*> -*> where tauq and taup are real scalars, and v and u are real vectors; -*> v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); -*> u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); -*> tauq is stored in TAUQ(i) and taup in TAUP(i). -*> -*> If m < n, -*> -*> Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) -*> -*> Each H(i) and G(i) has the form: -*> -*> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T -*> -*> where tauq and taup are real scalars, and v and u are real vectors; -*> v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); -*> u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); -*> tauq is stored in TAUQ(i) and taup in TAUP(i). -*> -*> The contents of A on exit are illustrated by the following examples: -*> -*> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): -*> -*> ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) -*> ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) -*> ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) -*> ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) -*> ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) -*> ( v1 v2 v3 v4 v5 ) -*> -*> where d and e denote diagonal and off-diagonal elements of B, vi -*> denotes an element of the vector defining H(i), and ui an element of -*> the vector defining G(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, - $ INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), - $ TAUQ( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB, - $ NBMIN, NX, WS -* .. -* .. External Subroutines .. - EXTERNAL DGEBD2, DGEMM, DLABRD, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) ) - LWKOPT = ( M+N )*NB - WORK( 1 ) = DBLE( LWKOPT ) - LQUERY = ( LWORK.EQ.-1 ) - 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 - ELSE IF( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN - INFO = -10 - END IF - IF( INFO.LT.0 ) THEN - CALL XERBLA( 'DGEBRD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - MINMN = MIN( M, N ) - IF( MINMN.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - WS = MAX( M, N ) - LDWRKX = M - LDWRKY = N -* - IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN -* -* Set the crossover point NX. -* - NX = MAX( NB, ILAENV( 3, 'DGEBRD', ' ', M, N, -1, -1 ) ) -* -* Determine when to switch from blocked to unblocked code. -* - IF( NX.LT.MINMN ) THEN - WS = ( M+N )*NB - IF( LWORK.LT.WS ) THEN -* -* Not enough work space for the optimal NB, consider using -* a smaller block size. -* - NBMIN = ILAENV( 2, 'DGEBRD', ' ', M, N, -1, -1 ) - IF( LWORK.GE.( M+N )*NBMIN ) THEN - NB = LWORK / ( M+N ) - ELSE - NB = 1 - NX = MINMN - END IF - END IF - END IF - ELSE - NX = MINMN - END IF -* - DO 30 I = 1, MINMN - NX, NB -* -* Reduce rows and columns i:i+nb-1 to bidiagonal form and return -* the matrices X and Y which are needed to update the unreduced -* part of the matrix -* - CALL DLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ), - $ TAUQ( I ), TAUP( I ), WORK, LDWRKX, - $ WORK( LDWRKX*NB+1 ), LDWRKY ) -* -* Update the trailing submatrix A(i+nb:m,i+nb:n), using an update -* of the form A := A - V*Y**T - X*U**T -* - CALL DGEMM( 'No transpose', 'Transpose', M-I-NB+1, N-I-NB+1, - $ NB, -ONE, A( I+NB, I ), LDA, - $ WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE, - $ A( I+NB, I+NB ), LDA ) - CALL DGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1, - $ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA, - $ ONE, A( I+NB, I+NB ), LDA ) -* -* Copy diagonal and off-diagonal elements of B back into A -* - IF( M.GE.N ) THEN - DO 10 J = I, I + NB - 1 - A( J, J ) = D( J ) - A( J, J+1 ) = E( J ) - 10 CONTINUE - ELSE - DO 20 J = I, I + NB - 1 - A( J, J ) = D( J ) - A( J+1, J ) = E( J ) - 20 CONTINUE - END IF - 30 CONTINUE -* -* Use unblocked code to reduce the remainder of the matrix -* - CALL DGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ), - $ TAUQ( I ), TAUP( I ), WORK, IINFO ) - WORK( 1 ) = WS - RETURN -* -* End of DGEBRD -* - END diff --git a/lib/linalg/fortran/dgecon.f b/lib/linalg/fortran/dgecon.f deleted file mode 100644 index aa10dee9a2..0000000000 --- a/lib/linalg/fortran/dgecon.f +++ /dev/null @@ -1,258 +0,0 @@ -*> \brief \b DGECON -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGECON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, -* INFO ) -* -* .. Scalar Arguments .. -* CHARACTER NORM -* INTEGER INFO, LDA, N -* DOUBLE PRECISION ANORM, RCOND -* .. -* .. Array Arguments .. -* INTEGER IWORK( * ) -* DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGECON estimates the reciprocal of the condition number of a general -*> real matrix A, in either the 1-norm or the infinity-norm, using -*> the LU factorization computed by DGETRF. -*> -*> An estimate is obtained for norm(inv(A)), and the reciprocal of the -*> condition number is computed as -*> RCOND = 1 / ( norm(A) * norm(inv(A)) ). -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] NORM -*> \verbatim -*> NORM is CHARACTER*1 -*> Specifies whether the 1-norm condition number or the -*> infinity-norm condition number is required: -*> = '1' or 'O': 1-norm; -*> = 'I': Infinity-norm. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The factors L and U from the factorization A = P*L*U -*> as computed by DGETRF. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] ANORM -*> \verbatim -*> ANORM is DOUBLE PRECISION -*> If NORM = '1' or 'O', the 1-norm of the original matrix A. -*> If NORM = 'I', the infinity-norm of the original matrix A. -*> \endverbatim -*> -*> \param[out] RCOND -*> \verbatim -*> RCOND is DOUBLE PRECISION -*> The reciprocal of the condition number of the matrix A, -*> computed as RCOND = 1/(norm(A) * norm(inv(A))). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (4*N) -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (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. -* -*> \ingroup doubleGEcomputational -* -* ===================================================================== - SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, - $ INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER NORM - INTEGER INFO, LDA, N - DOUBLE PRECISION ANORM, RCOND -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL ONENRM - CHARACTER NORMIN - INTEGER IX, KASE, KASE1 - DOUBLE PRECISION AINVNM, SCALE, SL, SMLNUM, SU -* .. -* .. Local Arrays .. - INTEGER ISAVE( 3 ) -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, IDAMAX, DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) - IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( ANORM.LT.ZERO ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGECON', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - RCOND = ZERO - IF( N.EQ.0 ) THEN - RCOND = ONE - RETURN - ELSE IF( ANORM.EQ.ZERO ) THEN - RETURN - END IF -* - SMLNUM = DLAMCH( 'Safe minimum' ) -* -* Estimate the norm of inv(A). -* - AINVNM = ZERO - NORMIN = 'N' - IF( ONENRM ) THEN - KASE1 = 1 - ELSE - KASE1 = 2 - END IF - KASE = 0 - 10 CONTINUE - CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) - IF( KASE.NE.0 ) THEN - IF( KASE.EQ.KASE1 ) THEN -* -* Multiply by inv(L). -* - CALL DLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N, A, - $ LDA, WORK, SL, WORK( 2*N+1 ), INFO ) -* -* Multiply by inv(U). -* - CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, - $ A, LDA, WORK, SU, WORK( 3*N+1 ), INFO ) - ELSE -* -* Multiply by inv(U**T). -* - CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A, - $ LDA, WORK, SU, WORK( 3*N+1 ), INFO ) -* -* Multiply by inv(L**T). -* - CALL DLATRS( 'Lower', 'Transpose', 'Unit', NORMIN, N, A, - $ LDA, WORK, SL, WORK( 2*N+1 ), INFO ) - END IF -* -* Divide X by 1/(SL*SU) if doing so will not cause overflow. -* - SCALE = SL*SU - NORMIN = 'Y' - IF( SCALE.NE.ONE ) THEN - IX = IDAMAX( N, WORK, 1 ) - IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO ) - $ GO TO 20 - CALL DRSCL( N, SCALE, WORK, 1 ) - END IF - GO TO 10 - END IF -* -* Compute the estimate of the reciprocal condition number. -* - IF( AINVNM.NE.ZERO ) - $ RCOND = ( ONE / AINVNM ) / ANORM -* - 20 CONTINUE - RETURN -* -* End of DGECON -* - END diff --git a/lib/linalg/fortran/dgelq2.f b/lib/linalg/fortran/dgelq2.f deleted file mode 100644 index 9915c57d47..0000000000 --- a/lib/linalg/fortran/dgelq2.f +++ /dev/null @@ -1,197 +0,0 @@ -*> \brief \b DGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGELQ2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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: -* ============= -*> -*> \verbatim -*> -*> DGELQ2 computes an LQ factorization of a real m-by-n matrix A: -*> -*> A = ( L 0 ) * Q -*> -*> where: -*> -*> Q is a n-by-n orthogonal matrix; -*> L is a lower-triangular m-by-m matrix; -*> 0 is a m-by-(n-m) zero matrix, if m < n. -*> -*> \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 A. -*> On exit, the elements on and below the diagonal of the array -*> contain the m by min(m,n) lower trapezoidal matrix L (L is -*> lower triangular if m <= n); the elements above the diagonal, -*> with the array TAU, represent the orthogonal matrix Q as a -*> product of elementary reflectors (see Further Details). -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) -*> The scalar factors of the elementary reflectors (see Further -*> Details). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (M) -*> \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. -* -*> \ingroup doubleGEcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The matrix Q is represented as a product of elementary reflectors -*> -*> Q = H(k) . . . H(2) H(1), where k = min(m,n). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**T -*> -*> where tau is a real scalar, and v is a real vector with -*> v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), -*> and tau in TAU(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, K - DOUBLE PRECISION AII -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - 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( 'DGELQ2', -INFO ) - RETURN - END IF -* - K = MIN( M, N ) -* - DO 10 I = 1, K -* -* Generate elementary reflector H(i) to annihilate A(i,i+1:n) -* - CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, - $ TAU( I ) ) - IF( I.LT.M ) THEN -* -* Apply H(i) to A(i+1:m,i:n) from the right -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ), - $ A( I+1, I ), LDA, WORK ) - A( I, I ) = AII - END IF - 10 CONTINUE - RETURN -* -* End of DGELQ2 -* - END diff --git a/lib/linalg/fortran/dgelqf.f b/lib/linalg/fortran/dgelqf.f deleted file mode 100644 index ed3372f965..0000000000 --- a/lib/linalg/fortran/dgelqf.f +++ /dev/null @@ -1,274 +0,0 @@ -*> \brief \b DGELQF -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGELQF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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: -* ============= -*> -*> \verbatim -*> -*> DGELQF computes an LQ factorization of a real M-by-N matrix A: -*> -*> A = ( L 0 ) * Q -*> -*> where: -*> -*> Q is a N-by-N orthogonal matrix; -*> L is a lower-triangular M-by-M matrix; -*> 0 is a M-by-(N-M) zero matrix, if M < N. -*> -*> \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 A. -*> On exit, the elements on and below the diagonal of the array -*> contain the m-by-min(m,n) lower trapezoidal matrix L (L is -*> lower triangular if m <= n); the elements above the diagonal, -*> with the array TAU, represent the orthogonal matrix Q as a -*> product of elementary reflectors (see Further Details). -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) -*> The scalar factors of the elementary reflectors (see Further -*> Details). -*> \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 >= max(1,M). -*> For optimum performance LWORK >= M*NB, where NB is the -*> optimal blocksize. -*> -*> 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 -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The matrix Q is represented as a product of elementary reflectors -*> -*> Q = H(k) . . . H(2) H(1), where k = min(m,n). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**T -*> -*> where tau is a real scalar, and v is a real vector with -*> v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), -*> and tau in TAU(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DGELQ2, DLARFB, DLARFT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - LWKOPT = M*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - 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 - ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGELQF', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - K = MIN( M, N ) - IF( K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = M - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DGELQF', ' ', M, N, -1, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = M - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', M, N, -1, - $ -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code initially -* - DO 10 I = 1, K - NX, NB - IB = MIN( K-I+1, NB ) -* -* Compute the LQ factorization of the current block -* A(i:i+ib-1,i:n) -* - CALL DGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) - IF( I+IB.LE.M ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), - $ LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(i+ib:m,i:n) from the right -* - CALL DLARFB( 'Right', 'No transpose', 'Forward', - $ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ), - $ LDA, WORK, LDWORK, A( I+IB, I ), LDA, - $ WORK( IB+1 ), LDWORK ) - END IF - 10 CONTINUE - ELSE - I = 1 - END IF -* -* Use unblocked code to factor the last or only block. -* - IF( I.LE.K ) - $ CALL DGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* - WORK( 1 ) = IWS - RETURN -* -* End of DGELQF -* - END diff --git a/lib/linalg/fortran/dgelsd.f b/lib/linalg/fortran/dgelsd.f deleted file mode 100644 index b3b3d8b2d3..0000000000 --- a/lib/linalg/fortran/dgelsd.f +++ /dev/null @@ -1,626 +0,0 @@ -*> \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. -* -*> \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 -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. 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/fortran/dgelss.f b/lib/linalg/fortran/dgelss.f deleted file mode 100644 index c4190f2e09..0000000000 --- a/lib/linalg/fortran/dgelss.f +++ /dev/null @@ -1,744 +0,0 @@ -*> \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. -* -*> \ingroup doubleGEsolve -* -* ===================================================================== - SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, - $ WORK, LWORK, INFO ) -* -* -- LAPACK driver routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. 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 = INT( 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 = INT( 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 = INT( 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 = INT( DUM(1) ) -* Compute space needed for DORGBR - CALL DORGBR( 'P', N, N, N, A, LDA, DUM(1), - $ DUM(1), -1, INFO ) - LWORK_DORGBR = INT( 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 = INT( 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 = INT( 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 = INT( DUM(1) ) -* Compute space needed for DORGBR - CALL DORGBR( 'P', M, M, M, A, LDA, DUM(1), - $ DUM(1), -1, INFO ) - LWORK_DORGBR = INT( 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 = INT( 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 = INT( 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 = INT( DUM(1) ) -* Compute space needed for DORGBR - CALL DORGBR( 'P', M, N, M, A, LDA, DUM(1), - $ DUM(1), -1, INFO ) - LWORK_DORGBR = INT( 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/fortran/dgemm.f b/lib/linalg/fortran/dgemm.f deleted file mode 100644 index 8c1b4f2066..0000000000 --- a/lib/linalg/fortran/dgemm.f +++ /dev/null @@ -1,379 +0,0 @@ -*> \brief \b DGEMM -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA,BETA -* INTEGER K,LDA,LDB,LDC,M,N -* CHARACTER TRANSA,TRANSB -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGEMM performs one of the matrix-matrix operations -*> -*> C := alpha*op( A )*op( B ) + beta*C, -*> -*> where op( X ) is one of -*> -*> op( X ) = X or op( X ) = X**T, -*> -*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) -*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] TRANSA -*> \verbatim -*> TRANSA is CHARACTER*1 -*> On entry, TRANSA specifies the form of op( A ) to be used in -*> the matrix multiplication as follows: -*> -*> TRANSA = 'N' or 'n', op( A ) = A. -*> -*> TRANSA = 'T' or 't', op( A ) = A**T. -*> -*> TRANSA = 'C' or 'c', op( A ) = A**T. -*> \endverbatim -*> -*> \param[in] TRANSB -*> \verbatim -*> TRANSB is CHARACTER*1 -*> On entry, TRANSB specifies the form of op( B ) to be used in -*> the matrix multiplication as follows: -*> -*> TRANSB = 'N' or 'n', op( B ) = B. -*> -*> TRANSB = 'T' or 't', op( B ) = B**T. -*> -*> TRANSB = 'C' or 'c', op( B ) = B**T. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of the matrix -*> op( A ) and of the matrix C. M must be at least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of the matrix -*> op( B ) and the number of columns of the matrix C. N must be -*> at least zero. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> On entry, K specifies the number of columns of the matrix -*> op( A ) and the number of rows of the matrix op( B ). K must -*> be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is -*> k when TRANSA = 'N' or 'n', and is m otherwise. -*> Before entry with TRANSA = 'N' or 'n', the leading m by k -*> part of the array A must contain the matrix A, otherwise -*> the leading k by m part of the array A must contain the -*> matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. When TRANSA = 'N' or 'n' then -*> LDA must be at least max( 1, m ), otherwise LDA must be at -*> least max( 1, k ). -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension ( LDB, kb ), where kb is -*> n when TRANSB = 'N' or 'n', and is k otherwise. -*> Before entry with TRANSB = 'N' or 'n', the leading k by n -*> part of the array B must contain the matrix B, otherwise -*> the leading n by k part of the array B must contain the -*> matrix B. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> On entry, LDB specifies the first dimension of B as declared -*> in the calling (sub) program. When TRANSB = 'N' or 'n' then -*> LDB must be at least max( 1, k ), otherwise LDB must be at -*> least max( 1, n ). -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is DOUBLE PRECISION. -*> On entry, BETA specifies the scalar beta. When BETA is -*> supplied as zero then C need not be set on input. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension ( LDC, N ) -*> Before entry, the leading m by n part of the array C must -*> contain the matrix C, except when beta is zero, in which -*> case C need not be set on entry. -*> On exit, the array C is overwritten by the m by n matrix -*> ( alpha*op( A )*op( B ) + beta*C ). -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> On entry, LDC specifies the first dimension of C as declared -*> in the calling (sub) program. LDC must be at least -*> max( 1, m ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level3 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 3 Blas routine. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* -- Reference BLAS level3 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA,BETA - INTEGER K,LDA,LDB,LDC,M,N - CHARACTER TRANSA,TRANSB -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,J,L,NROWA,NROWB - LOGICAL NOTA,NOTB -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Set NOTA and NOTB as true if A and B respectively are not -* transposed and set NROWA and NROWB as the number of rows of A -* and B respectively. -* - NOTA = LSAME(TRANSA,'N') - NOTB = LSAME(TRANSB,'N') - IF (NOTA) THEN - NROWA = M - ELSE - NROWA = K - END IF - IF (NOTB) THEN - NROWB = K - ELSE - NROWB = N - END IF -* -* Test the input parameters. -* - INFO = 0 - IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. - + (.NOT.LSAME(TRANSA,'T'))) THEN - INFO = 1 - ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. - + (.NOT.LSAME(TRANSB,'T'))) THEN - INFO = 2 - ELSE IF (M.LT.0) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (K.LT.0) THEN - INFO = 5 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 8 - ELSE IF (LDB.LT.MAX(1,NROWB)) THEN - INFO = 10 - ELSE IF (LDC.LT.MAX(1,M)) THEN - INFO = 13 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DGEMM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. - + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN -* -* And if alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - IF (BETA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - C(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1,N - DO 30 I = 1,M - C(I,J) = BETA*C(I,J) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF (NOTB) THEN - IF (NOTA) THEN -* -* Form C := alpha*A*B + beta*C. -* - DO 90 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 50 I = 1,M - C(I,J) = ZERO - 50 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 60 I = 1,M - C(I,J) = BETA*C(I,J) - 60 CONTINUE - END IF - DO 80 L = 1,K - TEMP = ALPHA*B(L,J) - DO 70 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - ELSE -* -* Form C := alpha*A**T*B + beta*C -* - DO 120 J = 1,N - DO 110 I = 1,M - TEMP = ZERO - DO 100 L = 1,K - TEMP = TEMP + A(L,I)*B(L,J) - 100 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 110 CONTINUE - 120 CONTINUE - END IF - ELSE - IF (NOTA) THEN -* -* Form C := alpha*A*B**T + beta*C -* - DO 170 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 130 I = 1,M - C(I,J) = ZERO - 130 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 140 I = 1,M - C(I,J) = BETA*C(I,J) - 140 CONTINUE - END IF - DO 160 L = 1,K - TEMP = ALPHA*B(J,L) - DO 150 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - ELSE -* -* Form C := alpha*A**T*B**T + beta*C -* - DO 200 J = 1,N - DO 190 I = 1,M - TEMP = ZERO - DO 180 L = 1,K - TEMP = TEMP + A(L,I)*B(J,L) - 180 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 190 CONTINUE - 200 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMM -* - END diff --git a/lib/linalg/fortran/dgemv.f b/lib/linalg/fortran/dgemv.f deleted file mode 100644 index 6625509b3a..0000000000 --- a/lib/linalg/fortran/dgemv.f +++ /dev/null @@ -1,327 +0,0 @@ -*> \brief \b DGEMV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA,BETA -* INTEGER INCX,INCY,LDA,M,N -* CHARACTER TRANS -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGEMV performs one of the matrix-vector operations -*> -*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, -*> -*> where alpha and beta are scalars, x and y are vectors and A is an -*> m by n matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the operation to be performed as -*> follows: -*> -*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -*> -*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. -*> -*> TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of the matrix A. -*> M must be at least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, N ) -*> Before entry, the leading m by n part of the array A must -*> contain the matrix of coefficients. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, m ). -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -*> and at least -*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -*> Before entry, the incremented array X must contain the -*> vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is DOUBLE PRECISION. -*> On entry, BETA specifies the scalar beta. When BETA is -*> supplied as zero then Y need not be set on input. -*> \endverbatim -*> -*> \param[in,out] Y -*> \verbatim -*> Y is DOUBLE PRECISION array, dimension at least -*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -*> and at least -*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -*> Before entry with BETA non-zero, the incremented array Y -*> must contain the vector y. On exit, Y is overwritten by the -*> updated vector y. -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> On entry, INCY specifies the increment for the elements of -*> Y. INCY must not be zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> The vector and matrix arguments are not referenced when N = 0, or M = 0 -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA,BETA - INTEGER INCX,INCY,LDA,M,N - CHARACTER TRANS -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 1 - ELSE IF (M.LT.0) THEN - INFO = 2 - ELSE IF (N.LT.0) THEN - INFO = 3 - ELSE IF (LDA.LT.MAX(1,M)) THEN - INFO = 6 - ELSE IF (INCX.EQ.0) THEN - INFO = 8 - ELSE IF (INCY.EQ.0) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DGEMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. - + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF (LSAME(TRANS,'N')) THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (LENX-1)*INCX - END IF - IF (INCY.GT.0) THEN - KY = 1 - ELSE - KY = 1 - (LENY-1)*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF (BETA.NE.ONE) THEN - IF (INCY.EQ.1) THEN - IF (BETA.EQ.ZERO) THEN - DO 10 I = 1,LENY - Y(I) = ZERO - 10 CONTINUE - ELSE - DO 20 I = 1,LENY - Y(I) = BETA*Y(I) - 20 CONTINUE - END IF - ELSE - IY = KY - IF (BETA.EQ.ZERO) THEN - DO 30 I = 1,LENY - Y(IY) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40 I = 1,LENY - Y(IY) = BETA*Y(IY) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF (ALPHA.EQ.ZERO) RETURN - IF (LSAME(TRANS,'N')) THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF (INCY.EQ.1) THEN - DO 60 J = 1,N - TEMP = ALPHA*X(JX) - DO 50 I = 1,M - Y(I) = Y(I) + TEMP*A(I,J) - 50 CONTINUE - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80 J = 1,N - TEMP = ALPHA*X(JX) - IY = KY - DO 70 I = 1,M - Y(IY) = Y(IY) + TEMP*A(I,J) - IY = IY + INCY - 70 CONTINUE - JX = JX + INCX - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A**T*x + y. -* - JY = KY - IF (INCX.EQ.1) THEN - DO 100 J = 1,N - TEMP = ZERO - DO 90 I = 1,M - TEMP = TEMP + A(I,J)*X(I) - 90 CONTINUE - Y(JY) = Y(JY) + ALPHA*TEMP - JY = JY + INCY - 100 CONTINUE - ELSE - DO 120 J = 1,N - TEMP = ZERO - IX = KX - DO 110 I = 1,M - TEMP = TEMP + A(I,J)*X(IX) - IX = IX + INCX - 110 CONTINUE - Y(JY) = Y(JY) + ALPHA*TEMP - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMV -* - END diff --git a/lib/linalg/fortran/dgeqr2.f b/lib/linalg/fortran/dgeqr2.f deleted file mode 100644 index 5791b3a915..0000000000 --- a/lib/linalg/fortran/dgeqr2.f +++ /dev/null @@ -1,198 +0,0 @@ -*> \brief \b DGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGEQR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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: -* ============= -*> -*> \verbatim -*> -*> DGEQR2 computes a QR factorization of a real m-by-n matrix A: -*> -*> A = Q * ( R ), -*> ( 0 ) -*> -*> where: -*> -*> Q is a m-by-m orthogonal matrix; -*> R is an upper-triangular n-by-n matrix; -*> 0 is a (m-n)-by-n zero matrix, if m > n. -*> -*> \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 A. -*> On exit, the elements on and above the diagonal of the array -*> contain the min(m,n) by n upper trapezoidal matrix R (R is -*> upper triangular if m >= n); the elements below the diagonal, -*> with the array TAU, represent the orthogonal matrix Q as a -*> product of elementary reflectors (see Further Details). -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) -*> The scalar factors of the elementary reflectors (see Further -*> Details). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (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. -* -*> \ingroup doubleGEcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The matrix Q is represented as a product of elementary reflectors -*> -*> Q = H(1) H(2) . . . H(k), where k = min(m,n). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**T -*> -*> where tau is a real scalar, and v is a real vector with -*> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), -*> and tau in TAU(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, K - DOUBLE PRECISION AII -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - 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( 'DGEQR2', -INFO ) - RETURN - END IF -* - K = MIN( M, N ) -* - DO 10 I = 1, K -* -* Generate elementary reflector H(i) to annihilate A(i+1:m,i) -* - CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, - $ TAU( I ) ) - IF( I.LT.N ) THEN -* -* Apply H(i) to A(i:m,i+1:n) from the left -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - A( I, I ) = AII - END IF - 10 CONTINUE - RETURN -* -* End of DGEQR2 -* - END diff --git a/lib/linalg/fortran/dgeqrf.f b/lib/linalg/fortran/dgeqrf.f deleted file mode 100644 index 705e939286..0000000000 --- a/lib/linalg/fortran/dgeqrf.f +++ /dev/null @@ -1,282 +0,0 @@ -*> \brief \b DGEQRF -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGEQRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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: -* ============= -*> -*> \verbatim -*> -*> DGEQRF computes a QR factorization of a real M-by-N matrix A: -*> -*> A = Q * ( R ), -*> ( 0 ) -*> -*> where: -*> -*> Q is a M-by-M orthogonal matrix; -*> R is an upper-triangular N-by-N matrix; -*> 0 is a (M-N)-by-N zero matrix, if M > N. -*> -*> \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 A. -*> On exit, the elements on and above the diagonal of the array -*> contain the min(M,N)-by-N upper trapezoidal matrix R (R is -*> upper triangular if m >= n); the elements below the diagonal, -*> with the array TAU, represent the orthogonal matrix Q as a -*> product of min(m,n) elementary reflectors (see Further -*> Details). -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) -*> The scalar factors of the elementary reflectors (see Further -*> Details). -*> \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, if MIN(M,N) = 0, and LWORK >= N, otherwise. -*> For optimum performance LWORK >= N*NB, where NB is -*> the optimal blocksize. -*> -*> 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 -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The matrix Q is represented as a product of elementary reflectors -*> -*> Q = H(1) H(2) . . . H(k), where k = min(m,n). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**T -*> -*> where tau is a real scalar, and v is a real vector with -*> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), -*> and tau in TAU(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - K = MIN( M, N ) - INFO = 0 - NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - LQUERY = ( LWORK.EQ.-1 ) - 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 - ELSE IF( .NOT.LQUERY ) THEN - IF( LWORK.LE.0 .OR. ( M.GT.0 .AND. LWORK.LT.MAX( 1, N ) ) ) - $ INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQRF', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - IF( K.EQ.0 ) THEN - LWKOPT = 1 - ELSE - LWKOPT = N*NB - END IF - WORK( 1 ) = LWKOPT - RETURN - END IF -* -* Quick return if possible -* - IF( K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1, - $ -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code initially -* - DO 10 I = 1, K - NX, NB - IB = MIN( K-I+1, NB ) -* -* Compute the QR factorization of the current block -* A(i:m,i:i+ib-1) -* - CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) - IF( I+IB.LE.N ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H**T to A(i:m,i+ib:n) from the left -* - CALL DLARFB( 'Left', 'Transpose', 'Forward', - $ 'Columnwise', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), - $ LDA, WORK( IB+1 ), LDWORK ) - END IF - 10 CONTINUE - ELSE - I = 1 - END IF -* -* Use unblocked code to factor the last or only block. -* - IF( I.LE.K ) - $ CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* - WORK( 1 ) = IWS - RETURN -* -* End of DGEQRF -* - END diff --git a/lib/linalg/fortran/dger.f b/lib/linalg/fortran/dger.f deleted file mode 100644 index 8c19cb4e41..0000000000 --- a/lib/linalg/fortran/dger.f +++ /dev/null @@ -1,224 +0,0 @@ -*> \brief \b DGER -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA -* INTEGER INCX,INCY,LDA,M,N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGER performs the rank 1 operation -*> -*> A := alpha*x*y**T + A, -*> -*> where alpha is a scalar, x is an m element vector, y is an n element -*> vector and A is an m by n matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of the matrix A. -*> M must be at least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension at least -*> ( 1 + ( m - 1 )*abs( INCX ) ). -*> Before entry, the incremented array X must contain the m -*> element vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -*> -*> \param[in] Y -*> \verbatim -*> Y is DOUBLE PRECISION array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCY ) ). -*> Before entry, the incremented array Y must contain the n -*> element vector y. -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> On entry, INCY specifies the increment for the elements of -*> Y. INCY must not be zero. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, N ) -*> Before entry, the leading m by n part of the array A must -*> contain the matrix of coefficients. On exit, A is -*> overwritten by the updated matrix. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, m ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX,INCY,LDA,M,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER (ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,J,JY,KX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (M.LT.0) THEN - INFO = 1 - ELSE IF (N.LT.0) THEN - INFO = 2 - ELSE IF (INCX.EQ.0) THEN - INFO = 5 - ELSE IF (INCY.EQ.0) THEN - INFO = 7 - ELSE IF (LDA.LT.MAX(1,M)) THEN - INFO = 9 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DGER ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF (INCY.GT.0) THEN - JY = 1 - ELSE - JY = 1 - (N-1)*INCY - END IF - IF (INCX.EQ.1) THEN - DO 20 J = 1,N - IF (Y(JY).NE.ZERO) THEN - TEMP = ALPHA*Y(JY) - DO 10 I = 1,M - A(I,J) = A(I,J) + X(I)*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (M-1)*INCX - END IF - DO 40 J = 1,N - IF (Y(JY).NE.ZERO) THEN - TEMP = ALPHA*Y(JY) - IX = KX - DO 30 I = 1,M - A(I,J) = A(I,J) + X(IX)*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of DGER -* - END diff --git a/lib/linalg/fortran/dgesv.f b/lib/linalg/fortran/dgesv.f deleted file mode 100644 index 3609c52f47..0000000000 --- a/lib/linalg/fortran/dgesv.f +++ /dev/null @@ -1,176 +0,0 @@ -*> \brief DGESV computes the solution to system of linear equations A * X = B for GE matrices -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGESV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGESV computes the solution to a real system of linear equations -*> A * X = B, -*> where A is an N-by-N matrix and X and B are N-by-NRHS matrices. -*> -*> The LU decomposition with partial pivoting and row interchanges is -*> used to factor A as -*> A = P * L * U, -*> where P is a permutation matrix, L is unit lower triangular, and U is -*> upper triangular. The factored form of A is then used to solve the -*> system of equations A * X = B. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of linear equations, i.e., the order 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 matrix B. NRHS >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the N-by-N coefficient matrix A. -*> 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,N). -*> \endverbatim -*> -*> \param[out] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (N) -*> The pivot indices that define the permutation matrix P; -*> row i of the matrix was interchanged with row IPIV(i). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) -*> On entry, the N-by-NRHS matrix of right hand side matrix B. -*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,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 = i, U(i,i) is exactly zero. The factorization -*> has been completed, but the factor U is exactly -*> singular, so the solution could not be computed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEsolve -* -* ===================================================================== - SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK driver routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. External Subroutines .. - EXTERNAL DGETRF, DGETRS, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGESV ', -INFO ) - RETURN - END IF -* -* Compute the LU factorization of A. -* - CALL DGETRF( N, N, A, LDA, IPIV, INFO ) - IF( INFO.EQ.0 ) THEN -* -* Solve the system A*X = B, overwriting B with X. -* - CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, - $ INFO ) - END IF - RETURN -* -* End of DGESV -* - END diff --git a/lib/linalg/fortran/dgesvd.f b/lib/linalg/fortran/dgesvd.f deleted file mode 100644 index 7cc8b35129..0000000000 --- a/lib/linalg/fortran/dgesvd.f +++ /dev/null @@ -1,3501 +0,0 @@ -*> \brief DGESVD computes the singular value decomposition (SVD) for GE matrices -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGESVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), -* $ VT( LDVT, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGESVD computes the singular value decomposition (SVD) of a real -*> M-by-N matrix A, optionally computing the left and/or right singular -*> vectors. The SVD is written -*> -*> A = U * SIGMA * transpose(V) -*> -*> where SIGMA is an M-by-N matrix which is zero except for its -*> min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and -*> V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA -*> are the singular values of A; they are real and non-negative, and -*> are returned in descending order. The first min(m,n) columns of -*> U and V are the left and right singular vectors of A. -*> -*> Note that the routine returns V**T, not V. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] JOBU -*> \verbatim -*> JOBU is CHARACTER*1 -*> Specifies options for computing all or part of the matrix U: -*> = 'A': all M columns of U are returned in array U: -*> = 'S': the first min(m,n) columns of U (the left singular -*> vectors) are returned in the array U; -*> = 'O': the first min(m,n) columns of U (the left singular -*> vectors) are overwritten on the array A; -*> = 'N': no columns of U (no left singular vectors) are -*> computed. -*> \endverbatim -*> -*> \param[in] JOBVT -*> \verbatim -*> JOBVT is CHARACTER*1 -*> Specifies options for computing all or part of the matrix -*> V**T: -*> = 'A': all N rows of V**T are returned in the array VT; -*> = 'S': the first min(m,n) rows of V**T (the right singular -*> vectors) are returned in the array VT; -*> = 'O': the first min(m,n) rows of V**T (the right singular -*> vectors) are overwritten on the array A; -*> = 'N': no rows of V**T (no right singular vectors) are -*> computed. -*> -*> JOBVT and JOBU cannot both be 'O'. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the input matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the input 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 A. -*> On exit, -*> if JOBU = 'O', A is overwritten with the first min(m,n) -*> columns of U (the left singular vectors, -*> stored columnwise); -*> if JOBVT = 'O', A is overwritten with the first min(m,n) -*> rows of V**T (the right singular vectors, -*> stored rowwise); -*> if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A -*> are destroyed. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] S -*> \verbatim -*> S is DOUBLE PRECISION array, dimension (min(M,N)) -*> The singular values of A, sorted so that S(i) >= S(i+1). -*> \endverbatim -*> -*> \param[out] U -*> \verbatim -*> U is DOUBLE PRECISION array, dimension (LDU,UCOL) -*> (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'. -*> If JOBU = 'A', U contains the M-by-M orthogonal matrix U; -*> if JOBU = 'S', U contains the first min(m,n) columns of U -*> (the left singular vectors, stored columnwise); -*> if JOBU = 'N' or 'O', U is not referenced. -*> \endverbatim -*> -*> \param[in] LDU -*> \verbatim -*> LDU is INTEGER -*> The leading dimension of the array U. LDU >= 1; if -*> JOBU = 'S' or 'A', LDU >= M. -*> \endverbatim -*> -*> \param[out] VT -*> \verbatim -*> VT is DOUBLE PRECISION array, dimension (LDVT,N) -*> If JOBVT = 'A', VT contains the N-by-N orthogonal matrix -*> V**T; -*> if JOBVT = 'S', VT contains the first min(m,n) rows of -*> V**T (the right singular vectors, stored rowwise); -*> if JOBVT = 'N' or 'O', VT is not referenced. -*> \endverbatim -*> -*> \param[in] LDVT -*> \verbatim -*> LDVT is INTEGER -*> The leading dimension of the array VT. LDVT >= 1; if -*> JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). -*> \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; -*> if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged -*> superdiagonal elements of an upper bidiagonal matrix B -*> whose diagonal is in S (not necessarily sorted). B -*> satisfies A = U * B * VT, so it has the same singular values -*> as A, and singular vectors related by U and VT. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> 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 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 -*> 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: if DBDSQR did not converge, INFO specifies how many -*> superdiagonals of an intermediate bidiagonal form B -*> did not converge to zero. See the description of WORK -*> above for details. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEsing -* -* ===================================================================== - SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, - $ VT, LDVT, WORK, LWORK, INFO ) -* -* -- LAPACK driver routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER JOBU, JOBVT - INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), - $ VT( LDVT, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, - $ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS - INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IR, ISCL, - $ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU, - $ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU, - $ NRVT, WRKBL - INTEGER LWORK_DGEQRF, LWORK_DORGQR_N, LWORK_DORGQR_M, - $ LWORK_DGEBRD, LWORK_DORGBR_P, LWORK_DORGBR_Q, - $ LWORK_DGELQF, LWORK_DORGLQ_N, LWORK_DORGLQ_M - DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM -* .. -* .. Local Arrays .. - DOUBLE PRECISION DUM( 1 ) -* .. -* .. External Subroutines .. - EXTERNAL DBDSQR, DGEBRD, DGELQF, DGEMM, DGEQRF, DLACPY, - $ DLASCL, DLASET, DORGBR, DORGLQ, DORGQR, DORMBR, - $ XERBLA -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - MINMN = MIN( M, N ) - WNTUA = LSAME( JOBU, 'A' ) - WNTUS = LSAME( JOBU, 'S' ) - WNTUAS = WNTUA .OR. WNTUS - WNTUO = LSAME( JOBU, 'O' ) - WNTUN = LSAME( JOBU, 'N' ) - WNTVA = LSAME( JOBVT, 'A' ) - WNTVS = LSAME( JOBVT, 'S' ) - WNTVAS = WNTVA .OR. WNTVS - WNTVO = LSAME( JOBVT, 'O' ) - WNTVN = LSAME( JOBVT, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* - IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN - INFO = -1 - ELSE IF( .NOT.( WNTVA .OR. WNTVS .OR. WNTVO .OR. WNTVN ) .OR. - $ ( WNTVO .AND. WNTUO ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE IF( LDU.LT.1 .OR. ( WNTUAS .AND. LDU.LT.M ) ) THEN - INFO = -9 - ELSE IF( LDVT.LT.1 .OR. ( WNTVA .AND. LDVT.LT.N ) .OR. - $ ( WNTVS .AND. LDVT.LT.MINMN ) ) THEN - INFO = -11 - 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( M.GE.N .AND. MINMN.GT.0 ) THEN -* -* Compute space needed for DBDSQR -* - MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 ) - BDSPAC = 5*N -* Compute space needed for DGEQRF - CALL DGEQRF( M, N, A, LDA, DUM(1), DUM(1), -1, IERR ) - 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 = INT( DUM(1) ) - CALL DORGQR( M, M, N, A, LDA, DUM(1), DUM(1), -1, IERR ) - 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 = 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 = 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 = INT( DUM(1) ) -* - IF( M.GE.MNTHR ) THEN - IF( WNTUN ) THEN -* -* Path 1 (M much larger than N, JOBU='N') -* - MAXWRK = N + LWORK_DGEQRF - MAXWRK = MAX( MAXWRK, 3*N + LWORK_DGEBRD ) - IF( WNTVO .OR. WNTVAS ) - $ MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR_P ) - MAXWRK = MAX( MAXWRK, BDSPAC ) - MINWRK = MAX( 4*N, BDSPAC ) - ELSE IF( WNTUO .AND. WNTVN ) THEN -* -* 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, 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, 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, BDSPAC ) - MAXWRK = N*N + WRKBL - 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, BDSPAC ) - MAXWRK = 2*N*N + WRKBL - 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, BDSPAC ) - MAXWRK = N*N + WRKBL - 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, BDSPAC ) - MAXWRK = N*N + WRKBL - 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, BDSPAC ) - MAXWRK = 2*N*N + WRKBL - 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, BDSPAC ) - MAXWRK = N*N + WRKBL - MINWRK = MAX( 3*N + M, BDSPAC ) - END IF - ELSE -* -* Path 10 (M at least N, but not much larger) -* - CALL DGEBRD( M, N, A, LDA, S, DUM(1), DUM(1), - $ DUM(1), DUM(1), -1, IERR ) - 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 = 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 = 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 ) - END IF - MAXWRK = MAX( MAXWRK, BDSPAC ) - MINWRK = MAX( 3*N + M, BDSPAC ) - END IF - ELSE IF( MINMN.GT.0 ) THEN -* -* Compute space needed for DBDSQR -* - MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 ) - BDSPAC = 5*M -* Compute space needed for DGELQF - CALL DGELQF( M, N, A, LDA, DUM(1), DUM(1), -1, IERR ) - 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 = INT( DUM(1) ) - CALL DORGLQ( M, N, M, A, LDA, DUM(1), DUM(1), -1, IERR ) - 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 = 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 = 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 = 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 ) - IF( WNTUO .OR. WNTUAS ) - $ MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR_Q ) - MAXWRK = MAX( MAXWRK, BDSPAC ) - MINWRK = MAX( 4*M, BDSPAC ) - ELSE IF( WNTVO .AND. WNTUN ) THEN -* -* 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, 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, 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, BDSPAC ) - MAXWRK = M*M + WRKBL - 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, BDSPAC ) - MAXWRK = 2*M*M + WRKBL - 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, BDSPAC ) - MAXWRK = M*M + WRKBL - 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, BDSPAC ) - MAXWRK = M*M + WRKBL - 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, BDSPAC ) - MAXWRK = 2*M*M + WRKBL - 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, BDSPAC ) - MAXWRK = M*M + WRKBL - MINWRK = MAX( 3*M + N, BDSPAC ) - END IF - ELSE -* -* Path 10t(N greater than M, but not much larger) -* - CALL DGEBRD( M, N, A, LDA, S, DUM(1), DUM(1), - $ DUM(1), DUM(1), -1, IERR ) - 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 = 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 = 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 ) - END IF - MAXWRK = MAX( MAXWRK, BDSPAC ) - MINWRK = MAX( 3*M + N, BDSPAC ) - END IF - END IF - MAXWRK = MAX( MAXWRK, MINWRK ) - WORK( 1 ) = MAXWRK -* - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGESVD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - RETURN - END IF -* -* Get machine constants -* - EPS = DLAMCH( 'P' ) - SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS - BIGNUM = ONE / SMLNUM -* -* Scale A if max element outside range [SMLNUM,BIGNUM] -* - ANRM = DLANGE( 'M', M, N, A, LDA, DUM ) - ISCL = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN - ISCL = 1 - CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR ) - ELSE IF( ANRM.GT.BIGNUM ) THEN - ISCL = 1 - CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR ) - END IF -* - IF( M.GE.N ) THEN -* -* A has at least as many rows as columns. If A has sufficiently -* more rows than columns, first reduce using the QR -* decomposition (if sufficient workspace available) -* - IF( M.GE.MNTHR ) THEN -* - IF( WNTUN ) THEN -* -* Path 1 (M much larger than N, JOBU='N') -* No left singular vectors to be computed -* - 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, IERR ) -* -* Zero out below R -* - 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) -* - CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, - $ IERR ) - NCVT = 0 - IF( WNTVO .OR. WNTVAS ) THEN -* -* If right singular vectors desired, generate P'. -* (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 ) - NCVT = N - END IF - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of A in A if desired -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, NCVT, 0, 0, S, WORK( IE ), A, LDA, - $ DUM, 1, DUM, 1, WORK( IWORK ), INFO ) -* -* If right singular vectors desired in VT, copy them there -* - IF( WNTVAS ) - $ CALL DLACPY( 'F', N, N, A, LDA, VT, LDVT ) -* - ELSE IF( WNTUO .AND. WNTVN ) THEN -* -* Path 2 (M much larger than N, JOBU='O', JOBVT='N') -* N left singular vectors to be overwritten on A and -* no right singular vectors to be computed -* - IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - 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 -* -* WORK(IU) is LDA by N, WORK(IR) is N by N -* - LDWRKU = LDA - LDWRKR = N - ELSE -* -* WORK(IU) is LDWRKU by N, WORK(IR) is N by N -* - LDWRKU = ( LWORK-N*N-N ) / N - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R -* (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 ) -* -* Copy R to WORK(IR) and zero out below it -* - CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ), - $ LDWRKR ) -* -* Generate Q in A -* (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 ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IR) -* (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) -* - CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IR) -* (Workspace: need N*N + BDSPAC) -* - CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, 1, - $ WORK( IR ), LDWRKR, DUM, 1, - $ WORK( IWORK ), INFO ) - IU = IE + N -* -* 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) -* - DO 10 I = 1, M, LDWRKU - CHUNK = MIN( M-I+1, LDWRKU ) - CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), - $ LDA, WORK( IR ), LDWRKR, ZERO, - $ WORK( IU ), LDWRKU ) - CALL DLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU, - $ A( I, 1 ), LDA ) - 10 CONTINUE -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - IE = 1 - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize A -* (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) -* - CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, 1, - $ A, LDA, DUM, 1, WORK( IWORK ), INFO ) -* - END IF -* - ELSE IF( WNTUO .AND. WNTVAS ) THEN -* -* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A') -* N left singular vectors to be overwritten on A and -* N right singular vectors to be computed in VT -* - IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - 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 -* -* WORK(IU) is LDA by N and WORK(IR) is N by N -* - LDWRKU = LDA - LDWRKR = N - ELSE -* -* WORK(IU) is LDWRKU by N and WORK(IR) is N by N -* - LDWRKU = ( LWORK-N*N-N ) / N - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R -* (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 ) -* -* Copy R to VT, zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) - IF( N.GT.1 ) - $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ VT( 2, 1 ), LDVT ) -* -* Generate Q in A -* (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 ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - 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) -* - CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - 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) -* - 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) -* - CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* 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) -* - CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, LDVT, - $ WORK( IR ), LDWRKR, DUM, 1, - $ WORK( IWORK ), INFO ) - IU = IE + N -* -* 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) -* - DO 20 I = 1, M, LDWRKU - CHUNK = MIN( M-I+1, LDWRKU ) - CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), - $ LDA, WORK( IR ), LDWRKR, ZERO, - $ WORK( IU ), LDWRKU ) - CALL DLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU, - $ A( I, 1 ), LDA ) - 20 CONTINUE -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - 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, IERR ) -* -* Copy R to VT, zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) - IF( N.GT.1 ) - $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ VT( 2, 1 ), LDVT ) -* -* Generate Q in A -* (Workspace: need 2*N, prefer N + N*NB) -* - CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in VT -* (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) -* - 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) -* - CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in A and computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, LDVT, - $ A, LDA, DUM, 1, WORK( IWORK ), INFO ) -* - END IF -* - ELSE IF( WNTUS ) THEN -* - IF( WNTVN ) THEN -* -* Path 4 (M much larger than N, JOBU='S', JOBVT='N') -* N left singular vectors to be computed in U and -* no right singular vectors to be computed -* - IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.WRKBL+LDA*N ) THEN -* -* WORK(IR) is LDA by N -* - LDWRKR = LDA - ELSE -* -* WORK(IR) is N by N -* - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R -* (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 ) -* -* Copy R to WORK(IR), zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), - $ LDWRKR ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ WORK( IR+1 ), LDWRKR ) -* -* Generate Q in A -* (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 ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IR) -* (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 in WORK(IR) -* (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 ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IR) -* (Workspace: need N*N + BDSPAC) -* - CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, - $ 1, WORK( IR ), LDWRKR, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply Q in A by left singular vectors of R in -* WORK(IR), storing result in U -* (Workspace: need N*N) -* - CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, - $ WORK( IR ), LDWRKR, ZERO, U, LDU ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (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) -* - CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Zero out below R in A -* - 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) -* - 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) -* - CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, - $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, - $ 1, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTVO ) THEN -* -* Path 5 (M much larger than N, JOBU='S', JOBVT='O') -* N left singular vectors to be computed in U and -* N right singular vectors to be overwritten on A -* - IF( LWORK.GE.2*N*N+MAX( 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+2*LDA*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is LDA by N -* - LDWRKU = LDA - IR = IU + LDWRKU*N - LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA + N )*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is N by N -* - LDWRKU = LDA - IR = IU + LDWRKU*N - LDWRKR = N - ELSE -* -* WORK(IU) is N by N and WORK(IR) is N by N -* - LDWRKU = N - IR = IU + LDWRKU*N - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R -* (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 ) -* -* Copy R to WORK(IU), zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ WORK( IU+1 ), LDWRKU ) -* -* Generate Q in A -* (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 ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IU), copying result to -* WORK(IR) -* (Workspace: need 2*N*N + 4*N, -* prefer 2*N*N+3*N+2*N*NB) -* - CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, - $ 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) -* - 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, -* prefer 2*N*N+3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* 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) -* - CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), - $ WORK( IR ), LDWRKR, WORK( IU ), - $ LDWRKU, DUM, 1, WORK( IWORK ), INFO ) -* -* Multiply Q in A by left singular vectors of R in -* WORK(IU), storing result in U -* (Workspace: need N*N) -* - CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, - $ WORK( IU ), LDWRKU, ZERO, U, LDU ) -* -* Copy right singular vectors of R to A -* (Workspace: need N*N) -* - CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A, - $ LDA ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (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) -* - CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Zero out below R in A -* - 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) -* - 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) -* - 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) -* - CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A, - $ LDA, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTVAS ) THEN -* -* Path 6 (M much larger than N, JOBU='S', JOBVT='S' -* or 'A') -* N left singular vectors to be computed in U and -* N right singular vectors to be computed in VT -* - IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+LDA*N ) THEN -* -* WORK(IU) is LDA by N -* - LDWRKU = LDA - ELSE -* -* WORK(IU) is N by N -* - LDWRKU = N - END IF - ITAU = IU + LDWRKU*N - IWORK = ITAU + N -* -* Compute A=Q*R -* (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 ) -* -* Copy R to WORK(IU), zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ WORK( IU+1 ), LDWRKU ) -* -* Generate Q in A -* (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 ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - 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) -* - CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT, - $ LDVT ) -* -* Generate left bidiagonalizing vectors in WORK(IU) -* (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, -* prefer N*N+3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* 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) -* - CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, - $ LDVT, WORK( IU ), LDWRKU, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply Q in A by left singular vectors of R in -* WORK(IU), storing result in U -* (Workspace: need N*N) -* - CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, - $ WORK( IU ), LDWRKU, ZERO, U, LDU ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (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) -* - CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to VT, zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) - IF( N.GT.1 ) - $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ VT( 2, 1 ), LDVT ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in VT -* (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 U by left bidiagonalizing vectors -* in VT -* (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) -* - CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, - $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - END IF -* - ELSE IF( WNTUA ) THEN -* - IF( WNTVN ) THEN -* -* Path 7 (M much larger than N, JOBU='A', JOBVT='N') -* M left singular vectors to be computed in U and -* no right singular vectors to be computed -* - IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.WRKBL+LDA*N ) THEN -* -* WORK(IR) is LDA by N -* - LDWRKR = LDA - ELSE -* -* WORK(IR) is N by N -* - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (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 ) -* -* Copy R to WORK(IR), zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), - $ LDWRKR ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ WORK( IR+1 ), LDWRKR ) -* -* Generate Q in U -* (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 ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IR) -* (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 bidiagonalizing vectors in WORK(IR) -* (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 ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IR) -* (Workspace: need N*N + BDSPAC) -* - CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, - $ 1, WORK( IR ), LDWRKR, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply Q in U by left singular vectors of R in -* WORK(IR), storing result in A -* (Workspace: need N*N) -* - CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, - $ WORK( IR ), LDWRKR, ZERO, A, LDA ) -* -* Copy left singular vectors of A from A to U -* - CALL DLACPY( 'F', M, N, A, LDA, U, LDU ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (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) -* - CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Zero out below R in A -* - 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) -* - 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 bidiagonalizing vectors -* in A -* (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 ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, - $ 1, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTVO ) THEN -* -* Path 8 (M much larger than N, JOBU='A', JOBVT='O') -* M left singular vectors to be computed in U and -* N right singular vectors to be overwritten on A -* - IF( LWORK.GE.2*N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+2*LDA*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is LDA by N -* - LDWRKU = LDA - IR = IU + LDWRKU*N - LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA + N )*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is N by N -* - LDWRKU = LDA - IR = IU + LDWRKU*N - LDWRKR = N - ELSE -* -* WORK(IU) is N by N and WORK(IR) is N by N -* - LDWRKU = N - IR = IU + LDWRKU*N - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - 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) -* - 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) -* - CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to WORK(IU), zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ WORK( IU+1 ), LDWRKU ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IU), copying result to -* WORK(IR) -* (Workspace: need 2*N*N + 4*N, -* prefer 2*N*N+3*N+2*N*NB) -* - CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, - $ 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) -* - 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, -* prefer 2*N*N+3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* 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) -* - CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), - $ WORK( IR ), LDWRKR, WORK( IU ), - $ LDWRKU, DUM, 1, WORK( IWORK ), INFO ) -* -* Multiply Q in U by left singular vectors of R in -* WORK(IU), storing result in A -* (Workspace: need N*N) -* - CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, - $ WORK( IU ), LDWRKU, ZERO, A, LDA ) -* -* Copy left singular vectors of A from A to U -* - CALL DLACPY( 'F', M, N, A, LDA, U, LDU ) -* -* Copy right singular vectors of R from WORK(IR) to A -* - CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A, - $ LDA ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (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) -* - CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Zero out below R in A -* - 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) -* - 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 bidiagonalizing vectors -* in A -* (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) -* - CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A, - $ LDA, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTVAS ) THEN -* -* Path 9 (M much larger than N, JOBU='A', JOBVT='S' -* or 'A') -* M left singular vectors to be computed in U and -* N right singular vectors to be computed in VT -* - IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+LDA*N ) THEN -* -* WORK(IU) is LDA by N -* - LDWRKU = LDA - ELSE -* -* WORK(IU) is N by N -* - LDWRKU = N - END IF - ITAU = IU + LDWRKU*N - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (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) -* - CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to WORK(IU), zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ WORK( IU+1 ), LDWRKU ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - 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) -* - CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT, - $ LDVT ) -* -* Generate left bidiagonalizing vectors in WORK(IU) -* (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, -* prefer N*N+3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* 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) -* - CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, - $ LDVT, WORK( IU ), LDWRKU, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply Q in U by left singular vectors of R in -* WORK(IU), storing result in A -* (Workspace: need N*N) -* - CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, - $ WORK( IU ), LDWRKU, ZERO, A, LDA ) -* -* Copy left singular vectors of A from A to U -* - CALL DLACPY( 'F', M, N, A, LDA, U, LDU ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (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) -* - CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R from A to VT, zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) - IF( N.GT.1 ) - $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ VT( 2, 1 ), LDVT ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in VT -* (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 U by left bidiagonalizing vectors -* in VT -* (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) -* - CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, - $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - END IF -* - END IF -* - ELSE -* -* M .LT. MNTHR -* -* Path 10 (M at least N, but not much larger) -* Reduce to bidiagonal form without QR decomposition -* - IE = 1 - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize A -* (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 ) - IF( WNTUAS ) THEN -* -* 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) -* - CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) - IF( WNTUS ) - $ NCU = N - IF( WNTUA ) - $ NCU = M - CALL DORGBR( 'Q', M, NCU, N, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTVAS ) THEN -* -* 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) -* - CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) - CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTUO ) THEN -* -* If left singular vectors desired in A, generate left -* bidiagonalizing vectors in A -* (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 ) - END IF - IF( WNTVO ) THEN -* -* If right singular vectors desired in A, generate right -* bidiagonalizing vectors 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, IERR ) - END IF - IWORK = IE + N - IF( WNTUAS .OR. WNTUO ) - $ NRU = M - IF( WNTUN ) - $ NRU = 0 - IF( WNTVAS .OR. WNTVO ) - $ NCVT = N - IF( WNTVN ) - $ NCVT = 0 - IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in U and computing right singular -* vectors in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT, - $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO ) - ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in U and computing right singular -* vectors in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), A, LDA, - $ U, LDU, DUM, 1, WORK( IWORK ), INFO ) - ELSE -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in A and computing right singular -* vectors in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT, - $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO ) - END IF -* - END IF -* - ELSE -* -* A has more columns than rows. If A has sufficiently more -* columns than rows, first reduce using the LQ decomposition (if -* sufficient workspace available) -* - IF( N.GE.MNTHR ) THEN -* - IF( WNTVN ) THEN -* -* Path 1t(N much larger than M, JOBVT='N') -* No right singular vectors to be computed -* - ITAU = 1 - IWORK = ITAU + M -* -* 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, IERR ) -* -* Zero out above L -* - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA ) - IE = 1 - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in A -* (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 ) - IF( WNTUO .OR. WNTUAS ) THEN -* -* If left singular vectors desired, generate Q -* (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 ) - END IF - IWORK = IE + M - NRU = 0 - IF( WNTUO .OR. WNTUAS ) - $ NRU = M -* -* Perform bidiagonal QR iteration, computing left singular -* vectors of A in A if desired -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, 0, NRU, 0, S, WORK( IE ), DUM, 1, A, - $ LDA, DUM, 1, WORK( IWORK ), INFO ) -* -* If left singular vectors desired in U, copy them there -* - IF( WNTUAS ) - $ CALL DLACPY( 'F', M, M, A, LDA, U, LDU ) -* - ELSE IF( WNTVO .AND. WNTUN ) THEN -* -* Path 2t(N much larger than M, JOBU='N', JOBVT='O') -* M right singular vectors to be overwritten on A and -* no left singular vectors to be computed -* - IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - 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 -* -* WORK(IU) is LDA by N and WORK(IR) is M by M -* - LDWRKU = LDA - CHUNK = N - LDWRKR = M - ELSE -* -* WORK(IU) is M by CHUNK and WORK(IR) is M by M -* - LDWRKU = M - CHUNK = ( LWORK-M*M-M ) / M - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q -* (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 ) -* -* Copy L to WORK(IR) and zero out above it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IR+LDWRKR ), LDWRKR ) -* -* Generate Q in A -* (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 ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IR) -* (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) -* - CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of L in WORK(IR) -* (Workspace: need M*M + BDSPAC) -* - CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), - $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1, - $ WORK( IWORK ), INFO ) - IU = IE + M -* -* 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) -* - DO 30 I = 1, N, CHUNK - BLK = MIN( N-I+1, CHUNK ) - CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ), - $ LDWRKR, A( 1, I ), LDA, ZERO, - $ WORK( IU ), LDWRKU ) - CALL DLACPY( 'F', M, BLK, WORK( IU ), LDWRKU, - $ A( 1, I ), LDA ) - 30 CONTINUE -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - 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, IERR ) -* -* Generate right vectors bidiagonalizing 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, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of A in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'L', M, N, 0, 0, S, WORK( IE ), A, LDA, - $ DUM, 1, DUM, 1, WORK( IWORK ), INFO ) -* - END IF -* - ELSE IF( WNTVO .AND. WNTUAS ) THEN -* -* Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O') -* M right singular vectors to be overwritten on A and -* M left singular vectors to be computed in U -* - IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - 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 -* -* WORK(IU) is LDA by N and WORK(IR) is M by M -* - LDWRKU = LDA - CHUNK = N - LDWRKR = M - ELSE -* -* WORK(IU) is M by CHUNK and WORK(IR) is M by M -* - LDWRKU = M - CHUNK = ( LWORK-M*M-M ) / M - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q -* (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 ) -* -* Copy L to U, zeroing about above it -* - CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), - $ LDU ) -* -* Generate Q in A -* (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 ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - 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) -* - CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - 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) -* - 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) -* - CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* 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) -* - CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), - $ WORK( IR ), LDWRKR, U, LDU, DUM, 1, - $ WORK( IWORK ), INFO ) - IU = IE + M -* -* 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)) -* - DO 40 I = 1, N, CHUNK - BLK = MIN( N-I+1, CHUNK ) - CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ), - $ LDWRKR, A( 1, I ), LDA, ZERO, - $ WORK( IU ), LDWRKU ) - CALL DLACPY( 'F', M, BLK, WORK( IU ), LDWRKU, - $ A( 1, I ), LDA ) - 40 CONTINUE -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* 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, IERR ) -* -* Copy L to U, zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), - $ LDU ) -* -* Generate Q in A -* (Workspace: need 2*M, prefer M + M*NB) -* - CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in U -* (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) -* - 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) -* - CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), A, LDA, - $ U, LDU, DUM, 1, WORK( IWORK ), INFO ) -* - END IF -* - ELSE IF( WNTVS ) THEN -* - IF( WNTUN ) THEN -* -* Path 4t(N much larger than M, JOBU='N', JOBVT='S') -* M right singular vectors to be computed in VT and -* no left singular vectors to be computed -* - IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.WRKBL+LDA*M ) THEN -* -* WORK(IR) is LDA by M -* - LDWRKR = LDA - ELSE -* -* WORK(IR) is M by M -* - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q -* (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 ) -* -* Copy L to WORK(IR), zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), - $ LDWRKR ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IR+LDWRKR ), LDWRKR ) -* -* Generate Q in A -* (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 ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IR) -* (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 in -* WORK(IR) -* (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 ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of L in WORK(IR) -* (Workspace: need M*M + BDSPAC) -* - CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), - $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IR) by -* Q in A, storing result in VT -* (Workspace: need M*M) -* - CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ), - $ LDWRKR, A, LDA, ZERO, VT, LDVT ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* 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, IERR ) -* -* Copy result to VT -* - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (Workspace: need 2*M, prefer M + M*NB) -* - CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Zero out above L in A -* - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), - $ LDA ) -* -* Bidiagonalize L in A -* (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) -* - CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, - $ WORK( ITAUP ), VT, LDVT, - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT, - $ LDVT, DUM, 1, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTUO ) THEN -* -* Path 5t(N much larger than M, JOBU='O', JOBVT='S') -* M 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( 4*M, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+2*LDA*M ) THEN -* -* WORK(IU) is LDA by M and WORK(IR) is LDA by M -* - LDWRKU = LDA - IR = IU + LDWRKU*M - LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA + M )*M ) THEN -* -* WORK(IU) is LDA by M and WORK(IR) is M by M -* - LDWRKU = LDA - IR = IU + LDWRKU*M - LDWRKR = M - ELSE -* -* WORK(IU) is M by M and WORK(IR) is M by M -* - LDWRKU = M - IR = IU + LDWRKU*M - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q -* (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 ) -* -* Copy L to WORK(IU), zeroing out below it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IU+LDWRKU ), LDWRKU ) -* -* Generate Q in A -* (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 ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IU), copying result to -* WORK(IR) -* (Workspace: need 2*M*M + 4*M, -* prefer 2*M*M+3*M+2*M*NB) -* - CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, - $ WORK( IR ), LDWRKR ) -* -* Generate right bidiagonalizing vectors in WORK(IU) -* (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, - $ WORK( ITAUP ), WORK( IWORK ), - $ 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) -* - CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* 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) -* - CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), - $ WORK( IU ), LDWRKU, WORK( IR ), - $ LDWRKR, DUM, 1, WORK( IWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IU) by -* Q in A, storing result in VT -* (Workspace: need M*M) -* - CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), - $ LDWRKU, A, LDA, ZERO, VT, LDVT ) -* -* Copy left singular vectors of L to A -* (Workspace: need M*M) -* - CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A, - $ LDA ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (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) -* - CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Zero out above L in A -* - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), - $ LDA ) -* -* Bidiagonalize L in A -* (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) -* - 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) -* - CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, compute left -* singular vectors of A in A and compute right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, - $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTUAS ) THEN -* -* Path 6t(N much larger than M, JOBU='S' or 'A', -* JOBVT='S') -* M right singular vectors to be computed in VT and -* M left singular vectors to be computed in U -* - IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+LDA*M ) THEN -* -* WORK(IU) is LDA by N -* - LDWRKU = LDA - ELSE -* -* WORK(IU) is LDA by M -* - LDWRKU = M - END IF - ITAU = IU + LDWRKU*M - IWORK = ITAU + M -* -* Compute A=L*Q -* (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 ) -* -* Copy L to WORK(IU), zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IU+LDWRKU ), LDWRKU ) -* -* Generate Q in A -* (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 ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - 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) -* - CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U, - $ LDU ) -* -* Generate right bidiagonalizing vectors in WORK(IU) -* (Workspace: need M*M + 4*M-1, -* 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) -* - CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* 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) -* - CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), - $ WORK( IU ), LDWRKU, U, LDU, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IU) by -* Q in A, storing result in VT -* (Workspace: need M*M) -* - CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), - $ LDWRKU, A, LDA, ZERO, VT, LDVT ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (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) -* - CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to U, zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), - $ LDU ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in U -* (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 bidiagonalizing vectors in U by Q -* in VT -* (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) -* - CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, - $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - END IF -* - ELSE IF( WNTVA ) THEN -* - IF( WNTUN ) THEN -* -* Path 7t(N much larger than M, JOBU='N', JOBVT='A') -* 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 -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.WRKBL+LDA*M ) THEN -* -* WORK(IR) is LDA by M -* - LDWRKR = LDA - ELSE -* -* WORK(IR) is M by M -* - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (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 ) -* -* Copy L to WORK(IR), zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), - $ LDWRKR ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IR+LDWRKR ), LDWRKR ) -* -* Generate Q in VT -* (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 ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IR) -* (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 bidiagonalizing vectors in WORK(IR) -* (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 ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of L in WORK(IR) -* (Workspace: need M*M + BDSPAC) -* - CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), - $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IR) by -* Q in VT, storing result in A -* (Workspace: need M*M) -* - CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ), - $ LDWRKR, VT, LDVT, ZERO, A, LDA ) -* -* Copy right singular vectors of A from A to VT -* - CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (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) -* - CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Zero out above L in A -* - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), - $ LDA ) -* -* Bidiagonalize L in A -* (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 bidiagonalizing vectors in A by Q -* in VT -* (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 ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT, - $ LDVT, DUM, 1, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTUO ) THEN -* -* Path 8t(N much larger than M, JOBU='O', JOBVT='A') -* 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 -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+2*LDA*M ) THEN -* -* WORK(IU) is LDA by M and WORK(IR) is LDA by M -* - LDWRKU = LDA - IR = IU + LDWRKU*M - LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA + M )*M ) THEN -* -* WORK(IU) is LDA by M and WORK(IR) is M by M -* - LDWRKU = LDA - IR = IU + LDWRKU*M - LDWRKR = M - ELSE -* -* WORK(IU) is M by M and WORK(IR) is M by M -* - LDWRKU = M - IR = IU + LDWRKU*M - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - 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) -* - 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) -* - CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to WORK(IU), zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IU+LDWRKU ), LDWRKU ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IU), copying result to -* WORK(IR) -* (Workspace: need 2*M*M + 4*M, -* prefer 2*M*M+3*M+2*M*NB) -* - CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, - $ WORK( IR ), LDWRKR ) -* -* Generate right bidiagonalizing vectors in WORK(IU) -* (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, - $ WORK( ITAUP ), WORK( IWORK ), - $ 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) -* - CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* 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) -* - CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), - $ WORK( IU ), LDWRKU, WORK( IR ), - $ LDWRKR, DUM, 1, WORK( IWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IU) by -* Q in VT, storing result in A -* (Workspace: need M*M) -* - CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), - $ LDWRKU, VT, LDVT, ZERO, A, LDA ) -* -* Copy right singular vectors of A from A to VT -* - CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT ) -* -* Copy left singular vectors of A from WORK(IR) to A -* - CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A, - $ LDA ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (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) -* - CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Zero out above L in A -* - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), - $ LDA ) -* -* Bidiagonalize L in A -* (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 bidiagonalizing vectors in A by Q -* in VT -* (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) -* - CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in A and computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, - $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTUAS ) THEN -* -* Path 9t(N much larger than M, JOBU='S' or 'A', -* JOBVT='A') -* 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 -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+LDA*M ) THEN -* -* WORK(IU) is LDA by M -* - LDWRKU = LDA - ELSE -* -* WORK(IU) is M by M -* - LDWRKU = M - END IF - ITAU = IU + LDWRKU*M - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (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) -* - CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to WORK(IU), zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IU+LDWRKU ), LDWRKU ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - 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) -* - CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U, - $ LDU ) -* -* Generate right bidiagonalizing vectors in WORK(IU) -* (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) -* - CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* 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) -* - CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), - $ WORK( IU ), LDWRKU, U, LDU, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IU) by -* Q in VT, storing result in A -* (Workspace: need M*M) -* - CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), - $ LDWRKU, VT, LDVT, ZERO, A, LDA ) -* -* Copy right singular vectors of A from A to VT -* - CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (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) -* - CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to U, zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), - $ LDU ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in U -* (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 bidiagonalizing vectors in U by Q -* in VT -* (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) -* - CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, - $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - END IF -* - END IF -* - ELSE -* -* N .LT. MNTHR -* -* Path 10t(N greater than M, but not much larger) -* Reduce to bidiagonal form without LQ decomposition -* - 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, - $ IERR ) - IF( WNTUAS ) THEN -* -* 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) -* - CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) - CALL DORGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTVAS ) THEN -* -* 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) -* - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) - IF( WNTVA ) - $ NRVT = N - IF( WNTVS ) - $ NRVT = M - CALL DORGBR( 'P', NRVT, N, M, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTUO ) THEN -* -* If left singular vectors desired in A, generate left -* bidiagonalizing vectors in A -* (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 ) - END IF - IF( WNTVO ) THEN -* -* If right singular vectors desired in A, 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, IERR ) - END IF - IWORK = IE + M - IF( WNTUAS .OR. WNTUO ) - $ NRU = M - IF( WNTUN ) - $ NRU = 0 - IF( WNTVAS .OR. WNTVO ) - $ NCVT = N - IF( WNTVN ) - $ NCVT = 0 - IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in U and computing right singular -* vectors in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT, - $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO ) - ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in U and computing right singular -* vectors in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), A, LDA, - $ U, LDU, DUM, 1, WORK( IWORK ), INFO ) - ELSE -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in A and computing right singular -* vectors in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT, - $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO ) - END IF -* - END IF -* - END IF -* -* If DBDSQR failed to converge, copy unconverged superdiagonals -* to WORK( 2:MINMN ) -* - IF( INFO.NE.0 ) THEN - IF( IE.GT.2 ) THEN - DO 50 I = 1, MINMN - 1 - WORK( I+1 ) = WORK( I+IE-1 ) - 50 CONTINUE - END IF - IF( IE.LT.2 ) THEN - DO 60 I = MINMN - 1, 1, -1 - WORK( I+1 ) = WORK( I+IE-1 ) - 60 CONTINUE - END IF - END IF -* -* Undo scaling if necessary -* - IF( ISCL.EQ.1 ) THEN - IF( ANRM.GT.BIGNUM ) - $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, - $ IERR ) - IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM ) - $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1, WORK( 2 ), - $ MINMN, IERR ) - IF( ANRM.LT.SMLNUM ) - $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, - $ IERR ) - IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM ) - $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1, WORK( 2 ), - $ MINMN, IERR ) - END IF -* -* Return optimal workspace in WORK(1) -* - WORK( 1 ) = MAXWRK -* - RETURN -* -* End of DGESVD -* - END diff --git a/lib/linalg/fortran/dgetf2.f b/lib/linalg/fortran/dgetf2.f deleted file mode 100644 index fc1587842e..0000000000 --- a/lib/linalg/fortran/dgetf2.f +++ /dev/null @@ -1,210 +0,0 @@ -*> \brief \b DGETF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row interchanges (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGETF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGETF2 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 right-looking Level 2 BLAS version of the algorithm. -*> \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 = -k, the k-th argument had an illegal value -*> > 0: if INFO = k, U(k,k) 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. -* -*> \ingroup doubleGEcomputational -* -* ===================================================================== - SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. 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 - INTEGER I, J, JP -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - INTEGER IDAMAX - EXTERNAL DLAMCH, IDAMAX -* .. -* .. External Subroutines .. - EXTERNAL DGER, DSCAL, DSWAP, 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( 'DGETF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Compute machine safe minimum -* - SFMIN = DLAMCH('S') -* - DO 10 J = 1, MIN( M, N ) -* -* Find pivot and test for singularity. -* - JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) - IPIV( J ) = JP - IF( A( JP, J ).NE.ZERO ) THEN -* -* Apply the interchange to columns 1:N. -* - IF( JP.NE.J ) - $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) -* -* 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 -* - ELSE IF( INFO.EQ.0 ) THEN -* - INFO = J - END IF -* - IF( J.LT.MIN( M, N ) ) THEN -* -* Update trailing submatrix. -* - CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, - $ A( J+1, J+1 ), LDA ) - END IF - 10 CONTINUE - RETURN -* -* End of DGETF2 -* - END diff --git a/lib/linalg/fortran/dgetrf.f b/lib/linalg/fortran/dgetrf.f deleted file mode 100644 index 73d0f3601a..0000000000 --- a/lib/linalg/fortran/dgetrf.f +++ /dev/null @@ -1,222 +0,0 @@ -*> \brief \b DGETRF -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGETRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGETRF 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 right-looking Level 3 BLAS version of the algorithm. -*> \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. -* -*> \ingroup doubleGEcomputational -* -* ===================================================================== - SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO, J, JB, NB -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGETRF2, DLASWP, DTRSM, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. 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( 'DGETRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN -* -* Use unblocked code. -* - CALL DGETRF2( M, N, A, LDA, IPIV, INFO ) - ELSE -* -* Use blocked code. -* - DO 20 J = 1, MIN( M, N ), NB - JB = MIN( MIN( M, N )-J+1, NB ) -* -* Factor diagonal and subdiagonal blocks and test for exact -* singularity. -* - CALL DGETRF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) -* -* Adjust INFO and the pivot indices. -* - IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + J - 1 - DO 10 I = J, MIN( M, J+JB-1 ) - IPIV( I ) = J - 1 + IPIV( I ) - 10 CONTINUE -* -* Apply interchanges to columns 1:J-1. -* - CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) -* - IF( J+JB.LE.N ) THEN -* -* Apply interchanges to columns J+JB:N. -* - CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, - $ IPIV, 1 ) -* -* Compute block row of U. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, - $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), - $ LDA ) - IF( J+JB.LE.M ) THEN -* -* Update trailing submatrix. -* - CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, - $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, - $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), - $ LDA ) - END IF - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DGETRF -* - END diff --git a/lib/linalg/fortran/dgetrf2.f b/lib/linalg/fortran/dgetrf2.f deleted file mode 100644 index 40af0793dd..0000000000 --- a/lib/linalg/fortran/dgetrf2.f +++ /dev/null @@ -1,269 +0,0 @@ -*> \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. -* -*> \ingroup doubleGEcomputational -* -* ===================================================================== - RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. 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/fortran/dgetri.f b/lib/linalg/fortran/dgetri.f deleted file mode 100644 index 92ef90c186..0000000000 --- a/lib/linalg/fortran/dgetri.f +++ /dev/null @@ -1,258 +0,0 @@ -*> \brief \b DGETRI -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGETRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGETRI computes the inverse of a matrix using the LU factorization -*> computed by DGETRF. -*> -*> This method inverts U and then computes inv(A) by solving the system -*> inv(A)*L = inv(U) for inv(A). -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the factors L and U from the factorization -*> A = P*L*U as computed by DGETRF. -*> On exit, if INFO = 0, the inverse of the original matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (N) -*> The pivot indices from DGETRF; for 1<=i<=N, row i of the -*> matrix was interchanged with row IPIV(i). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO=0, then WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. LWORK >= max(1,N). -*> For optimal performance LWORK >= N*NB, where NB is -*> the optimal blocksize returned by ILAENV. -*> -*> 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: if INFO = i, U(i,i) is exactly zero; the matrix is -*> singular and its inverse could not be computed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEcomputational -* -* ===================================================================== - SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB, - $ NBMIN, NN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -3 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRI', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Form inv(U). If INFO > 0 from DTRTRI, then U is singular, -* and the inverse is not computed. -* - CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO ) - IF( INFO.GT.0 ) - $ RETURN -* - NBMIN = 2 - LDWORK = N - IF( NB.GT.1 .AND. NB.LT.N ) THEN - IWS = MAX( LDWORK*NB, 1 ) - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) ) - END IF - ELSE - IWS = N - END IF -* -* Solve the equation inv(A)*L = inv(U) for inv(A). -* - IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN -* -* Use unblocked code. -* - DO 20 J = N, 1, -1 -* -* Copy current column of L to WORK and replace with zeros. -* - DO 10 I = J + 1, N - WORK( I ) = A( I, J ) - A( I, J ) = ZERO - 10 CONTINUE -* -* Compute current column of inv(A). -* - IF( J.LT.N ) - $ CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ), - $ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 ) - 20 CONTINUE - ELSE -* -* Use blocked code. -* - NN = ( ( N-1 ) / NB )*NB + 1 - DO 50 J = NN, 1, -NB - JB = MIN( NB, N-J+1 ) -* -* Copy current block column of L to WORK and replace with -* zeros. -* - DO 40 JJ = J, J + JB - 1 - DO 30 I = JJ + 1, N - WORK( I+( JJ-J )*LDWORK ) = A( I, JJ ) - A( I, JJ ) = ZERO - 30 CONTINUE - 40 CONTINUE -* -* Compute current block column of inv(A). -* - IF( J+JB.LE.N ) - $ CALL DGEMM( 'No transpose', 'No transpose', N, JB, - $ N-J-JB+1, -ONE, A( 1, J+JB ), LDA, - $ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB, - $ ONE, WORK( J ), LDWORK, A( 1, J ), LDA ) - 50 CONTINUE - END IF -* -* Apply column interchanges. -* - DO 60 J = N - 1, 1, -1 - JP = IPIV( J ) - IF( JP.NE.J ) - $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) - 60 CONTINUE -* - WORK( 1 ) = IWS - RETURN -* -* End of DGETRI -* - END diff --git a/lib/linalg/fortran/dgetrs.f b/lib/linalg/fortran/dgetrs.f deleted file mode 100644 index d3464f685a..0000000000 --- a/lib/linalg/fortran/dgetrs.f +++ /dev/null @@ -1,222 +0,0 @@ -*> \brief \b DGETRS -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGETRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER TRANS -* INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGETRS solves a system of linear equations -*> A * X = B or A**T * X = B -*> with a general N-by-N matrix A using the LU factorization computed -*> by DGETRF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> Specifies the form of the system of equations: -*> = 'N': A * X = B (No transpose) -*> = 'T': A**T* X = B (Transpose) -*> = 'C': A**T* X = B (Conjugate transpose = Transpose) -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order 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 matrix B. NRHS >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The factors L and U from the factorization A = P*L*U -*> as computed by DGETRF. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (N) -*> The pivot indices from DGETRF; for 1<=i<=N, row i of the -*> matrix was interchanged with row IPIV(i). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) -*> On entry, the right hand side matrix B. -*> On exit, the solution matrix X. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,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. -* -*> \ingroup doubleGEcomputational -* -* ===================================================================== - SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLASWP, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) 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, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( NOTRAN ) THEN -* -* Solve A * X = B. -* -* Apply row interchanges to the right hand sides. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) -* -* Solve L*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A**T * X = B. -* -* Solve U**T *X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve L**T *X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, - $ A, LDA, B, LDB ) -* -* Apply row interchanges to the solution vectors. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) - END IF -* - RETURN -* -* End of DGETRS -* - END diff --git a/lib/linalg/fortran/disnan.f b/lib/linalg/fortran/disnan.f deleted file mode 100644 index e621b2589c..0000000000 --- a/lib/linalg/fortran/disnan.f +++ /dev/null @@ -1,77 +0,0 @@ -*> \brief \b DISNAN tests input for NaN. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DISNAN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* LOGICAL FUNCTION DISNAN( DIN ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION, INTENT(IN) :: DIN -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DISNAN returns .TRUE. if its argument is NaN, and .FALSE. -*> otherwise. To be replaced by the Fortran 2003 intrinsic in the -*> future. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] DIN -*> \verbatim -*> DIN is DOUBLE PRECISION -*> Input to test for NaN. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - LOGICAL FUNCTION DISNAN( DIN ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION, INTENT(IN) :: DIN -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL DLAISNAN - EXTERNAL DLAISNAN -* .. -* .. Executable Statements .. - DISNAN = DLAISNAN(DIN,DIN) - RETURN - END diff --git a/lib/linalg/fortran/dlabad.f b/lib/linalg/fortran/dlabad.f deleted file mode 100644 index 95b35e53b8..0000000000 --- a/lib/linalg/fortran/dlabad.f +++ /dev/null @@ -1,102 +0,0 @@ -*> \brief \b DLABAD -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLABAD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLABAD( SMALL, LARGE ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION LARGE, SMALL -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLABAD takes as input the values computed by DLAMCH for underflow and -*> overflow, and returns the square root of each of these values if the -*> log of LARGE is sufficiently large. This subroutine is intended to -*> identify machines with a large exponent range, such as the Crays, and -*> redefine the underflow and overflow limits to be the square roots of -*> the values computed by DLAMCH. This subroutine is needed because -*> DLAMCH does not compensate for poor arithmetic in the upper half of -*> the exponent range, as is found on a Cray. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in,out] SMALL -*> \verbatim -*> SMALL is DOUBLE PRECISION -*> On entry, the underflow threshold as computed by DLAMCH. -*> On exit, if LOG10(LARGE) is sufficiently large, the square -*> root of SMALL, otherwise unchanged. -*> \endverbatim -*> -*> \param[in,out] LARGE -*> \verbatim -*> LARGE is DOUBLE PRECISION -*> On entry, the overflow threshold as computed by DLAMCH. -*> On exit, if LOG10(LARGE) is sufficiently large, the square -*> root of LARGE, otherwise unchanged. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLABAD( SMALL, LARGE ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION LARGE, SMALL -* .. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC LOG10, SQRT -* .. -* .. Executable Statements .. -* -* If it looks like we're on a Cray, take the square root of -* SMALL and LARGE to avoid overflow and underflow problems. -* - IF( LOG10( LARGE ).GT.2000.D0 ) THEN - SMALL = SQRT( SMALL ) - LARGE = SQRT( LARGE ) - END IF -* - RETURN -* -* End of DLABAD -* - END diff --git a/lib/linalg/fortran/dlabrd.f b/lib/linalg/fortran/dlabrd.f deleted file mode 100644 index 86dfc10c7c..0000000000 --- a/lib/linalg/fortran/dlabrd.f +++ /dev/null @@ -1,378 +0,0 @@ -*> \brief \b DLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLABRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), -* $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLABRD reduces the first NB rows and columns of a real general -*> m by n matrix A to upper or lower bidiagonal form by an orthogonal -*> transformation Q**T * A * P, and returns the matrices X and Y which -*> are needed to apply the transformation to the unreduced part of A. -*> -*> If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower -*> bidiagonal form. -*> -*> This is an auxiliary routine called by DGEBRD -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows in the matrix A. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns in the matrix A. -*> \endverbatim -*> -*> \param[in] NB -*> \verbatim -*> NB is INTEGER -*> The number of leading rows and columns of A to be reduced. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the m by n general matrix to be reduced. -*> On exit, the first NB rows and columns of the matrix are -*> overwritten; the rest of the array is unchanged. -*> If m >= n, elements on and below the diagonal in the first NB -*> columns, with the array TAUQ, represent the orthogonal -*> matrix Q as a product of elementary reflectors; and -*> elements above the diagonal in the first NB rows, with the -*> array TAUP, represent the orthogonal matrix P as a product -*> of elementary reflectors. -*> If m < n, elements below the diagonal in the first NB -*> columns, with the array TAUQ, represent the orthogonal -*> matrix Q as a product of elementary reflectors, and -*> elements on and above the diagonal in the first NB rows, -*> with the array TAUP, represent the orthogonal matrix P as -*> a product of elementary reflectors. -*> See Further Details. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (NB) -*> The diagonal elements of the first NB rows and columns of -*> the reduced matrix. D(i) = A(i,i). -*> \endverbatim -*> -*> \param[out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (NB) -*> The off-diagonal elements of the first NB rows and columns of -*> the reduced matrix. -*> \endverbatim -*> -*> \param[out] TAUQ -*> \verbatim -*> TAUQ is DOUBLE PRECISION array, dimension (NB) -*> The scalar factors of the elementary reflectors which -*> represent the orthogonal matrix Q. See Further Details. -*> \endverbatim -*> -*> \param[out] TAUP -*> \verbatim -*> TAUP is DOUBLE PRECISION array, dimension (NB) -*> The scalar factors of the elementary reflectors which -*> represent the orthogonal matrix P. See Further Details. -*> \endverbatim -*> -*> \param[out] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension (LDX,NB) -*> The m-by-nb matrix X required to update the unreduced part -*> of A. -*> \endverbatim -*> -*> \param[in] LDX -*> \verbatim -*> LDX is INTEGER -*> The leading dimension of the array X. LDX >= max(1,M). -*> \endverbatim -*> -*> \param[out] Y -*> \verbatim -*> Y is DOUBLE PRECISION array, dimension (LDY,NB) -*> The n-by-nb matrix Y required to update the unreduced part -*> of A. -*> \endverbatim -*> -*> \param[in] LDY -*> \verbatim -*> LDY is INTEGER -*> The leading dimension of the array Y. LDY >= max(1,N). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The matrices Q and P are represented as products of elementary -*> reflectors: -*> -*> Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) -*> -*> Each H(i) and G(i) has the form: -*> -*> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T -*> -*> where tauq and taup are real scalars, and v and u are real vectors. -*> -*> If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in -*> A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in -*> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). -*> -*> If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in -*> A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in -*> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). -*> -*> The elements of the vectors v and u together form the m-by-nb matrix -*> V and the nb-by-n matrix U**T which are needed, with X and Y, to apply -*> the transformation to the unreduced part of the matrix, using a block -*> update of the form: A := A - V*Y**T - X*U**T. -*> -*> The contents of A on exit are illustrated by the following examples -*> with nb = 2: -*> -*> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): -*> -*> ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) -*> ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) -*> ( v1 v2 a a a ) ( v1 1 a a a a ) -*> ( v1 v2 a a a ) ( v1 v2 a a a a ) -*> ( v1 v2 a a a ) ( v1 v2 a a a a ) -*> ( v1 v2 a a a ) -*> -*> where a denotes an element of the original matrix which is unchanged, -*> vi denotes an element of the vector defining H(i), and ui an element -*> of the vector defining G(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, - $ LDY ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER LDA, LDX, LDY, M, N, NB -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), - $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DLARFG, DSCAL -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - IF( M.GE.N ) THEN -* -* Reduce to upper bidiagonal form -* - DO 10 I = 1, NB -* -* Update A(i:m,i) -* - CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ), - $ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 ) - CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ), - $ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 ) -* -* Generate reflection Q(i) to annihilate A(i+1:m,i) -* - CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, - $ TAUQ( I ) ) - D( I ) = A( I, I ) - IF( I.LT.N ) THEN - A( I, I ) = ONE -* -* Compute Y(i+1:n,i) -* - CALL DGEMV( 'Transpose', M-I+1, N-I, ONE, A( I, I+1 ), - $ LDA, A( I, I ), 1, ZERO, Y( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, A( I, 1 ), LDA, - $ A( I, I ), 1, ZERO, Y( 1, I ), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), - $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, X( I, 1 ), LDX, - $ A( I, I ), 1, ZERO, Y( 1, I ), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), - $ LDA, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) -* -* Update A(i,i+1:n) -* - CALL DGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ), - $ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA ) - CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), - $ LDA, X( I, 1 ), LDX, ONE, A( I, I+1 ), LDA ) -* -* Generate reflection P(i) to annihilate A(i,i+2:n) -* - CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), - $ LDA, TAUP( I ) ) - E( I ) = A( I, I+1 ) - A( I, I+1 ) = ONE -* -* Compute X(i+1:m,i) -* - CALL DGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ), - $ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, Y( I+1, 1 ), LDY, - $ A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ), - $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), - $ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), - $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) - END IF - 10 CONTINUE - ELSE -* -* Reduce to lower bidiagonal form -* - DO 20 I = 1, NB -* -* Update A(i,i:n) -* - CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ), - $ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA ) - CALL DGEMV( 'Transpose', I-1, N-I+1, -ONE, A( 1, I ), LDA, - $ X( I, 1 ), LDX, ONE, A( I, I ), LDA ) -* -* Generate reflection P(i) to annihilate A(i,i+1:n) -* - CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, - $ TAUP( I ) ) - D( I ) = A( I, I ) - IF( I.LT.M ) THEN - A( I, I ) = ONE -* -* Compute X(i+1:m,i) -* - CALL DGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ), - $ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Y( I, 1 ), LDY, - $ A( I, I ), LDA, ZERO, X( 1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), - $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ), - $ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), - $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) -* -* Update A(i+1:m,i) -* - CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), - $ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ), - $ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 ) -* -* Generate reflection Q(i) to annihilate A(i+2:m,i) -* - CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, - $ TAUQ( I ) ) - E( I ) = A( I+1, I ) - A( I+1, I ) = ONE -* -* Compute Y(i+1:n,i) -* - CALL DGEMV( 'Transpose', M-I, N-I, ONE, A( I+1, I+1 ), - $ LDA, A( I+1, I ), 1, ZERO, Y( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', M-I, I-1, ONE, A( I+1, 1 ), LDA, - $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), - $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', M-I, I, ONE, X( I+1, 1 ), LDX, - $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 ) - CALL DGEMV( 'Transpose', I, N-I, -ONE, A( 1, I+1 ), LDA, - $ Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DLABRD -* - END diff --git a/lib/linalg/fortran/dlacn2.f b/lib/linalg/fortran/dlacn2.f deleted file mode 100644 index ee2e7ca266..0000000000 --- a/lib/linalg/fortran/dlacn2.f +++ /dev/null @@ -1,304 +0,0 @@ -*> \brief \b DLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLACN2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) -* -* .. Scalar Arguments .. -* INTEGER KASE, N -* DOUBLE PRECISION EST -* .. -* .. Array Arguments .. -* INTEGER ISGN( * ), ISAVE( 3 ) -* DOUBLE PRECISION V( * ), X( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLACN2 estimates the 1-norm of a square, real matrix A. -*> Reverse communication is used for evaluating matrix-vector products. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix. N >= 1. -*> \endverbatim -*> -*> \param[out] V -*> \verbatim -*> V is DOUBLE PRECISION array, dimension (N) -*> On the final return, V = A*W, where EST = norm(V)/norm(W) -*> (W is not returned). -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension (N) -*> On an intermediate return, X should be overwritten by -*> A * X, if KASE=1, -*> A**T * X, if KASE=2, -*> and DLACN2 must be re-called with all the other parameters -*> unchanged. -*> \endverbatim -*> -*> \param[out] ISGN -*> \verbatim -*> ISGN is INTEGER array, dimension (N) -*> \endverbatim -*> -*> \param[in,out] EST -*> \verbatim -*> 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). -*> \endverbatim -*> -*> \param[in,out] KASE -*> \verbatim -*> KASE is INTEGER -*> On the initial call to DLACN2, KASE should be 0. -*> On an intermediate return, KASE will be 1 or 2, indicating -*> whether X should be overwritten by A * X or A**T * X. -*> On the final return from DLACN2, KASE will again be 0. -*> \endverbatim -*> -*> \param[in,out] ISAVE -*> \verbatim -*> ISAVE is INTEGER array, dimension (3) -*> ISAVE is used to save variables between calls to DLACN2 -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Originally named SONEST, dated March 16, 1988. -*> -*> This is a thread safe version of DLACON, which uses the array ISAVE -*> in place of a SAVE statement, as follows: -*> -*> DLACON DLACN2 -*> JUMP ISAVE(1) -*> J ISAVE(2) -*> ITER ISAVE(3) -*> \endverbatim -* -*> \par Contributors: -* ================== -*> -*> Nick Higham, University of Manchester -* -*> \par References: -* ================ -*> -*> N.J. Higham, "FORTRAN codes for estimating the one-norm of -*> a real or complex matrix, with applications to condition estimation", -*> ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. -*> -* ===================================================================== - SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER KASE, N - DOUBLE PRECISION EST -* .. -* .. Array Arguments .. - INTEGER ISGN( * ), ISAVE( 3 ) - DOUBLE PRECISION V( * ), X( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER ITMAX - PARAMETER ( ITMAX = 5 ) - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, JLAST - DOUBLE PRECISION ALTSGN, ESTOLD, TEMP, XS -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DASUM - EXTERNAL IDAMAX, DASUM -* .. -* .. External Subroutines .. - EXTERNAL DCOPY -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, NINT -* .. -* .. Executable Statements .. -* - IF( KASE.EQ.0 ) THEN - DO 10 I = 1, N - X( I ) = ONE / DBLE( N ) - 10 CONTINUE - KASE = 1 - ISAVE( 1 ) = 1 - RETURN - END IF -* - GO TO ( 20, 40, 70, 110, 140 )ISAVE( 1 ) -* -* ................ ENTRY (ISAVE( 1 ) = 1) -* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. -* - 20 CONTINUE - IF( N.EQ.1 ) THEN - V( 1 ) = X( 1 ) - EST = ABS( V( 1 ) ) -* ... QUIT - GO TO 150 - END IF - EST = DASUM( N, X, 1 ) -* - DO 30 I = 1, N - IF( X(I).GE.ZERO ) THEN - X(I) = ONE - ELSE - X(I) = -ONE - END IF - ISGN( I ) = NINT( X( I ) ) - 30 CONTINUE - KASE = 2 - ISAVE( 1 ) = 2 - RETURN -* -* ................ ENTRY (ISAVE( 1 ) = 2) -* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. -* - 40 CONTINUE - ISAVE( 2 ) = IDAMAX( N, X, 1 ) - ISAVE( 3 ) = 2 -* -* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. -* - 50 CONTINUE - DO 60 I = 1, N - X( I ) = ZERO - 60 CONTINUE - X( ISAVE( 2 ) ) = ONE - KASE = 1 - ISAVE( 1 ) = 3 - RETURN -* -* ................ ENTRY (ISAVE( 1 ) = 3) -* X HAS BEEN OVERWRITTEN BY A*X. -* - 70 CONTINUE - CALL DCOPY( N, X, 1, V, 1 ) - ESTOLD = EST - EST = DASUM( N, V, 1 ) - DO 80 I = 1, N - IF( X(I).GE.ZERO ) THEN - XS = ONE - ELSE - XS = -ONE - END IF - IF( NINT( XS ).NE.ISGN( I ) ) - $ GO TO 90 - 80 CONTINUE -* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. - GO TO 120 -* - 90 CONTINUE -* TEST FOR CYCLING. - IF( EST.LE.ESTOLD ) - $ GO TO 120 -* - DO 100 I = 1, N - IF( X(I).GE.ZERO ) THEN - X(I) = ONE - ELSE - X(I) = -ONE - END IF - ISGN( I ) = NINT( X( I ) ) - 100 CONTINUE - KASE = 2 - ISAVE( 1 ) = 4 - RETURN -* -* ................ ENTRY (ISAVE( 1 ) = 4) -* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. -* - 110 CONTINUE - JLAST = ISAVE( 2 ) - ISAVE( 2 ) = IDAMAX( N, X, 1 ) - IF( ( X( JLAST ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND. - $ ( ISAVE( 3 ).LT.ITMAX ) ) THEN - ISAVE( 3 ) = ISAVE( 3 ) + 1 - GO TO 50 - END IF -* -* ITERATION COMPLETE. FINAL STAGE. -* - 120 CONTINUE - ALTSGN = ONE - DO 130 I = 1, N - X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) - ALTSGN = -ALTSGN - 130 CONTINUE - KASE = 1 - ISAVE( 1 ) = 5 - RETURN -* -* ................ ENTRY (ISAVE( 1 ) = 5) -* X HAS BEEN OVERWRITTEN BY A*X. -* - 140 CONTINUE - TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) ) - IF( TEMP.GT.EST ) THEN - CALL DCOPY( N, X, 1, V, 1 ) - EST = TEMP - END IF -* - 150 CONTINUE - KASE = 0 - RETURN -* -* End of DLACN2 -* - END diff --git a/lib/linalg/fortran/dlacpy.f b/lib/linalg/fortran/dlacpy.f deleted file mode 100644 index 917aa1e2a2..0000000000 --- a/lib/linalg/fortran/dlacpy.f +++ /dev/null @@ -1,153 +0,0 @@ -*> \brief \b DLACPY copies all or part of one two-dimensional array to another. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLACPY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER LDA, LDB, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLACPY copies all or part of a two-dimensional matrix A to another -*> matrix B. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies the part of the matrix A to be copied to B. -*> = 'U': Upper triangular part -*> = 'L': Lower triangular part -*> Otherwise: All of the matrix A -*> \endverbatim -*> -*> \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] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The m by n matrix A. If UPLO = 'U', only the upper triangle -*> or trapezoid is accessed; if UPLO = 'L', only the lower -*> triangle or trapezoid is accessed. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,N) -*> On exit, B = A in the locations specified by UPLO. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDB, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( LSAME( UPLO, 'U' ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, MIN( J, M ) - B( I, J ) = A( I, J ) - 10 CONTINUE - 20 CONTINUE - ELSE IF( LSAME( UPLO, 'L' ) ) THEN - DO 40 J = 1, N - DO 30 I = J, M - B( I, J ) = A( I, J ) - 30 CONTINUE - 40 CONTINUE - ELSE - DO 60 J = 1, N - DO 50 I = 1, M - B( I, J ) = A( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF - RETURN -* -* End of DLACPY -* - END diff --git a/lib/linalg/fortran/dladiv.f b/lib/linalg/fortran/dladiv.f deleted file mode 100644 index 4265618fed..0000000000 --- a/lib/linalg/fortran/dladiv.f +++ /dev/null @@ -1,251 +0,0 @@ -*> \brief \b DLADIV performs complex division in real arithmetic, avoiding unnecessary overflow. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLADIV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLADIV( A, B, C, D, P, Q ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION A, B, C, D, P, Q -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLADIV performs complex division in real arithmetic -*> -*> a + i*b -*> p + i*q = --------- -*> c + i*d -*> -*> The algorithm is due to Michael Baudin and Robert L. Smith -*> and can be found in the paper -*> "A Robust Complex Division in Scilab" -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] C -*> \verbatim -*> C is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] D -*> \verbatim -*> D is DOUBLE PRECISION -*> The scalars a, b, c, and d in the above expression. -*> \endverbatim -*> -*> \param[out] P -*> \verbatim -*> P is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[out] Q -*> \verbatim -*> Q is DOUBLE PRECISION -*> The scalars p and q in the above expression. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLADIV( A, B, C, D, P, Q ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION A, B, C, D, P, Q -* .. -* -* ===================================================================== -* -* .. 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 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, MAX -* .. -* .. Executable Statements .. -* - 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 -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. 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 -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. 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 DLADIV2 -* - END diff --git a/lib/linalg/fortran/dlae2.f b/lib/linalg/fortran/dlae2.f deleted file mode 100644 index a0e3971b41..0000000000 --- a/lib/linalg/fortran/dlae2.f +++ /dev/null @@ -1,182 +0,0 @@ -*> \brief \b DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAE2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION A, B, C, RT1, RT2 -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix -*> [ A B ] -*> [ B C ]. -*> On return, RT1 is the eigenvalue of larger absolute value, and RT2 -*> is the eigenvalue of smaller absolute value. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION -*> The (1,1) element of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION -*> The (1,2) and (2,1) elements of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[in] C -*> \verbatim -*> C is DOUBLE PRECISION -*> The (2,2) element of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[out] RT1 -*> \verbatim -*> RT1 is DOUBLE PRECISION -*> The eigenvalue of larger absolute value. -*> \endverbatim -*> -*> \param[out] RT2 -*> \verbatim -*> RT2 is DOUBLE PRECISION -*> The eigenvalue of smaller absolute value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> RT1 is accurate to a few ulps barring over/underflow. -*> -*> RT2 may be inaccurate if there is massive cancellation in the -*> determinant A*C-B*B; higher precision or correctly rounded or -*> correctly truncated arithmetic would be needed to compute RT2 -*> accurately in all cases. -*> -*> Overflow is possible only if RT1 is within a factor of 5 of overflow. -*> Underflow is harmless if the input data is 0 or exceeds -*> underflow_threshold / macheps. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION A, B, C, RT1, RT2 -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION HALF - PARAMETER ( HALF = 0.5D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION AB, ACMN, ACMX, ADF, DF, RT, SM, TB -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. -* -* Compute the eigenvalues -* - SM = A + C - DF = A - C - ADF = ABS( DF ) - TB = B + B - AB = ABS( TB ) - IF( ABS( A ).GT.ABS( C ) ) THEN - ACMX = A - ACMN = C - ELSE - ACMX = C - ACMN = A - END IF - IF( ADF.GT.AB ) THEN - RT = ADF*SQRT( ONE+( AB / ADF )**2 ) - ELSE IF( ADF.LT.AB ) THEN - RT = AB*SQRT( ONE+( ADF / AB )**2 ) - ELSE -* -* Includes case AB=ADF=0 -* - RT = AB*SQRT( TWO ) - END IF - IF( SM.LT.ZERO ) THEN - RT1 = HALF*( SM-RT ) -* -* Order of execution important. -* To get fully accurate smaller eigenvalue, -* next line needs to be executed in higher precision. -* - RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B - ELSE IF( SM.GT.ZERO ) THEN - RT1 = HALF*( SM+RT ) -* -* Order of execution important. -* To get fully accurate smaller eigenvalue, -* next line needs to be executed in higher precision. -* - RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B - ELSE -* -* Includes case RT1 = RT2 = 0 -* - RT1 = HALF*RT - RT2 = -HALF*RT - END IF - RETURN -* -* End of DLAE2 -* - END diff --git a/lib/linalg/fortran/dlaed0.f b/lib/linalg/fortran/dlaed0.f deleted file mode 100644 index fe3b6249e9..0000000000 --- a/lib/linalg/fortran/dlaed0.f +++ /dev/null @@ -1,431 +0,0 @@ -*> \brief \b DLAED0 used by DSTEDC. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmetric tridiagonal matrix using the divide and conquer method. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAED0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* INTEGER IWORK( * ) -* DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ), -* $ WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAED0 computes all eigenvalues and corresponding eigenvectors of a -*> symmetric tridiagonal matrix using the divide and conquer method. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ICOMPQ -*> \verbatim -*> ICOMPQ is INTEGER -*> = 0: Compute eigenvalues only. -*> = 1: Compute eigenvectors of original dense symmetric matrix -*> also. On entry, Q contains the orthogonal matrix used -*> to reduce the original matrix to tridiagonal form. -*> = 2: Compute eigenvalues and eigenvectors of tridiagonal -*> matrix. -*> \endverbatim -*> -*> \param[in] QSIZ -*> \verbatim -*> QSIZ is INTEGER -*> The dimension of the orthogonal matrix used to reduce -*> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the main diagonal of the tridiagonal matrix. -*> On exit, its eigenvalues. -*> \endverbatim -*> -*> \param[in] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> The off-diagonal elements of the tridiagonal matrix. -*> On exit, E has been destroyed. -*> \endverbatim -*> -*> \param[in,out] Q -*> \verbatim -*> Q is DOUBLE PRECISION array, dimension (LDQ, N) -*> On entry, Q must contain an N-by-N orthogonal matrix. -*> If ICOMPQ = 0 Q is not referenced. -*> If ICOMPQ = 1 On entry, Q is a subset of the columns of the -*> orthogonal matrix used to reduce the full -*> matrix to tridiagonal form corresponding to -*> the subset of the full matrix which is being -*> decomposed at this time. -*> If ICOMPQ = 2 On entry, Q will be the identity matrix. -*> On exit, Q contains the eigenvectors of the -*> tridiagonal matrix. -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. If eigenvectors are -*> desired, then LDQ >= max(1,N). In any case, LDQ >= 1. -*> \endverbatim -*> -*> \param[out] QSTORE -*> \verbatim -*> QSTORE is DOUBLE PRECISION array, dimension (LDQS, N) -*> Referenced only when ICOMPQ = 1. Used to store parts of -*> the eigenvector matrix when the updating matrix multiplies -*> take place. -*> \endverbatim -*> -*> \param[in] LDQS -*> \verbatim -*> LDQS is INTEGER -*> The leading dimension of the array QSTORE. If ICOMPQ = 1, -*> then LDQS >= max(1,N). In any case, LDQS >= 1. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, -*> If ICOMPQ = 0 or 1, the dimension of WORK must be at least -*> 1 + 3*N + 2*N*lg N + 3*N**2 -*> ( lg( N ) = smallest integer k -*> such that 2^k >= N ) -*> If ICOMPQ = 2, the dimension of WORK must be at least -*> 4*N + N**2. -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, -*> If ICOMPQ = 0 or 1, the dimension of IWORK must be at least -*> 6 + 6*N + 5*N*lg N. -*> ( lg( N ) = smallest integer k -*> such that 2^k >= N ) -*> If ICOMPQ = 2, the dimension of IWORK must be at least -*> 3 + 5*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 an eigenvalue 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. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA -* -* ===================================================================== - SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, - $ WORK, IWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ), - $ WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0 ) -* .. -* .. Local Scalars .. - INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM, - $ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM, - $ J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1, - $ SPM2, SUBMAT, SUBPBS, TLVLS - DOUBLE PRECISION TEMP -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DLACPY, DLAED1, DLAED7, DSTEQR, - $ XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, LOG, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.2 ) THEN - INFO = -1 - ELSE IF( ( ICOMPQ.EQ.1 ) .AND. ( QSIZ.LT.MAX( 0, N ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAED0', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - SMLSIZ = ILAENV( 9, 'DLAED0', ' ', 0, 0, 0, 0 ) -* -* Determine the size and placement of the submatrices, and save in -* the leading elements of IWORK. -* - IWORK( 1 ) = N - SUBPBS = 1 - TLVLS = 0 - 10 CONTINUE - IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN - DO 20 J = SUBPBS, 1, -1 - IWORK( 2*J ) = ( IWORK( J )+1 ) / 2 - IWORK( 2*J-1 ) = IWORK( J ) / 2 - 20 CONTINUE - TLVLS = TLVLS + 1 - SUBPBS = 2*SUBPBS - GO TO 10 - END IF - DO 30 J = 2, SUBPBS - IWORK( J ) = IWORK( J ) + IWORK( J-1 ) - 30 CONTINUE -* -* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 -* using rank-1 modifications (cuts). -* - SPM1 = SUBPBS - 1 - DO 40 I = 1, SPM1 - SUBMAT = IWORK( I ) + 1 - SMM1 = SUBMAT - 1 - D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) ) - D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) ) - 40 CONTINUE -* - INDXQ = 4*N + 3 - IF( ICOMPQ.NE.2 ) THEN -* -* Set up workspaces for eigenvalues only/accumulate new vectors -* routine -* - TEMP = LOG( DBLE( N ) ) / LOG( TWO ) - LGN = INT( TEMP ) - IF( 2**LGN.LT.N ) - $ LGN = LGN + 1 - IF( 2**LGN.LT.N ) - $ LGN = LGN + 1 - IPRMPT = INDXQ + N + 1 - IPERM = IPRMPT + N*LGN - IQPTR = IPERM + N*LGN - IGIVPT = IQPTR + N + 2 - IGIVCL = IGIVPT + N*LGN -* - IGIVNM = 1 - IQ = IGIVNM + 2*N*LGN - IWREM = IQ + N**2 + 1 -* -* Initialize pointers -* - DO 50 I = 0, SUBPBS - IWORK( IPRMPT+I ) = 1 - IWORK( IGIVPT+I ) = 1 - 50 CONTINUE - IWORK( IQPTR ) = 1 - END IF -* -* Solve each submatrix eigenproblem at the bottom of the divide and -* conquer tree. -* - CURR = 0 - DO 70 I = 0, SPM1 - IF( I.EQ.0 ) THEN - SUBMAT = 1 - MATSIZ = IWORK( 1 ) - ELSE - SUBMAT = IWORK( I ) + 1 - MATSIZ = IWORK( I+1 ) - IWORK( I ) - END IF - IF( ICOMPQ.EQ.2 ) THEN - CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ), - $ Q( SUBMAT, SUBMAT ), LDQ, WORK, INFO ) - IF( INFO.NE.0 ) - $ GO TO 130 - ELSE - CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ), - $ WORK( IQ-1+IWORK( IQPTR+CURR ) ), MATSIZ, WORK, - $ INFO ) - IF( INFO.NE.0 ) - $ GO TO 130 - IF( ICOMPQ.EQ.1 ) THEN - CALL DGEMM( 'N', 'N', QSIZ, MATSIZ, MATSIZ, ONE, - $ Q( 1, SUBMAT ), LDQ, WORK( IQ-1+IWORK( IQPTR+ - $ CURR ) ), MATSIZ, ZERO, QSTORE( 1, SUBMAT ), - $ LDQS ) - END IF - IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2 - CURR = CURR + 1 - END IF - K = 1 - DO 60 J = SUBMAT, IWORK( I+1 ) - IWORK( INDXQ+J ) = K - K = K + 1 - 60 CONTINUE - 70 CONTINUE -* -* Successively merge eigensystems of adjacent submatrices -* into eigensystem for the corresponding larger matrix. -* -* while ( SUBPBS > 1 ) -* - CURLVL = 1 - 80 CONTINUE - IF( SUBPBS.GT.1 ) THEN - SPM2 = SUBPBS - 2 - DO 90 I = 0, SPM2, 2 - IF( I.EQ.0 ) THEN - SUBMAT = 1 - MATSIZ = IWORK( 2 ) - MSD2 = IWORK( 1 ) - CURPRB = 0 - ELSE - SUBMAT = IWORK( I ) + 1 - MATSIZ = IWORK( I+2 ) - IWORK( I ) - MSD2 = MATSIZ / 2 - CURPRB = CURPRB + 1 - END IF -* -* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) -* into an eigensystem of size MATSIZ. -* DLAED1 is used only for the full eigensystem of a tridiagonal -* matrix. -* DLAED7 handles the cases in which eigenvalues only or eigenvalues -* and eigenvectors of a full symmetric matrix (which was reduced to -* tridiagonal form) are desired. -* - IF( ICOMPQ.EQ.2 ) THEN - CALL DLAED1( MATSIZ, D( SUBMAT ), Q( SUBMAT, SUBMAT ), - $ LDQ, IWORK( INDXQ+SUBMAT ), - $ E( SUBMAT+MSD2-1 ), MSD2, WORK, - $ IWORK( SUBPBS+1 ), INFO ) - ELSE - CALL DLAED7( ICOMPQ, MATSIZ, QSIZ, TLVLS, CURLVL, CURPRB, - $ D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS, - $ IWORK( INDXQ+SUBMAT ), E( SUBMAT+MSD2-1 ), - $ MSD2, WORK( IQ ), IWORK( IQPTR ), - $ IWORK( IPRMPT ), IWORK( IPERM ), - $ IWORK( IGIVPT ), IWORK( IGIVCL ), - $ WORK( IGIVNM ), WORK( IWREM ), - $ IWORK( SUBPBS+1 ), INFO ) - END IF - IF( INFO.NE.0 ) - $ GO TO 130 - IWORK( I / 2+1 ) = IWORK( I+2 ) - 90 CONTINUE - SUBPBS = SUBPBS / 2 - CURLVL = CURLVL + 1 - GO TO 80 - END IF -* -* end while -* -* Re-merge the eigenvalues/vectors which were deflated at the final -* merge step. -* - IF( ICOMPQ.EQ.1 ) THEN - DO 100 I = 1, N - J = IWORK( INDXQ+I ) - WORK( I ) = D( J ) - CALL DCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 ) - 100 CONTINUE - CALL DCOPY( N, WORK, 1, D, 1 ) - ELSE IF( ICOMPQ.EQ.2 ) THEN - DO 110 I = 1, N - J = IWORK( INDXQ+I ) - WORK( I ) = D( J ) - CALL DCOPY( N, Q( 1, J ), 1, WORK( N*I+1 ), 1 ) - 110 CONTINUE - CALL DCOPY( N, WORK, 1, D, 1 ) - CALL DLACPY( 'A', N, N, WORK( N+1 ), N, Q, LDQ ) - ELSE - DO 120 I = 1, N - J = IWORK( INDXQ+I ) - WORK( I ) = D( J ) - 120 CONTINUE - CALL DCOPY( N, WORK, 1, D, 1 ) - END IF - GO TO 140 -* - 130 CONTINUE - INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1 -* - 140 CONTINUE - RETURN -* -* End of DLAED0 -* - END diff --git a/lib/linalg/fortran/dlaed1.f b/lib/linalg/fortran/dlaed1.f deleted file mode 100644 index 3718139c14..0000000000 --- a/lib/linalg/fortran/dlaed1.f +++ /dev/null @@ -1,271 +0,0 @@ -*> \brief \b DLAED1 used by DSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is tridiagonal. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAED1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, -* INFO ) -* -* .. Scalar Arguments .. -* INTEGER CUTPNT, INFO, LDQ, N -* DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. -* INTEGER INDXQ( * ), IWORK( * ) -* DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAED1 computes the updated eigensystem of a diagonal -*> matrix after modification by a rank-one symmetric matrix. This -*> routine is used only for the eigenproblem which requires all -*> eigenvalues and eigenvectors of a tridiagonal matrix. DLAED7 handles -*> the case in which eigenvalues only or eigenvalues and eigenvectors -*> of a full symmetric matrix (which was reduced to tridiagonal form) -*> are desired. -*> -*> T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out) -*> -*> where Z = Q**T*u, u is a vector of length N with ones in the -*> CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. -*> -*> The eigenvectors of the original matrix are stored in Q, and the -*> eigenvalues are in D. The algorithm consists of three stages: -*> -*> 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 occurrence the dimension of the -*> secular equation problem is reduced by one. This stage is -*> performed by the routine DLAED2. -*> -*> The second stage consists of calculating the updated -*> eigenvalues. This is done by finding the roots of the secular -*> equation via the routine DLAED4 (as called by DLAED3). -*> This routine also calculates the eigenvectors of the current -*> problem. -*> -*> The final stage consists of computing the updated eigenvectors -*> directly using the updated eigenvalues. The eigenvectors for -*> the current problem are multiplied with the eigenvectors from -*> the overall problem. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the eigenvalues of the rank-1-perturbed matrix. -*> On exit, the eigenvalues of the repaired matrix. -*> \endverbatim -*> -*> \param[in,out] Q -*> \verbatim -*> Q is DOUBLE PRECISION array, dimension (LDQ,N) -*> On entry, the eigenvectors of the rank-1-perturbed matrix. -*> On exit, the eigenvectors of the repaired tridiagonal matrix. -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max(1,N). -*> \endverbatim -*> -*> \param[in,out] INDXQ -*> \verbatim -*> INDXQ is INTEGER array, dimension (N) -*> On entry, the permutation which separately sorts the two -*> subproblems in D into ascending order. -*> On exit, the permutation which will reintegrate the -*> subproblems back into sorted order, -*> i.e. D( INDXQ( I = 1, N ) ) will be in ascending order. -*> \endverbatim -*> -*> \param[in] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> The subdiagonal entry used to create the rank-1 modification. -*> \endverbatim -*> -*> \param[in] CUTPNT -*> \verbatim -*> CUTPNT is INTEGER -*> The location of the last eigenvalue in the leading sub-matrix. -*> min(1,N) <= CUTPNT <= N/2. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (4*N + N**2) -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (4*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, an eigenvalue did not converge -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA \n -*> Modified by Francoise Tisseur, University of Tennessee -*> -* ===================================================================== - SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, - $ INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER CUTPNT, INFO, LDQ, N - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - INTEGER INDXQ( * ), IWORK( * ) - DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER COLTYP, I, IDLMDA, INDX, INDXC, INDXP, IQ2, IS, - $ IW, IZ, K, N1, N2, ZPP1 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLAED2, DLAED3, DLAMRG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( MIN( 1, N / 2 ).GT.CUTPNT .OR. ( N / 2 ).LT.CUTPNT ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAED1', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* The following values are integer pointers which indicate -* the portion of the workspace -* used by a particular array in DLAED2 and DLAED3. -* - IZ = 1 - IDLMDA = IZ + N - IW = IDLMDA + N - IQ2 = IW + N -* - INDX = 1 - INDXC = INDX + N - COLTYP = INDXC + N - INDXP = COLTYP + N -* -* -* Form the z-vector which consists of the last row of Q_1 and the -* first row of Q_2. -* - CALL DCOPY( CUTPNT, Q( CUTPNT, 1 ), LDQ, WORK( IZ ), 1 ) - ZPP1 = CUTPNT + 1 - CALL DCOPY( N-CUTPNT, Q( ZPP1, ZPP1 ), LDQ, WORK( IZ+CUTPNT ), 1 ) -* -* Deflate eigenvalues. -* - CALL DLAED2( K, N, CUTPNT, D, Q, LDQ, INDXQ, RHO, WORK( IZ ), - $ WORK( IDLMDA ), WORK( IW ), WORK( IQ2 ), - $ IWORK( INDX ), IWORK( INDXC ), IWORK( INDXP ), - $ IWORK( COLTYP ), INFO ) -* - IF( INFO.NE.0 ) - $ GO TO 20 -* -* Solve Secular Equation. -* - IF( K.NE.0 ) THEN - IS = ( IWORK( COLTYP )+IWORK( COLTYP+1 ) )*CUTPNT + - $ ( IWORK( COLTYP+1 )+IWORK( COLTYP+2 ) )*( N-CUTPNT ) + IQ2 - CALL DLAED3( K, N, CUTPNT, D, Q, LDQ, RHO, WORK( IDLMDA ), - $ WORK( IQ2 ), IWORK( INDXC ), IWORK( COLTYP ), - $ WORK( IW ), WORK( IS ), INFO ) - IF( INFO.NE.0 ) - $ GO TO 20 -* -* Prepare the INDXQ sorting permutation. -* - N1 = K - N2 = N - K - CALL DLAMRG( N1, N2, D, 1, -1, INDXQ ) - ELSE - DO 10 I = 1, N - INDXQ( I ) = I - 10 CONTINUE - END IF -* - 20 CONTINUE - RETURN -* -* End of DLAED1 -* - END diff --git a/lib/linalg/fortran/dlaed2.f b/lib/linalg/fortran/dlaed2.f deleted file mode 100644 index 9b1f1e0930..0000000000 --- a/lib/linalg/fortran/dlaed2.f +++ /dev/null @@ -1,536 +0,0 @@ -*> \brief \b DLAED2 used by DSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matrix is tridiagonal. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAED2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ), -* $ INDXQ( * ) -* DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), -* $ W( * ), Z( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAED2 merges the two sets of eigenvalues 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 -*> eigenvalues 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. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[out] K -*> \verbatim -*> K is INTEGER -*> The number of non-deflated eigenvalues, and the order of the -*> related secular equation. 0 <= K <=N. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in] N1 -*> \verbatim -*> N1 is INTEGER -*> The location of the last eigenvalue in the leading sub-matrix. -*> min(1,N) <= N1 <= N/2. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, D contains the eigenvalues of the two submatrices to -*> be combined. -*> On exit, D contains the trailing (N-K) updated eigenvalues -*> (those which were deflated) sorted into increasing order. -*> \endverbatim -*> -*> \param[in,out] Q -*> \verbatim -*> Q is DOUBLE PRECISION array, dimension (LDQ, N) -*> On entry, Q contains the eigenvectors of two submatrices in -*> the two square blocks with corners at (1,1), (N1,N1) -*> and (N1+1, N1+1), (N,N). -*> On exit, Q contains the trailing (N-K) updated eigenvectors -*> (those which were deflated) in its last N-K columns. -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max(1,N). -*> \endverbatim -*> -*> \param[in,out] INDXQ -*> \verbatim -*> INDXQ is INTEGER array, dimension (N) -*> The permutation which separately sorts the two sub-problems -*> in D into ascending order. Note that elements in the second -*> half of this permutation must first have N1 added to their -*> values. Destroyed on exit. -*> \endverbatim -*> -*> \param[in,out] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> On entry, the off-diagonal element associated with the rank-1 -*> cut which originally split the two submatrices which are now -*> being recombined. -*> On exit, RHO has been modified to the value required by -*> DLAED3. -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (N) -*> On entry, Z contains the updating vector (the last -*> row of the first sub-eigenvector matrix and the first row of -*> the second sub-eigenvector matrix). -*> On exit, the contents of Z have been destroyed by the updating -*> process. -*> \endverbatim -*> -*> \param[out] DLAMDA -*> \verbatim -*> DLAMDA is DOUBLE PRECISION array, dimension (N) -*> A copy of the first K eigenvalues which will be used by -*> DLAED3 to form the secular equation. -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (N) -*> The first k values of the final deflation-altered z-vector -*> which will be passed to DLAED3. -*> \endverbatim -*> -*> \param[out] Q2 -*> \verbatim -*> Q2 is DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2) -*> A copy of the first K eigenvectors which will be used by -*> DLAED3 in a matrix multiply (DGEMM) to solve for the new -*> eigenvectors. -*> \endverbatim -*> -*> \param[out] INDX -*> \verbatim -*> INDX is INTEGER array, dimension (N) -*> The permutation used to sort the contents of DLAMDA into -*> ascending order. -*> \endverbatim -*> -*> \param[out] INDXC -*> \verbatim -*> INDXC is INTEGER array, dimension (N) -*> The permutation used to arrange the columns of the deflated -*> Q matrix into three groups: the first group contains non-zero -*> elements only at and above N1, the second contains -*> non-zero elements only below N1, and the third is dense. -*> \endverbatim -*> -*> \param[out] INDXP -*> \verbatim -*> INDXP is INTEGER array, dimension (N) -*> The permutation used to place deflated values of D at the end -*> of the array. INDXP(1:K) points to the nondeflated D-values -*> and INDXP(K+1:N) points to the deflated eigenvalues. -*> \endverbatim -*> -*> \param[out] COLTYP -*> \verbatim -*> COLTYP is INTEGER array, dimension (N) -*> During execution, a label which will indicate which of the -*> following types a column in the Q2 matrix is: -*> 1 : non-zero in the upper half only; -*> 2 : dense; -*> 3 : non-zero in the lower half only; -*> 4 : deflated. -*> On exit, COLTYP(i) is the number of columns of type i, -*> for i=1 to 4 only. -*> \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. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA \n -*> Modified by Francoise Tisseur, University of Tennessee -*> -* ===================================================================== - SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, - $ Q2, INDX, INDXC, INDXP, COLTYP, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDQ, N, N1 - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ), - $ INDXQ( * ) - DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), - $ W( * ), Z( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT - PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0, - $ TWO = 2.0D0, EIGHT = 8.0D0 ) -* .. -* .. Local Arrays .. - INTEGER CTOT( 4 ), PSM( 4 ) -* .. -* .. Local Scalars .. - INTEGER CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1, - $ N2, NJ, PJ - DOUBLE PRECISION C, EPS, S, T, TAU, TOL -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DLAPY2 - EXTERNAL IDAMAX, DLAMCH, DLAPY2 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( MIN( 1, ( N / 2 ) ).GT.N1 .OR. ( N / 2 ).LT.N1 ) THEN - INFO = -3 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAED2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - N2 = N - N1 - N1P1 = N1 + 1 -* - IF( RHO.LT.ZERO ) THEN - CALL DSCAL( N2, MONE, Z( N1P1 ), 1 ) - END IF -* -* Normalize z so that norm(z) = 1. Since z is the concatenation of -* two normalized vectors, norm2(z) = sqrt(2). -* - T = ONE / SQRT( TWO ) - CALL DSCAL( N, T, Z, 1 ) -* -* RHO = ABS( norm(z)**2 * RHO ) -* - RHO = ABS( TWO*RHO ) -* -* Sort the eigenvalues into increasing order -* - DO 10 I = N1P1, N - INDXQ( I ) = INDXQ( I ) + N1 - 10 CONTINUE -* -* re-integrate the deflated parts from the last pass -* - DO 20 I = 1, N - DLAMDA( I ) = D( INDXQ( I ) ) - 20 CONTINUE - CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDXC ) - DO 30 I = 1, N - INDX( I ) = INDXQ( INDXC( I ) ) - 30 CONTINUE -* -* Calculate the allowable deflation tolerance -* - IMAX = IDAMAX( N, Z, 1 ) - JMAX = IDAMAX( N, D, 1 ) - EPS = DLAMCH( 'Epsilon' ) - TOL = EIGHT*EPS*MAX( ABS( D( JMAX ) ), ABS( Z( IMAX ) ) ) -* -* If the rank-1 modifier is small enough, no more needs to be done -* except to reorganize Q so that its columns correspond with the -* elements in D. -* - IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN - K = 0 - IQ2 = 1 - DO 40 J = 1, N - I = INDX( J ) - CALL DCOPY( N, Q( 1, I ), 1, Q2( IQ2 ), 1 ) - DLAMDA( J ) = D( I ) - IQ2 = IQ2 + N - 40 CONTINUE - CALL DLACPY( 'A', N, N, Q2, N, Q, LDQ ) - CALL DCOPY( N, DLAMDA, 1, D, 1 ) - GO TO 190 - END IF -* -* If there are multiple eigenvalues then the problem deflates. Here -* the number of equal eigenvalues are found. As each equal -* eigenvalue is found, an elementary reflector is computed to rotate -* the corresponding eigensubspace so that the corresponding -* components of Z are zero in this new basis. -* - DO 50 I = 1, N1 - COLTYP( I ) = 1 - 50 CONTINUE - DO 60 I = N1P1, N - COLTYP( I ) = 3 - 60 CONTINUE -* -* - K = 0 - K2 = N + 1 - DO 70 J = 1, N - NJ = INDX( J ) - IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN -* -* Deflate due to small z component. -* - K2 = K2 - 1 - COLTYP( NJ ) = 4 - INDXP( K2 ) = NJ - IF( J.EQ.N ) - $ GO TO 100 - ELSE - PJ = NJ - GO TO 80 - END IF - 70 CONTINUE - 80 CONTINUE - J = J + 1 - NJ = INDX( J ) - IF( J.GT.N ) - $ GO TO 100 - IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN -* -* Deflate due to small z component. -* - K2 = K2 - 1 - COLTYP( NJ ) = 4 - INDXP( K2 ) = NJ - ELSE -* -* Check if eigenvalues are close enough to allow deflation. -* - S = Z( PJ ) - C = Z( NJ ) -* -* Find sqrt(a**2+b**2) without overflow or -* destructive underflow. -* - TAU = DLAPY2( C, S ) - T = D( NJ ) - D( PJ ) - C = C / TAU - S = -S / TAU - IF( ABS( T*C*S ).LE.TOL ) THEN -* -* Deflation is possible. -* - Z( NJ ) = TAU - Z( PJ ) = ZERO - IF( COLTYP( NJ ).NE.COLTYP( PJ ) ) - $ COLTYP( NJ ) = 2 - COLTYP( PJ ) = 4 - CALL DROT( N, Q( 1, PJ ), 1, Q( 1, NJ ), 1, C, S ) - T = D( PJ )*C**2 + D( NJ )*S**2 - D( NJ ) = D( PJ )*S**2 + D( NJ )*C**2 - D( PJ ) = T - K2 = K2 - 1 - I = 1 - 90 CONTINUE - IF( K2+I.LE.N ) THEN - IF( D( PJ ).LT.D( INDXP( K2+I ) ) ) THEN - INDXP( K2+I-1 ) = INDXP( K2+I ) - INDXP( K2+I ) = PJ - I = I + 1 - GO TO 90 - ELSE - INDXP( K2+I-1 ) = PJ - END IF - ELSE - INDXP( K2+I-1 ) = PJ - END IF - PJ = NJ - ELSE - K = K + 1 - DLAMDA( K ) = D( PJ ) - W( K ) = Z( PJ ) - INDXP( K ) = PJ - PJ = NJ - END IF - END IF - GO TO 80 - 100 CONTINUE -* -* Record the last eigenvalue. -* - K = K + 1 - DLAMDA( K ) = D( PJ ) - W( K ) = Z( PJ ) - INDXP( K ) = PJ -* -* Count up the total number of the various types of columns, then -* form a permutation which positions the four column types into -* four uniform groups (although one or more of these groups may be -* empty). -* - DO 110 J = 1, 4 - CTOT( J ) = 0 - 110 CONTINUE - DO 120 J = 1, N - CT = COLTYP( J ) - CTOT( CT ) = CTOT( CT ) + 1 - 120 CONTINUE -* -* PSM(*) = Position in SubMatrix (of types 1 through 4) -* - PSM( 1 ) = 1 - PSM( 2 ) = 1 + CTOT( 1 ) - PSM( 3 ) = PSM( 2 ) + CTOT( 2 ) - PSM( 4 ) = PSM( 3 ) + CTOT( 3 ) - K = N - CTOT( 4 ) -* -* Fill out the INDXC array so that the permutation which it induces -* will place all type-1 columns first, all type-2 columns next, -* then all type-3's, and finally all type-4's. -* - DO 130 J = 1, N - JS = INDXP( J ) - CT = COLTYP( JS ) - INDX( PSM( CT ) ) = JS - INDXC( PSM( CT ) ) = J - PSM( CT ) = PSM( CT ) + 1 - 130 CONTINUE -* -* Sort the eigenvalues and corresponding eigenvectors into DLAMDA -* and Q2 respectively. The eigenvalues/vectors which were not -* deflated go into the first K slots of DLAMDA and Q2 respectively, -* while those which were deflated go into the last N - K slots. -* - I = 1 - IQ1 = 1 - IQ2 = 1 + ( CTOT( 1 )+CTOT( 2 ) )*N1 - DO 140 J = 1, CTOT( 1 ) - JS = INDX( I ) - CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 ) - Z( I ) = D( JS ) - I = I + 1 - IQ1 = IQ1 + N1 - 140 CONTINUE -* - DO 150 J = 1, CTOT( 2 ) - JS = INDX( I ) - CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 ) - CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 ) - Z( I ) = D( JS ) - I = I + 1 - IQ1 = IQ1 + N1 - IQ2 = IQ2 + N2 - 150 CONTINUE -* - DO 160 J = 1, CTOT( 3 ) - JS = INDX( I ) - CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 ) - Z( I ) = D( JS ) - I = I + 1 - IQ2 = IQ2 + N2 - 160 CONTINUE -* - IQ1 = IQ2 - DO 170 J = 1, CTOT( 4 ) - JS = INDX( I ) - CALL DCOPY( N, Q( 1, JS ), 1, Q2( IQ2 ), 1 ) - IQ2 = IQ2 + N - Z( I ) = D( JS ) - I = I + 1 - 170 CONTINUE -* -* The deflated eigenvalues and their corresponding vectors go back -* 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, - $ Q( 1, K+1 ), LDQ ) - CALL DCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 ) - END IF -* -* Copy CTOT into COLTYP for referencing in DLAED3. -* - DO 180 J = 1, 4 - COLTYP( J ) = CTOT( J ) - 180 CONTINUE -* - 190 CONTINUE - RETURN -* -* End of DLAED2 -* - END diff --git a/lib/linalg/fortran/dlaed3.f b/lib/linalg/fortran/dlaed3.f deleted file mode 100644 index c58944e604..0000000000 --- a/lib/linalg/fortran/dlaed3.f +++ /dev/null @@ -1,350 +0,0 @@ -*> \brief \b DLAED3 used by DSTEDC. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is tridiagonal. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAED3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* INTEGER CTOT( * ), INDX( * ) -* DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), -* $ S( * ), W( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAED3 finds the roots of the secular equation, as defined by the -*> values in D, W, and RHO, between 1 and K. It makes the -*> appropriate calls to DLAED4 and then updates the eigenvectors by -*> multiplying the matrix of eigenvectors of the pair of eigensystems -*> being combined by the matrix of eigenvectors of the K-by-K system -*> which is solved here. -*> -*> 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 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] K -*> \verbatim -*> K is INTEGER -*> The number of terms in the rational function to be solved by -*> DLAED4. K >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of rows and columns in the Q matrix. -*> N >= K (deflation may result in N>K). -*> \endverbatim -*> -*> \param[in] N1 -*> \verbatim -*> N1 is INTEGER -*> The location of the last eigenvalue in the leading submatrix. -*> min(1,N) <= N1 <= N/2. -*> \endverbatim -*> -*> \param[out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> D(I) contains the updated eigenvalues for -*> 1 <= I <= K. -*> \endverbatim -*> -*> \param[out] Q -*> \verbatim -*> Q is DOUBLE PRECISION array, dimension (LDQ,N) -*> Initially the first K columns are used as workspace. -*> On output the columns 1 to K contain -*> the updated eigenvectors. -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max(1,N). -*> \endverbatim -*> -*> \param[in] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> The value of the parameter in the rank one update equation. -*> RHO >= 0 required. -*> \endverbatim -*> -*> \param[in,out] DLAMDA -*> \verbatim -*> DLAMDA is DOUBLE PRECISION array, dimension (K) -*> The first K elements of this array contain the old roots -*> of the deflated updating problem. These are the poles -*> of the secular equation. May be changed on output by -*> having lowest order bit set to zero on Cray X-MP, Cray Y-MP, -*> Cray-2, or Cray C-90, as described above. -*> \endverbatim -*> -*> \param[in] Q2 -*> \verbatim -*> 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 -*> -*> \param[in] INDX -*> \verbatim -*> INDX is INTEGER array, dimension (N) -*> The permutation used to arrange the columns of the deflated -*> Q matrix into three groups (see DLAED2). -*> The rows of the eigenvectors found by DLAED4 must be likewise -*> permuted before the matrix multiply can take place. -*> \endverbatim -*> -*> \param[in] CTOT -*> \verbatim -*> CTOT is INTEGER array, dimension (4) -*> A count of the total number of the various types of columns -*> in Q, as described in INDX. The fourth column type is any -*> column which has been deflated. -*> \endverbatim -*> -*> \param[in,out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (K) -*> The first K elements of this array contain the components -*> of the deflation-adjusted updating vector. Destroyed on -*> output. -*> \endverbatim -*> -*> \param[out] S -*> \verbatim -*> S is DOUBLE PRECISION array, dimension (N1 + 1)*K -*> Will contain the eigenvectors of the repaired matrix which -*> will be multiplied by the previously accumulated eigenvectors -*> to update the system. -*> \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, an eigenvalue did not converge -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA \n -*> Modified by Francoise Tisseur, University of Tennessee -*> -* ===================================================================== - SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, - $ CTOT, W, S, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDQ, N, N1 - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - INTEGER CTOT( * ), INDX( * ) - DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), - $ S( * ), W( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I, II, IQ2, J, N12, N2, N23 - DOUBLE PRECISION TEMP -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3, DNRM2 - EXTERNAL DLAMC3, DNRM2 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DLACPY, DLAED4, DLASET, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( K.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.K ) THEN - INFO = -2 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAED3', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( K.EQ.0 ) - $ RETURN -* -* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(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 DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), -* which on any of these machines zeros out the bottommost -* bit of DLAMDA(I) if it is 1; this makes the subsequent -* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation -* occurs. On binary machines with a guard digit (almost all -* machines) it does not change DLAMDA(I) at all. On hexadecimal -* and decimal machines with a guard digit, it slightly -* changes the bottommost bits of DLAMDA(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 - DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I ) - 10 CONTINUE -* - DO 20 J = 1, K - CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO ) -* -* If the zero finder fails, the computation is terminated. -* - IF( INFO.NE.0 ) - $ GO TO 120 - 20 CONTINUE -* - IF( K.EQ.1 ) - $ GO TO 110 - IF( K.EQ.2 ) THEN - DO 30 J = 1, K - W( 1 ) = Q( 1, J ) - W( 2 ) = Q( 2, J ) - II = INDX( 1 ) - Q( 1, J ) = W( II ) - II = INDX( 2 ) - Q( 2, J ) = W( II ) - 30 CONTINUE - GO TO 110 - END IF -* -* Compute updated W. -* - CALL DCOPY( K, W, 1, S, 1 ) -* -* Initialize W(I) = Q(I,I) -* - CALL DCOPY( K, Q, LDQ+1, W, 1 ) - DO 60 J = 1, K - DO 40 I = 1, J - 1 - W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) - 40 CONTINUE - DO 50 I = J + 1, K - W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) - 50 CONTINUE - 60 CONTINUE - DO 70 I = 1, K - W( I ) = SIGN( SQRT( -W( I ) ), S( I ) ) - 70 CONTINUE -* -* Compute eigenvectors of the modified rank-1 modification. -* - DO 100 J = 1, K - DO 80 I = 1, K - S( I ) = W( I ) / Q( I, J ) - 80 CONTINUE - TEMP = DNRM2( K, S, 1 ) - DO 90 I = 1, K - II = INDX( I ) - Q( I, J ) = S( II ) / TEMP - 90 CONTINUE - 100 CONTINUE -* -* Compute the updated eigenvectors. -* - 110 CONTINUE -* - N2 = N - N1 - N12 = CTOT( 1 ) + CTOT( 2 ) - N23 = CTOT( 2 ) + CTOT( 3 ) -* - CALL DLACPY( 'A', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 ) - IQ2 = N1*N12 + 1 - IF( N23.NE.0 ) THEN - CALL DGEMM( 'N', 'N', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23, - $ ZERO, Q( N1+1, 1 ), LDQ ) - ELSE - CALL DLASET( 'A', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ ) - END IF -* - CALL DLACPY( 'A', N12, K, Q, LDQ, S, N12 ) - IF( N12.NE.0 ) THEN - CALL DGEMM( 'N', 'N', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q, - $ LDQ ) - ELSE - CALL DLASET( 'A', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ ) - END IF -* -* - 120 CONTINUE - RETURN -* -* End of DLAED3 -* - END diff --git a/lib/linalg/fortran/dlaed4.f b/lib/linalg/fortran/dlaed4.f deleted file mode 100644 index b51e23d850..0000000000 --- a/lib/linalg/fortran/dlaed4.f +++ /dev/null @@ -1,917 +0,0 @@ -*> \brief \b DLAED4 used by DSTEDC. Finds a single root of the secular equation. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAED4 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) -* -* .. Scalar Arguments .. -* INTEGER I, INFO, N -* DOUBLE PRECISION DLAM, RHO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ), DELTA( * ), Z( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> This subroutine computes the I-th updated eigenvalue of a symmetric -*> rank-one modification to a diagonal matrix whose elements are -*> given in the array d, and that -*> -*> 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 ) + 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, 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 > 2, DELTA contains (D(j) - lambda_I) in its j-th -*> component. If N = 1, then DELTA(1) = 1. If N = 2, see DLAED5 -*> for detail. The vector DELTA contains the information necessary -*> to construct the eigenvectors by DLAED3 and DLAED9. -*> \endverbatim -*> -*> \param[in] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> The scalar in the symmetric updating formula. -*> \endverbatim -*> -*> \param[out] DLAM -*> \verbatim -*> DLAM is DOUBLE PRECISION -*> The computed lambda_I, the I-th updated eigenvalue. -*> \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. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Ren-Cang Li, Computer Science Division, University of California -*> at Berkeley, USA -*> -* ===================================================================== - SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER I, INFO, N - DOUBLE PRECISION DLAM, RHO -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), DELTA( * ), Z( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER MAXIT - PARAMETER ( MAXIT = 30 ) - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0, - $ TEN = 10.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL ORGATI, SWTCH, SWTCH3 - INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER - DOUBLE PRECISION A, B, C, DEL, DLTLB, DLTUB, DPHI, DPSI, DW, - $ EPS, ERRETM, ETA, MIDPT, PHI, PREW, PSI, - $ RHOINV, TAU, TEMP, TEMP1, W -* .. -* .. Local Arrays .. - DOUBLE PRECISION ZZ( 3 ) -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DLAED5, DLAED6 -* .. -* .. 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 -* - DLAM = D( 1 ) + RHO*Z( 1 )*Z( 1 ) - DELTA( 1 ) = ONE - RETURN - END IF - IF( N.EQ.2 ) THEN - CALL DLAED5( I, D, Z, DELTA, RHO, DLAM ) - RETURN - END IF -* -* Compute machine epsilon -* - EPS = DLAMCH( 'Epsilon' ) - RHOINV = ONE / RHO -* -* The case I = N -* - IF( I.EQ.N ) THEN -* -* Initialize some basic variables -* - II = N - 1 - NITER = 1 -* -* Calculate initial guess -* - MIDPT = RHO / TWO -* -* If ||Z||_2 is not one, then TEMP should be set to -* RHO * ||Z||_2^2 / TWO -* - DO 10 J = 1, N - DELTA( J ) = ( D( J )-D( I ) ) - MIDPT - 10 CONTINUE -* - PSI = ZERO - DO 20 J = 1, N - 2 - PSI = PSI + Z( J )*Z( J ) / DELTA( J ) - 20 CONTINUE -* - C = RHOINV + PSI - W = C + Z( II )*Z( II ) / DELTA( II ) + - $ Z( N )*Z( N ) / DELTA( N ) -* - IF( W.LE.ZERO ) THEN - TEMP = Z( N-1 )*Z( N-1 ) / ( D( N )-D( N-1 )+RHO ) + - $ Z( N )*Z( N ) / RHO - IF( C.LE.TEMP ) THEN - TAU = RHO - ELSE - DEL = D( N ) - D( N-1 ) - A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) - B = Z( N )*Z( N )*DEL - IF( A.LT.ZERO ) THEN - TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) - ELSE - TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) - END IF - END IF -* -* It can be proved that -* D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO -* - DLTLB = MIDPT - DLTUB = RHO - ELSE - DEL = D( N ) - D( N-1 ) - A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) - B = Z( N )*Z( N )*DEL - IF( A.LT.ZERO ) THEN - TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) - ELSE - TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) - END IF -* -* It can be proved that -* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2 -* - DLTLB = ZERO - DLTUB = MIDPT - END IF -* - DO 30 J = 1, N - DELTA( J ) = ( D( J )-D( I ) ) - 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 ) - 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 ) - PHI = Z( N )*TEMP - DPHI = TEMP*TEMP - ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + - $ ABS( TAU )*( DPSI+DPHI ) -* - W = RHOINV + PHI + PSI -* -* Test for convergence -* - IF( ABS( W ).LE.EPS*ERRETM ) THEN - DLAM = D( I ) + TAU - GO TO 250 - END IF -* - IF( W.LE.ZERO ) THEN - DLTLB = MAX( DLTLB, TAU ) - ELSE - DLTUB = MIN( DLTUB, TAU ) - END IF -* -* Calculate the new step -* - NITER = NITER + 1 - C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI - A = ( DELTA( N-1 )+DELTA( N ) )*W - - $ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI ) - B = DELTA( N-1 )*DELTA( N )*W - IF( C.LT.ZERO ) - $ C = ABS( C ) - IF( C.EQ.ZERO ) THEN -* ETA = B/A -* ETA = RHO - TAU -* ETA = DLTUB - TAU -* -* Update proposed by Li, Ren-Cang: - ETA = -W / ( DPSI+DPHI ) - 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 = TAU + ETA - IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN - IF( W.LT.ZERO ) THEN - ETA = ( DLTUB-TAU ) / TWO - ELSE - ETA = ( DLTLB-TAU ) / TWO - END IF - END IF - DO 50 J = 1, N - DELTA( J ) = DELTA( J ) - ETA - 50 CONTINUE -* - TAU = TAU + ETA -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 60 J = 1, II - TEMP = Z( 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 -* - TEMP = Z( N ) / DELTA( N ) - PHI = Z( N )*TEMP - DPHI = TEMP*TEMP - ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + - $ ABS( TAU )*( 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 - DLAM = D( I ) + TAU - GO TO 250 - END IF -* - IF( W.LE.ZERO ) THEN - DLTLB = MAX( DLTLB, TAU ) - ELSE - DLTUB = MIN( DLTUB, TAU ) - END IF -* -* Calculate the new step -* - C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI - A = ( DELTA( N-1 )+DELTA( N ) )*W - - $ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI ) - B = DELTA( N-1 )*DELTA( N )*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 = TAU + ETA - IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN - IF( W.LT.ZERO ) THEN - ETA = ( DLTUB-TAU ) / TWO - ELSE - ETA = ( DLTLB-TAU ) / TWO - END IF - END IF - DO 70 J = 1, N - DELTA( J ) = DELTA( J ) - ETA - 70 CONTINUE -* - TAU = TAU + ETA -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 80 J = 1, II - TEMP = Z( 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 -* - TEMP = Z( N ) / DELTA( N ) - PHI = Z( N )*TEMP - DPHI = TEMP*TEMP - ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + - $ ABS( TAU )*( DPSI+DPHI ) -* - W = RHOINV + PHI + PSI - 90 CONTINUE -* -* Return with INFO = 1, NITER = MAXIT and not converged -* - INFO = 1 - DLAM = D( I ) + TAU - GO TO 250 -* -* End for the case I = N -* - ELSE -* -* The case for I < N -* - NITER = 1 - IP1 = I + 1 -* -* Calculate initial guess -* - DEL = D( IP1 ) - D( I ) - MIDPT = DEL / TWO - DO 100 J = 1, N - DELTA( J ) = ( D( J )-D( I ) ) - MIDPT - 100 CONTINUE -* - PSI = ZERO - DO 110 J = 1, I - 1 - PSI = PSI + Z( J )*Z( J ) / DELTA( J ) - 110 CONTINUE -* - PHI = ZERO - DO 120 J = N, I + 2, -1 - PHI = PHI + Z( J )*Z( J ) / DELTA( J ) - 120 CONTINUE - C = RHOINV + PSI + PHI - W = C + Z( I )*Z( I ) / DELTA( I ) + - $ Z( IP1 )*Z( IP1 ) / DELTA( IP1 ) -* - IF( W.GT.ZERO ) THEN -* -* d(i)< the ith eigenvalue < (d(i)+d(i+1))/2 -* -* We choose d(i) as origin. -* - ORGATI = .TRUE. - A = C*DEL + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 ) - B = Z( I )*Z( I )*DEL - IF( A.GT.ZERO ) THEN - TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) - ELSE - TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - END IF - DLTLB = ZERO - DLTUB = MIDPT - ELSE -* -* (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1) -* -* We choose d(i+1) as origin. -* - ORGATI = .FALSE. - A = C*DEL - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 ) - B = Z( IP1 )*Z( IP1 )*DEL - IF( A.LT.ZERO ) THEN - TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) ) - ELSE - TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C ) - END IF - DLTLB = -MIDPT - DLTUB = ZERO - END IF -* - IF( ORGATI ) THEN - DO 130 J = 1, N - DELTA( J ) = ( D( J )-D( I ) ) - TAU - 130 CONTINUE - ELSE - DO 140 J = 1, N - DELTA( J ) = ( D( J )-D( IP1 ) ) - TAU - 140 CONTINUE - END IF - IF( ORGATI ) THEN - II = I - ELSE - II = I + 1 - END IF - 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 ) / 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 ) / 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 ) / 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( TAU )*DW -* -* Test for convergence -* - IF( ABS( W ).LE.EPS*ERRETM ) THEN - IF( ORGATI ) THEN - DLAM = D( I ) + TAU - ELSE - DLAM = D( IP1 ) + TAU - END IF - GO TO 250 - END IF -* - IF( W.LE.ZERO ) THEN - DLTLB = MAX( DLTLB, TAU ) - ELSE - DLTUB = MIN( DLTUB, TAU ) - END IF -* -* Calculate the new step -* - NITER = NITER + 1 - IF( .NOT.SWTCH3 ) THEN - IF( ORGATI ) THEN - C = W - DELTA( IP1 )*DW - ( D( I )-D( IP1 ) )* - $ ( Z( I ) / DELTA( I ) )**2 - ELSE - C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )* - $ ( Z( IP1 ) / DELTA( IP1 ) )**2 - END IF - A = ( DELTA( I )+DELTA( IP1 ) )*W - - $ DELTA( I )*DELTA( IP1 )*DW - B = DELTA( I )*DELTA( IP1 )*W - IF( C.EQ.ZERO ) THEN - IF( A.EQ.ZERO ) THEN - IF( ORGATI ) THEN - A = Z( I )*Z( I ) + DELTA( IP1 )*DELTA( IP1 )* - $ ( DPSI+DPHI ) - ELSE - A = Z( IP1 )*Z( IP1 ) + DELTA( I )*DELTA( I )* - $ ( 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 -* - TEMP = RHOINV + PSI + PHI - IF( ORGATI ) THEN - TEMP1 = Z( IIM1 ) / DELTA( IIM1 ) - TEMP1 = TEMP1*TEMP1 - C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) - - $ ( D( IIM1 )-D( IIP1 ) )*TEMP1 - ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) - ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )* - $ ( ( DPSI-TEMP1 )+DPHI ) - ELSE - TEMP1 = Z( IIP1 ) / DELTA( IIP1 ) - TEMP1 = TEMP1*TEMP1 - C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) - - $ ( D( IIP1 )-D( IIM1 ) )*TEMP1 - ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )* - $ ( DPSI+( DPHI-TEMP1 ) ) - ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) - END IF - ZZ( 2 ) = Z( II )*Z( II ) - CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA, - $ INFO ) - IF( INFO.NE.0 ) - $ GO TO 250 - 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 - TEMP = TAU + ETA - IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN - IF( W.LT.ZERO ) THEN - ETA = ( DLTUB-TAU ) / TWO - ELSE - ETA = ( DLTLB-TAU ) / TWO - END IF - END IF -* - PREW = W -* - DO 180 J = 1, N - DELTA( J ) = DELTA( J ) - ETA - 180 CONTINUE -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 190 J = 1, IIM1 - TEMP = Z( J ) / DELTA( J ) - PSI = PSI + Z( J )*TEMP - DPSI = DPSI + TEMP*TEMP - ERRETM = ERRETM + PSI - 190 CONTINUE - ERRETM = ABS( ERRETM ) -* -* Evaluate PHI and the derivative DPHI -* - DPHI = ZERO - PHI = ZERO - DO 200 J = N, IIP1, -1 - TEMP = Z( J ) / DELTA( J ) - PHI = PHI + Z( J )*TEMP - DPHI = DPHI + TEMP*TEMP - ERRETM = ERRETM + PHI - 200 CONTINUE -* - TEMP = Z( II ) / DELTA( II ) - 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( TAU+ETA )*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 -* - TAU = TAU + ETA -* -* Main loop to update the values of the array DELTA -* - ITER = NITER + 1 -* - DO 240 NITER = ITER, MAXIT -* -* Test for convergence -* - IF( ABS( W ).LE.EPS*ERRETM ) THEN - IF( ORGATI ) THEN - DLAM = D( I ) + TAU - ELSE - DLAM = D( IP1 ) + TAU - END IF - GO TO 250 - END IF -* - IF( W.LE.ZERO ) THEN - DLTLB = MAX( DLTLB, TAU ) - ELSE - DLTUB = MIN( DLTUB, TAU ) - END IF -* -* Calculate the new step -* - IF( .NOT.SWTCH3 ) THEN - IF( .NOT.SWTCH ) THEN - IF( ORGATI ) THEN - C = W - DELTA( IP1 )*DW - - $ ( D( I )-D( IP1 ) )*( Z( I ) / DELTA( I ) )**2 - ELSE - C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )* - $ ( Z( IP1 ) / DELTA( IP1 ) )**2 - END IF - ELSE - TEMP = Z( II ) / DELTA( II ) - IF( ORGATI ) THEN - DPSI = DPSI + TEMP*TEMP - ELSE - DPHI = DPHI + TEMP*TEMP - END IF - C = W - DELTA( I )*DPSI - DELTA( IP1 )*DPHI - END IF - A = ( DELTA( I )+DELTA( IP1 ) )*W - - $ DELTA( I )*DELTA( IP1 )*DW - B = DELTA( I )*DELTA( IP1 )*W - IF( C.EQ.ZERO ) THEN - IF( A.EQ.ZERO ) THEN - IF( .NOT.SWTCH ) THEN - IF( ORGATI ) THEN - A = Z( I )*Z( I ) + DELTA( IP1 )* - $ DELTA( IP1 )*( DPSI+DPHI ) - ELSE - A = Z( IP1 )*Z( IP1 ) + - $ DELTA( I )*DELTA( I )*( DPSI+DPHI ) - END IF - ELSE - A = DELTA( I )*DELTA( I )*DPSI + - $ DELTA( IP1 )*DELTA( IP1 )*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 -* - TEMP = RHOINV + PSI + PHI - IF( SWTCH ) THEN - C = TEMP - DELTA( IIM1 )*DPSI - DELTA( IIP1 )*DPHI - ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*DPSI - ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*DPHI - ELSE - IF( ORGATI ) THEN - TEMP1 = Z( IIM1 ) / DELTA( IIM1 ) - TEMP1 = TEMP1*TEMP1 - C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) - - $ ( D( IIM1 )-D( IIP1 ) )*TEMP1 - ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) - ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )* - $ ( ( DPSI-TEMP1 )+DPHI ) - ELSE - TEMP1 = Z( IIP1 ) / DELTA( IIP1 ) - TEMP1 = TEMP1*TEMP1 - C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) - - $ ( D( IIP1 )-D( IIM1 ) )*TEMP1 - ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )* - $ ( DPSI+( DPHI-TEMP1 ) ) - ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) - END IF - END IF - CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA, - $ INFO ) - IF( INFO.NE.0 ) - $ GO TO 250 - 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 - TEMP = TAU + ETA - IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN - IF( W.LT.ZERO ) THEN - ETA = ( DLTUB-TAU ) / TWO - ELSE - ETA = ( DLTLB-TAU ) / TWO - END IF - END IF -* - DO 210 J = 1, N - DELTA( J ) = DELTA( J ) - ETA - 210 CONTINUE -* - TAU = TAU + ETA - PREW = W -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 220 J = 1, IIM1 - TEMP = Z( J ) / DELTA( J ) - PSI = PSI + Z( J )*TEMP - DPSI = DPSI + TEMP*TEMP - ERRETM = ERRETM + PSI - 220 CONTINUE - ERRETM = ABS( ERRETM ) -* -* Evaluate PHI and the derivative DPHI -* - DPHI = ZERO - PHI = ZERO - DO 230 J = N, IIP1, -1 - TEMP = Z( J ) / DELTA( J ) - PHI = PHI + Z( J )*TEMP - DPHI = DPHI + TEMP*TEMP - ERRETM = ERRETM + PHI - 230 CONTINUE -* - TEMP = Z( II ) / DELTA( II ) - 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( TAU )*DW - IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN ) - $ SWTCH = .NOT.SWTCH -* - 240 CONTINUE -* -* Return with INFO = 1, NITER = MAXIT and not converged -* - INFO = 1 - IF( ORGATI ) THEN - DLAM = D( I ) + TAU - ELSE - DLAM = D( IP1 ) + TAU - END IF -* - END IF -* - 250 CONTINUE -* - RETURN -* -* End of DLAED4 -* - END diff --git a/lib/linalg/fortran/dlaed5.f b/lib/linalg/fortran/dlaed5.f deleted file mode 100644 index d9e977e6b7..0000000000 --- a/lib/linalg/fortran/dlaed5.f +++ /dev/null @@ -1,186 +0,0 @@ -*> \brief \b DLAED5 used by DSTEDC. Solves the 2-by-2 secular equation. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAED5 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM ) -* -* .. Scalar Arguments .. -* INTEGER I -* DOUBLE PRECISION DLAM, RHO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> This subroutine computes the I-th eigenvalue of a symmetric rank-one -*> modification of a 2-by-2 diagonal matrix -*> -*> diag( D ) + RHO * Z * transpose(Z) . -*> -*> The diagonal elements in the array D are assumed to satisfy -*> -*> 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 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) -*> 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] DLAM -*> \verbatim -*> DLAM is DOUBLE PRECISION -*> The computed lambda_I, the I-th updated eigenvalue. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Ren-Cang Li, Computer Science Division, University of California -*> at Berkeley, USA -*> -* ===================================================================== - SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER I - DOUBLE PRECISION DLAM, RHO -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, FOUR - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ FOUR = 4.0D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION B, C, DEL, TAU, TEMP, W -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. -* - DEL = D( 2 ) - D( 1 ) - IF( I.EQ.1 ) THEN - W = ONE + TWO*RHO*( Z( 2 )*Z( 2 )-Z( 1 )*Z( 1 ) ) / DEL - IF( W.GT.ZERO ) THEN - B = DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) - C = RHO*Z( 1 )*Z( 1 )*DEL -* -* B > ZERO, always -* - TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) ) - DLAM = D( 1 ) + TAU - DELTA( 1 ) = -Z( 1 ) / TAU - DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) - ELSE - B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) - C = RHO*Z( 2 )*Z( 2 )*DEL - 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 - DLAM = 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 = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) - C = RHO*Z( 2 )*Z( 2 )*DEL - 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 - DLAM = 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 DLAED5 -* - END diff --git a/lib/linalg/fortran/dlaed6.f b/lib/linalg/fortran/dlaed6.f deleted file mode 100644 index a0c0364e56..0000000000 --- a/lib/linalg/fortran/dlaed6.f +++ /dev/null @@ -1,407 +0,0 @@ -*> \brief \b DLAED6 used by DSTEDC. Computes one Newton step in solution of the secular equation. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAED6 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) -* -* .. Scalar Arguments .. -* LOGICAL ORGATI -* INTEGER INFO, KNITER -* DOUBLE PRECISION FINIT, RHO, TAU -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( 3 ), Z( 3 ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAED6 computes the positive or negative root (closest to the origin) -*> of -*> z(1) z(2) z(3) -*> f(x) = rho + --------- + ---------- + --------- -*> d(1)-x d(2)-x d(3)-x -*> -*> It is assumed that -*> -*> if ORGATI = .true. the root is between d(2) and d(3); -*> otherwise it is between d(1) and d(2) -*> -*> This routine will be called by DLAED4 when necessary. In most cases, -*> the root sought is the smallest in magnitude, though it might not be -*> in some extremely rare situations. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] KNITER -*> \verbatim -*> KNITER is INTEGER -*> Refer to DLAED4 for its significance. -*> \endverbatim -*> -*> \param[in] ORGATI -*> \verbatim -*> ORGATI is LOGICAL -*> If ORGATI is true, the needed root is between d(2) and -*> d(3); otherwise it is between d(1) and d(2). See -*> DLAED4 for further details. -*> \endverbatim -*> -*> \param[in] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> Refer to the equation f(x) above. -*> \endverbatim -*> -*> \param[in] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (3) -*> D satisfies d(1) < d(2) < d(3). -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (3) -*> Each of the elements in z must be positive. -*> \endverbatim -*> -*> \param[in] FINIT -*> \verbatim -*> FINIT is DOUBLE PRECISION -*> The value of f at 0. It is more accurate than the one -*> evaluated inside this routine (if someone wants to do -*> so). -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION -*> The root of the equation f(x). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> > 0: if INFO = 1, failure to converge -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> 10/02/03: This version has a few statements commented out for thread -*> safety (machine parameters are computed on each entry). SJH. -*> -*> 05/10/06: Modified from a new version of Ren-Cang Li, use -*> Gragg-Thornton-Warner cubic convergent scheme for better stability. -*> \endverbatim -* -*> \par Contributors: -* ================== -*> -*> Ren-Cang Li, Computer Science Division, University of California -*> at Berkeley, USA -*> -* ===================================================================== - SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - LOGICAL ORGATI - INTEGER INFO, KNITER - DOUBLE PRECISION FINIT, RHO, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( 3 ), Z( 3 ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER MAXIT - PARAMETER ( MAXIT = 40 ) - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0 ) -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Local Arrays .. - DOUBLE PRECISION DSCALE( 3 ), ZSCALE( 3 ) -* .. -* .. Local Scalars .. - LOGICAL SCALE - 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, - $ LBD, UBD -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - INFO = 0 -* - IF( ORGATI ) THEN - LBD = D(2) - UBD = D(3) - ELSE - LBD = D(1) - UBD = D(2) - END IF - IF( FINIT .LT. ZERO )THEN - LBD = ZERO - ELSE - UBD = ZERO - END IF -* - NITER = 1 - TAU = ZERO - IF( KNITER.EQ.2 ) THEN - IF( ORGATI ) THEN - TEMP = ( D( 3 )-D( 2 ) ) / TWO - C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP ) - A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 ) - B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 ) - ELSE - TEMP = ( D( 1 )-D( 2 ) ) / TWO - C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP ) - A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 ) - B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 ) - END IF - TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) ) - A = A / TEMP - B = B / TEMP - C = C / TEMP - IF( C.EQ.ZERO ) THEN - TAU = B / A - ELSE IF( A.LE.ZERO ) THEN - TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - ELSE - TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) - END IF - IF( TAU .LT. LBD .OR. TAU .GT. UBD ) - $ TAU = ( LBD+UBD )/TWO - IF( D(1).EQ.TAU .OR. D(2).EQ.TAU .OR. D(3).EQ.TAU ) THEN - TAU = ZERO - ELSE - TEMP = FINIT + TAU*Z(1)/( D(1)*( D( 1 )-TAU ) ) + - $ TAU*Z(2)/( D(2)*( D( 2 )-TAU ) ) + - $ TAU*Z(3)/( D(3)*( D( 3 )-TAU ) ) - IF( TEMP .LE. ZERO )THEN - LBD = TAU - ELSE - UBD = TAU - END IF - IF( ABS( FINIT ).LE.ABS( TEMP ) ) - $ TAU = ZERO - END IF - END IF -* -* get machine parameters for possible scaling to avoid overflow -* -* modified by Sven: parameters SMALL1, SMINV1, SMALL2, -* SMINV2, EPS are not SAVEd anymore between one call to the -* others but recomputed at each call -* - EPS = DLAMCH( 'Epsilon' ) - BASE = DLAMCH( 'Base' ) - SMALL1 = BASE**( INT( LOG( DLAMCH( 'SafMin' ) ) / LOG( BASE ) / - $ THREE ) ) - SMINV1 = ONE / SMALL1 - SMALL2 = SMALL1*SMALL1 - SMINV2 = SMINV1*SMINV1 -* -* Determine if scaling of inputs necessary to avoid overflow -* when computing 1/TEMP**3 -* - IF( ORGATI ) THEN - TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) ) - ELSE - TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) ) - END IF - SCALE = .FALSE. - IF( TEMP.LE.SMALL1 ) THEN - SCALE = .TRUE. - IF( TEMP.LE.SMALL2 ) THEN -* -* Scale up by power of radix nearest 1/SAFMIN**(2/3) -* - SCLFAC = SMINV2 - SCLINV = SMALL2 - ELSE -* -* Scale up by power of radix nearest 1/SAFMIN**(1/3) -* - SCLFAC = SMINV1 - SCLINV = SMALL1 - END IF -* -* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1) -* - DO 10 I = 1, 3 - DSCALE( I ) = D( I )*SCLFAC - ZSCALE( I ) = Z( I )*SCLFAC - 10 CONTINUE - TAU = TAU*SCLFAC - LBD = LBD*SCLFAC - UBD = UBD*SCLFAC - ELSE -* -* Copy D and Z to DSCALE and ZSCALE -* - DO 20 I = 1, 3 - DSCALE( I ) = D( I ) - ZSCALE( I ) = Z( I ) - 20 CONTINUE - END IF -* - FC = ZERO - DF = ZERO - DDF = ZERO - DO 30 I = 1, 3 - TEMP = ONE / ( DSCALE( I )-TAU ) - TEMP1 = ZSCALE( I )*TEMP - TEMP2 = TEMP1*TEMP - TEMP3 = TEMP2*TEMP - FC = FC + TEMP1 / DSCALE( I ) - DF = DF + TEMP2 - DDF = DDF + TEMP3 - 30 CONTINUE - F = FINIT + TAU*FC -* - IF( ABS( F ).LE.ZERO ) - $ GO TO 60 - IF( F .LE. ZERO )THEN - LBD = TAU - ELSE - UBD = TAU - END IF -* -* Iteration begins -- Use Gragg-Thornton-Warner cubic convergent -* scheme -* -* It is not hard to see that -* -* 1) Iterations will go up monotonically -* if FINIT < 0; -* -* 2) Iterations will go down monotonically -* if FINIT > 0. -* - ITER = NITER + 1 -* - DO 50 NITER = ITER, MAXIT -* - IF( ORGATI ) THEN - TEMP1 = DSCALE( 2 ) - TAU - TEMP2 = DSCALE( 3 ) - TAU - ELSE - TEMP1 = DSCALE( 1 ) - TAU - TEMP2 = DSCALE( 2 ) - TAU - END IF - A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF - B = TEMP1*TEMP2*F - C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF - TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) ) - A = A / TEMP - B = B / TEMP - C = C / TEMP - IF( C.EQ.ZERO ) THEN - 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 - IF( F*ETA.GE.ZERO ) THEN - ETA = -F / DF - END IF -* - TAU = TAU + ETA - IF( TAU .LT. LBD .OR. TAU .GT. UBD ) - $ TAU = ( LBD + UBD )/TWO -* - FC = ZERO - ERRETM = ZERO - DF = ZERO - DDF = ZERO - DO 40 I = 1, 3 - IF ( ( DSCALE( I )-TAU ).NE.ZERO ) THEN - TEMP = ONE / ( DSCALE( I )-TAU ) - TEMP1 = ZSCALE( I )*TEMP - TEMP2 = TEMP1*TEMP - TEMP3 = TEMP2*TEMP - TEMP4 = TEMP1 / DSCALE( I ) - FC = FC + TEMP4 - ERRETM = ERRETM + ABS( TEMP4 ) - DF = DF + TEMP2 - DDF = DDF + TEMP3 - ELSE - 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.FOUR*EPS*ERRETM ) .OR. - $ ( (UBD-LBD).LE.FOUR*EPS*ABS(TAU) ) ) - $ GO TO 60 - IF( F .LE. ZERO )THEN - LBD = TAU - ELSE - UBD = TAU - END IF - 50 CONTINUE - INFO = 1 - 60 CONTINUE -* -* Undo scaling -* - IF( SCALE ) - $ TAU = TAU*SCLINV - RETURN -* -* End of DLAED6 -* - END diff --git a/lib/linalg/fortran/dlaed7.f b/lib/linalg/fortran/dlaed7.f deleted file mode 100644 index d968c56752..0000000000 --- a/lib/linalg/fortran/dlaed7.f +++ /dev/null @@ -1,404 +0,0 @@ -*> \brief \b DLAED7 used by DSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is dense. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAED7 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, -* 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 -* DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. -* INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ), -* $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * ) -* DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ), -* $ QSTORE( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAED7 computes the updated eigensystem of a diagonal -*> matrix after modification by a rank-one symmetric matrix. This -*> routine is used only for the eigenproblem which requires all -*> eigenvalues and optionally eigenvectors of a dense symmetric matrix -*> that has been reduced to tridiagonal form. DLAED1 handles -*> the case in which all eigenvalues and eigenvectors of a symmetric -*> tridiagonal matrix are desired. -*> -*> T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out) -*> -*> where Z = Q**Tu, u is a vector of length N with ones in the -*> CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. -*> -*> The eigenvectors of the original matrix are stored in Q, and the -*> eigenvalues are in D. The algorithm consists of three stages: -*> -*> 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 occurrence the dimension of the -*> secular equation problem is reduced by one. This stage is -*> performed by the routine DLAED8. -*> -*> The second stage consists of calculating the updated -*> eigenvalues. This is done by finding the roots of the secular -*> equation via the routine DLAED4 (as called by DLAED9). -*> This routine also calculates the eigenvectors of the current -*> problem. -*> -*> The final stage consists of computing the updated eigenvectors -*> directly using the updated eigenvalues. The eigenvectors for -*> the current problem are multiplied with the eigenvectors from -*> the overall problem. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ICOMPQ -*> \verbatim -*> ICOMPQ is INTEGER -*> = 0: Compute eigenvalues only. -*> = 1: Compute eigenvectors of original dense symmetric matrix -*> also. On entry, Q contains the orthogonal matrix used -*> to reduce the original matrix to tridiagonal form. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in] QSIZ -*> \verbatim -*> QSIZ is INTEGER -*> The dimension of the orthogonal matrix used to reduce -*> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. -*> \endverbatim -*> -*> \param[in] TLVLS -*> \verbatim -*> TLVLS is INTEGER -*> The total number of merging levels in the overall divide and -*> conquer tree. -*> \endverbatim -*> -*> \param[in] CURLVL -*> \verbatim -*> CURLVL is INTEGER -*> The current level in the overall merge routine, -*> 0 <= CURLVL <= TLVLS. -*> \endverbatim -*> -*> \param[in] CURPBM -*> \verbatim -*> CURPBM is INTEGER -*> The current problem in the current level in the overall -*> merge routine (counting from upper left to lower right). -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the eigenvalues of the rank-1-perturbed matrix. -*> On exit, the eigenvalues of the repaired matrix. -*> \endverbatim -*> -*> \param[in,out] Q -*> \verbatim -*> Q is DOUBLE PRECISION array, dimension (LDQ, N) -*> On entry, the eigenvectors of the rank-1-perturbed matrix. -*> On exit, the eigenvectors of the repaired tridiagonal matrix. -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max(1,N). -*> \endverbatim -*> -*> \param[out] INDXQ -*> \verbatim -*> INDXQ is INTEGER array, dimension (N) -*> The permutation which will reintegrate the subproblem just -*> solved back into sorted order, i.e., D( INDXQ( I = 1, N ) ) -*> will be in ascending order. -*> \endverbatim -*> -*> \param[in] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> The subdiagonal element used to create the rank-1 -*> modification. -*> \endverbatim -*> -*> \param[in] CUTPNT -*> \verbatim -*> CUTPNT is INTEGER -*> Contains the location of the last eigenvalue in the leading -*> sub-matrix. min(1,N) <= CUTPNT <= N. -*> \endverbatim -*> -*> \param[in,out] QSTORE -*> \verbatim -*> QSTORE is DOUBLE PRECISION array, dimension (N**2+1) -*> Stores eigenvectors of submatrices encountered during -*> divide and conquer, packed together. QPTR points to -*> beginning of the submatrices. -*> \endverbatim -*> -*> \param[in,out] QPTR -*> \verbatim -*> QPTR is INTEGER array, dimension (N+2) -*> List of indices pointing to beginning of submatrices stored -*> in QSTORE. The submatrices are numbered starting at the -*> bottom left of the divide and conquer tree, from left to -*> right and bottom to top. -*> \endverbatim -*> -*> \param[in] PRMPTR -*> \verbatim -*> PRMPTR is INTEGER array, dimension (N lg N) -*> Contains a list of pointers which indicate where in PERM a -*> level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) -*> indicates the size of the permutation and also the size of -*> the full, non-deflated problem. -*> \endverbatim -*> -*> \param[in] PERM -*> \verbatim -*> PERM is INTEGER array, dimension (N lg N) -*> Contains the permutations (from deflation and sorting) to be -*> applied to each eigenblock. -*> \endverbatim -*> -*> \param[in] GIVPTR -*> \verbatim -*> GIVPTR is INTEGER array, dimension (N lg N) -*> Contains a list of pointers which indicate where in GIVCOL a -*> level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) -*> indicates the number of Givens rotations. -*> \endverbatim -*> -*> \param[in] GIVCOL -*> \verbatim -*> GIVCOL is INTEGER array, dimension (2, N lg N) -*> Each pair of numbers indicates a pair of columns to take place -*> in a Givens rotation. -*> \endverbatim -*> -*> \param[in] GIVNUM -*> \verbatim -*> GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N) -*> Each number indicates the S value to be used in the -*> corresponding Givens rotation. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (3*N+2*QSIZ*N) -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (4*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, an eigenvalue did not converge -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA -* -* ===================================================================== - SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, - $ LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, - $ PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, - $ INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N, - $ QSIZ, TLVLS - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ), - $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * ) - DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ), - $ QSTORE( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -* .. -* .. Local Scalars .. - INTEGER COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP, - $ IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DLAED8, DLAED9, DLAEDA, DLAMRG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN - INFO = -3 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN - INFO = -12 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAED7', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* 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 DLAED8 and DLAED9. -* - IF( ICOMPQ.EQ.1 ) THEN - LDQ2 = QSIZ - ELSE - LDQ2 = N - END IF -* - IZ = 1 - IDLMDA = IZ + N - IW = IDLMDA + N - IQ2 = IW + N - IS = IQ2 + N*LDQ2 -* - INDX = 1 - INDXC = INDX + N - COLTYP = INDXC + N - INDXP = COLTYP + N -* -* Form the z-vector which consists of the last row of Q_1 and the -* first row of Q_2. -* - PTR = 1 + 2**TLVLS - DO 10 I = 1, CURLVL - 1 - PTR = PTR + 2**( TLVLS-I ) - 10 CONTINUE - CURR = PTR + CURPBM - CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, - $ GIVCOL, GIVNUM, QSTORE, QPTR, WORK( IZ ), - $ WORK( IZ+N ), INFO ) -* -* When solving the final problem, we no longer need the stored data, -* so we will overwrite the data from this level onto the previously -* used storage space. -* - IF( CURLVL.EQ.TLVLS ) THEN - QPTR( CURR ) = 1 - PRMPTR( CURR ) = 1 - GIVPTR( CURR ) = 1 - END IF -* -* Sort and Deflate eigenvalues. -* - CALL DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT, - $ WORK( IZ ), WORK( IDLMDA ), WORK( IQ2 ), LDQ2, - $ WORK( IW ), PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ), - $ GIVCOL( 1, GIVPTR( CURR ) ), - $ GIVNUM( 1, GIVPTR( CURR ) ), IWORK( INDXP ), - $ IWORK( INDX ), INFO ) - PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N - GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR ) -* -* Solve Secular Equation. -* - IF( K.NE.0 ) THEN - CALL DLAED9( K, 1, K, N, D, WORK( IS ), K, RHO, WORK( IDLMDA ), - $ WORK( IW ), QSTORE( QPTR( CURR ) ), K, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( ICOMPQ.EQ.1 ) THEN - CALL DGEMM( 'N', 'N', QSIZ, K, K, ONE, WORK( IQ2 ), LDQ2, - $ QSTORE( QPTR( CURR ) ), K, ZERO, Q, LDQ ) - END IF - QPTR( CURR+1 ) = QPTR( CURR ) + K**2 -* -* Prepare the INDXQ sorting permutation. -* - N1 = K - N2 = N - K - CALL DLAMRG( N1, N2, D, 1, -1, INDXQ ) - ELSE - QPTR( CURR+1 ) = QPTR( CURR ) - DO 20 I = 1, N - INDXQ( I ) = I - 20 CONTINUE - END IF -* - 30 CONTINUE - RETURN -* -* End of DLAED7 -* - END diff --git a/lib/linalg/fortran/dlaed8.f b/lib/linalg/fortran/dlaed8.f deleted file mode 100644 index 3631fb4566..0000000000 --- a/lib/linalg/fortran/dlaed8.f +++ /dev/null @@ -1,521 +0,0 @@ -*> \brief \b DLAED8 used by DSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matrix is dense. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAED8 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* 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 -* DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. -* INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ), -* $ INDXQ( * ), PERM( * ) -* DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), -* $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAED8 merges the two sets of eigenvalues 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 -*> eigenvalues are close together or if there is a tiny element in the -*> Z vector. For each such occurrence the order of the related secular -*> equation problem is reduced by one. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ICOMPQ -*> \verbatim -*> ICOMPQ is INTEGER -*> = 0: Compute eigenvalues only. -*> = 1: Compute eigenvectors of original dense symmetric matrix -*> also. On entry, Q contains the orthogonal matrix used -*> to reduce the original matrix to tridiagonal form. -*> \endverbatim -*> -*> \param[out] K -*> \verbatim -*> K is INTEGER -*> The number of non-deflated eigenvalues, and the order of the -*> related secular equation. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in] QSIZ -*> \verbatim -*> QSIZ is INTEGER -*> The dimension of the orthogonal matrix used to reduce -*> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the eigenvalues of the two submatrices to be -*> combined. On exit, the trailing (N-K) updated eigenvalues -*> (those which were deflated) sorted into increasing order. -*> \endverbatim -*> -*> \param[in,out] Q -*> \verbatim -*> Q is DOUBLE PRECISION array, dimension (LDQ,N) -*> If ICOMPQ = 0, Q is not referenced. Otherwise, -*> on entry, Q contains the eigenvectors of the partially solved -*> system which has been previously updated in matrix -*> multiplies with other partially solved eigensystems. -*> On exit, Q contains the trailing (N-K) updated eigenvectors -*> (those which were deflated) in its last N-K columns. -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max(1,N). -*> \endverbatim -*> -*> \param[in] INDXQ -*> \verbatim -*> INDXQ is INTEGER array, dimension (N) -*> The permutation which separately sorts the two sub-problems -*> in D into ascending order. Note that elements in the second -*> half of this permutation must first have CUTPNT added to -*> their values in order to be accurate. -*> \endverbatim -*> -*> \param[in,out] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> On entry, the off-diagonal element associated with the rank-1 -*> cut which originally split the two submatrices which are now -*> being recombined. -*> On exit, RHO has been modified to the value required by -*> DLAED3. -*> \endverbatim -*> -*> \param[in] CUTPNT -*> \verbatim -*> CUTPNT is INTEGER -*> The location of the last eigenvalue in the leading -*> sub-matrix. min(1,N) <= CUTPNT <= N. -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (N) -*> On entry, Z contains the updating vector (the last row of -*> the first sub-eigenvector matrix and the first row of the -*> second sub-eigenvector matrix). -*> On exit, the contents of Z are destroyed by the updating -*> process. -*> \endverbatim -*> -*> \param[out] DLAMDA -*> \verbatim -*> DLAMDA is DOUBLE PRECISION array, dimension (N) -*> A copy of the first K eigenvalues which will be used by -*> DLAED3 to form the secular equation. -*> \endverbatim -*> -*> \param[out] Q2 -*> \verbatim -*> Q2 is DOUBLE PRECISION array, dimension (LDQ2,N) -*> If ICOMPQ = 0, Q2 is not referenced. Otherwise, -*> a copy of the first K eigenvectors which will be used by -*> DLAED7 in a matrix multiply (DGEMM) to update the new -*> eigenvectors. -*> \endverbatim -*> -*> \param[in] LDQ2 -*> \verbatim -*> LDQ2 is INTEGER -*> The leading dimension of the array Q2. LDQ2 >= max(1,N). -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (N) -*> The first k values of the final deflation-altered z-vector and -*> will be passed to DLAED3. -*> \endverbatim -*> -*> \param[out] PERM -*> \verbatim -*> PERM is INTEGER array, dimension (N) -*> The permutations (from deflation and sorting) to be applied -*> to each eigenblock. -*> \endverbatim -*> -*> \param[out] GIVPTR -*> \verbatim -*> GIVPTR is INTEGER -*> The number of Givens rotations which took place in this -*> subproblem. -*> \endverbatim -*> -*> \param[out] GIVCOL -*> \verbatim -*> GIVCOL is INTEGER array, dimension (2, N) -*> Each pair of numbers indicates a pair of columns to take place -*> in a Givens rotation. -*> \endverbatim -*> -*> \param[out] GIVNUM -*> \verbatim -*> GIVNUM is DOUBLE PRECISION array, dimension (2, N) -*> Each number indicates the S value to be used in the -*> corresponding Givens rotation. -*> \endverbatim -*> -*> \param[out] INDXP -*> \verbatim -*> INDXP is INTEGER array, dimension (N) -*> The permutation used to place deflated values of D at the end -*> of the array. INDXP(1:K) points to the nondeflated D-values -*> and INDXP(K+1:N) points to the deflated eigenvalues. -*> \endverbatim -*> -*> \param[out] INDX -*> \verbatim -*> INDX is INTEGER array, dimension (N) -*> The permutation used to sort the contents of D into ascending -*> order. -*> \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. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA -* -* ===================================================================== - SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, - $ CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, - $ GIVCOL, GIVNUM, INDXP, INDX, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N, - $ QSIZ - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ), - $ INDXQ( * ), PERM( * ) - DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), - $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT - PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0, - $ TWO = 2.0D0, EIGHT = 8.0D0 ) -* .. -* .. Local Scalars .. -* - INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2 - DOUBLE PRECISION C, EPS, S, T, TAU, TOL -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DLAPY2 - EXTERNAL IDAMAX, DLAMCH, DLAPY2 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN - INFO = -4 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN - INFO = -10 - ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN - INFO = -14 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAED8', -INFO ) - RETURN - 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 -* (or at least some IWORK entries which used in *laed7 for GIVPTR). -* - GIVPTR = 0 -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - N1 = CUTPNT - N2 = N - N1 - N1P1 = N1 + 1 -* - IF( RHO.LT.ZERO ) THEN - CALL DSCAL( N2, MONE, Z( N1P1 ), 1 ) - END IF -* -* Normalize z so that norm(z) = 1 -* - T = ONE / SQRT( TWO ) - DO 10 J = 1, N - INDX( J ) = J - 10 CONTINUE - CALL DSCAL( N, T, Z, 1 ) - RHO = ABS( TWO*RHO ) -* -* Sort the eigenvalues into increasing order -* - DO 20 I = CUTPNT + 1, N - INDXQ( I ) = INDXQ( I ) + CUTPNT - 20 CONTINUE - DO 30 I = 1, N - DLAMDA( I ) = D( INDXQ( I ) ) - W( I ) = Z( INDXQ( I ) ) - 30 CONTINUE - I = 1 - J = CUTPNT + 1 - CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDX ) - DO 40 I = 1, N - D( I ) = DLAMDA( INDX( I ) ) - Z( I ) = W( INDX( I ) ) - 40 CONTINUE -* -* Calculate the allowable deflation tolerance -* - IMAX = IDAMAX( N, Z, 1 ) - JMAX = IDAMAX( N, D, 1 ) - EPS = DLAMCH( 'Epsilon' ) - TOL = EIGHT*EPS*ABS( D( JMAX ) ) -* -* If the rank-1 modifier is small enough, no more needs to be done -* except to reorganize Q so that its columns correspond with the -* elements in D. -* - IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN - K = 0 - IF( ICOMPQ.EQ.0 ) THEN - DO 50 J = 1, N - PERM( J ) = INDXQ( INDX( J ) ) - 50 CONTINUE - ELSE - DO 60 J = 1, N - PERM( J ) = INDXQ( INDX( J ) ) - CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) - 60 CONTINUE - CALL DLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ), - $ LDQ ) - END IF - RETURN - END IF -* -* If there are multiple eigenvalues then the problem deflates. Here -* the number of equal eigenvalues are found. As each equal -* eigenvalue is found, an elementary reflector is computed to rotate -* the corresponding eigensubspace so that the corresponding -* components of Z are zero in this new basis. -* - K = 0 - K2 = N + 1 - DO 70 J = 1, N - IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN -* -* Deflate due to small z component. -* - K2 = K2 - 1 - INDXP( K2 ) = J - IF( J.EQ.N ) - $ GO TO 110 - ELSE - JLAM = J - GO TO 80 - END IF - 70 CONTINUE - 80 CONTINUE - J = J + 1 - IF( J.GT.N ) - $ GO TO 100 - IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN -* -* Deflate due to small z component. -* - K2 = K2 - 1 - INDXP( K2 ) = J - ELSE -* -* Check if eigenvalues are close enough to allow deflation. -* - S = Z( JLAM ) - C = Z( J ) -* -* Find sqrt(a**2+b**2) without overflow or -* destructive underflow. -* - TAU = DLAPY2( C, S ) - T = D( J ) - D( JLAM ) - C = C / TAU - S = -S / TAU - IF( ABS( T*C*S ).LE.TOL ) THEN -* -* Deflation is possible. -* - Z( J ) = TAU - Z( JLAM ) = ZERO -* -* Record the appropriate Givens rotation -* - GIVPTR = GIVPTR + 1 - GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) ) - GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) ) - GIVNUM( 1, GIVPTR ) = C - GIVNUM( 2, GIVPTR ) = S - IF( ICOMPQ.EQ.1 ) THEN - CALL DROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1, - $ Q( 1, INDXQ( INDX( J ) ) ), 1, C, S ) - END IF - T = D( JLAM )*C*C + D( J )*S*S - D( J ) = D( JLAM )*S*S + D( J )*C*C - D( JLAM ) = T - K2 = K2 - 1 - I = 1 - 90 CONTINUE - IF( K2+I.LE.N ) THEN - IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN - INDXP( K2+I-1 ) = INDXP( K2+I ) - INDXP( K2+I ) = JLAM - I = I + 1 - GO TO 90 - ELSE - INDXP( K2+I-1 ) = JLAM - END IF - ELSE - INDXP( K2+I-1 ) = JLAM - END IF - JLAM = J - ELSE - K = K + 1 - W( K ) = Z( JLAM ) - DLAMDA( K ) = D( JLAM ) - INDXP( K ) = JLAM - JLAM = J - END IF - END IF - GO TO 80 - 100 CONTINUE -* -* Record the last eigenvalue. -* - K = K + 1 - W( K ) = Z( JLAM ) - DLAMDA( K ) = D( JLAM ) - INDXP( K ) = JLAM -* - 110 CONTINUE -* -* Sort the eigenvalues and corresponding eigenvectors into DLAMDA -* and Q2 respectively. The eigenvalues/vectors which were not -* deflated go into the first K slots of DLAMDA and Q2 respectively, -* while those which were deflated go into the last N - K slots. -* - IF( ICOMPQ.EQ.0 ) THEN - DO 120 J = 1, N - JP = INDXP( J ) - DLAMDA( J ) = D( JP ) - PERM( J ) = INDXQ( INDX( JP ) ) - 120 CONTINUE - ELSE - DO 130 J = 1, N - JP = INDXP( J ) - DLAMDA( J ) = D( JP ) - PERM( J ) = INDXQ( INDX( JP ) ) - CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) - 130 CONTINUE - END IF -* -* The deflated eigenvalues and their corresponding vectors go back -* into the last N - K slots of D and Q respectively. -* - IF( K.LT.N ) THEN - IF( ICOMPQ.EQ.0 ) THEN - CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 ) - ELSE - CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 ) - CALL DLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2, - $ Q( 1, K+1 ), LDQ ) - END IF - END IF -* - RETURN -* -* End of DLAED8 -* - END diff --git a/lib/linalg/fortran/dlaed9.f b/lib/linalg/fortran/dlaed9.f deleted file mode 100644 index b88cdd9077..0000000000 --- a/lib/linalg/fortran/dlaed9.f +++ /dev/null @@ -1,291 +0,0 @@ -*> \brief \b DLAED9 used by DSTEDC. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is dense. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAED9 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ), -* $ W( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAED9 finds the roots of the secular equation, as defined by the -*> values in D, Z, and RHO, between KSTART and KSTOP. It makes the -*> appropriate calls to DLAED4 and then stores the new matrix of -*> eigenvectors for use in calculating the next level of Z vectors. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of terms in the rational function to be solved by -*> DLAED4. K >= 0. -*> \endverbatim -*> -*> \param[in] KSTART -*> \verbatim -*> KSTART is INTEGER -*> \endverbatim -*> -*> \param[in] KSTOP -*> \verbatim -*> KSTOP is INTEGER -*> The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP -*> are to be computed. 1 <= KSTART <= KSTOP <= K. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of rows and columns in the Q matrix. -*> N >= K (delation may result in N > K). -*> \endverbatim -*> -*> \param[out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> D(I) contains the updated eigenvalues -*> for KSTART <= I <= KSTOP. -*> \endverbatim -*> -*> \param[out] Q -*> \verbatim -*> Q is DOUBLE PRECISION array, dimension (LDQ,N) -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max( 1, N ). -*> \endverbatim -*> -*> \param[in] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> The value of the parameter in the rank one update equation. -*> RHO >= 0 required. -*> \endverbatim -*> -*> \param[in] DLAMDA -*> \verbatim -*> DLAMDA is DOUBLE PRECISION array, dimension (K) -*> The first K elements of this array contain the old roots -*> of the deflated updating problem. These are the poles -*> of the secular equation. -*> \endverbatim -*> -*> \param[in] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (K) -*> The first K elements of this array contain the components -*> of the deflation-adjusted updating vector. -*> \endverbatim -*> -*> \param[out] S -*> \verbatim -*> S is DOUBLE PRECISION array, dimension (LDS, K) -*> Will contain the eigenvectors of the repaired matrix which -*> will be stored for subsequent Z vector calculation and -*> multiplied by the previously accumulated eigenvectors -*> to update the system. -*> \endverbatim -*> -*> \param[in] LDS -*> \verbatim -*> LDS is INTEGER -*> The leading dimension of S. LDS >= max( 1, 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, an eigenvalue did not converge -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA -* -* ===================================================================== - SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, - $ S, LDS, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ), - $ W( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION TEMP -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3, DNRM2 - EXTERNAL DLAMC3, DNRM2 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLAED4, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( K.LT.0 ) THEN - INFO = -1 - ELSE IF( KSTART.LT.1 .OR. KSTART.GT.MAX( 1, K ) ) THEN - INFO = -2 - ELSE IF( MAX( 1, KSTOP ).LT.KSTART .OR. KSTOP.GT.MAX( 1, K ) ) - $ THEN - INFO = -3 - ELSE IF( N.LT.K ) THEN - INFO = -4 - ELSE IF( LDQ.LT.MAX( 1, K ) ) THEN - INFO = -7 - ELSE IF( LDS.LT.MAX( 1, K ) ) THEN - INFO = -12 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAED9', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( K.EQ.0 ) - $ RETURN -* -* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(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 DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), -* which on any of these machines zeros out the bottommost -* bit of DLAMDA(I) if it is 1; this makes the subsequent -* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation -* occurs. On binary machines with a guard digit (almost all -* machines) it does not change DLAMDA(I) at all. On hexadecimal -* and decimal machines with a guard digit, it slightly -* changes the bottommost bits of DLAMDA(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, N - DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I ) - 10 CONTINUE -* - DO 20 J = KSTART, KSTOP - CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO ) -* -* If the zero finder fails, the computation is terminated. -* - IF( INFO.NE.0 ) - $ GO TO 120 - 20 CONTINUE -* - IF( K.EQ.1 .OR. K.EQ.2 ) THEN - DO 40 I = 1, K - DO 30 J = 1, K - S( J, I ) = Q( J, I ) - 30 CONTINUE - 40 CONTINUE - GO TO 120 - END IF -* -* Compute updated W. -* - CALL DCOPY( K, W, 1, S, 1 ) -* -* Initialize W(I) = Q(I,I) -* - CALL DCOPY( K, Q, LDQ+1, W, 1 ) - DO 70 J = 1, K - DO 50 I = 1, J - 1 - W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) - 50 CONTINUE - DO 60 I = J + 1, K - W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) - 60 CONTINUE - 70 CONTINUE - DO 80 I = 1, K - W( I ) = SIGN( SQRT( -W( I ) ), S( I, 1 ) ) - 80 CONTINUE -* -* Compute eigenvectors of the modified rank-1 modification. -* - DO 110 J = 1, K - DO 90 I = 1, K - Q( I, J ) = W( I ) / Q( I, J ) - 90 CONTINUE - TEMP = DNRM2( K, Q( 1, J ), 1 ) - DO 100 I = 1, K - S( I, J ) = Q( I, J ) / TEMP - 100 CONTINUE - 110 CONTINUE -* - 120 CONTINUE - RETURN -* -* End of DLAED9 -* - END diff --git a/lib/linalg/fortran/dlaeda.f b/lib/linalg/fortran/dlaeda.f deleted file mode 100644 index 8864fd7f2a..0000000000 --- a/lib/linalg/fortran/dlaeda.f +++ /dev/null @@ -1,305 +0,0 @@ -*> \brief \b DLAEDA used by DSTEDC. Computes the Z vector determining the rank-one modification of the diagonal matrix. Used when the original matrix is dense. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAEDA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ), -* $ PRMPTR( * ), QPTR( * ) -* DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAEDA computes the Z vector corresponding to the merge step in the -*> CURLVLth step of the merge process with TLVLS steps for the CURPBMth -*> problem. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in] TLVLS -*> \verbatim -*> TLVLS is INTEGER -*> The total number of merging levels in the overall divide and -*> conquer tree. -*> \endverbatim -*> -*> \param[in] CURLVL -*> \verbatim -*> CURLVL is INTEGER -*> The current level in the overall merge routine, -*> 0 <= curlvl <= tlvls. -*> \endverbatim -*> -*> \param[in] CURPBM -*> \verbatim -*> CURPBM is INTEGER -*> The current problem in the current level in the overall -*> merge routine (counting from upper left to lower right). -*> \endverbatim -*> -*> \param[in] PRMPTR -*> \verbatim -*> PRMPTR is INTEGER array, dimension (N lg N) -*> Contains a list of pointers which indicate where in PERM a -*> level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) -*> indicates the size of the permutation and incidentally the -*> size of the full, non-deflated problem. -*> \endverbatim -*> -*> \param[in] PERM -*> \verbatim -*> PERM is INTEGER array, dimension (N lg N) -*> Contains the permutations (from deflation and sorting) to be -*> applied to each eigenblock. -*> \endverbatim -*> -*> \param[in] GIVPTR -*> \verbatim -*> GIVPTR is INTEGER array, dimension (N lg N) -*> Contains a list of pointers which indicate where in GIVCOL a -*> level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) -*> indicates the number of Givens rotations. -*> \endverbatim -*> -*> \param[in] GIVCOL -*> \verbatim -*> GIVCOL is INTEGER array, dimension (2, N lg N) -*> Each pair of numbers indicates a pair of columns to take place -*> in a Givens rotation. -*> \endverbatim -*> -*> \param[in] GIVNUM -*> \verbatim -*> GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N) -*> Each number indicates the S value to be used in the -*> corresponding Givens rotation. -*> \endverbatim -*> -*> \param[in] Q -*> \verbatim -*> Q is DOUBLE PRECISION array, dimension (N**2) -*> Contains the square eigenblocks from previous levels, the -*> starting positions for blocks are given by QPTR. -*> \endverbatim -*> -*> \param[in] QPTR -*> \verbatim -*> QPTR is INTEGER array, dimension (N+2) -*> Contains a list of pointers which indicate where in Q an -*> eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates -*> the size of the block. -*> \endverbatim -*> -*> \param[out] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (N) -*> On output this vector contains the updating vector (the last -*> row of the first sub-eigenvector matrix and the first row of -*> the second sub-eigenvector matrix). -*> \endverbatim -*> -*> \param[out] ZTEMP -*> \verbatim -*> ZTEMP is DOUBLE PRECISION array, dimension (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. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA -* -* ===================================================================== - SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, - $ GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER CURLVL, CURPBM, INFO, N, TLVLS -* .. -* .. Array Arguments .. - INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ), - $ PRMPTR( * ), QPTR( * ) - DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - INTEGER BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2, - $ PTR, ZPTR1 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, DROT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, INT, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( N.LT.0 ) THEN - INFO = -1 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAEDA', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine location of first number in second half. -* - MID = N / 2 + 1 -* -* Gather last/first rows of appropriate eigenblocks into center of Z -* - PTR = 1 -* -* Determine location of lowest level subproblem in the full storage -* scheme -* - CURR = PTR + CURPBM*2**CURLVL + 2**( CURLVL-1 ) - 1 -* -* Determine size of these matrices. We add HALF to the value of -* the SQRT in case the machine underestimates one of these square -* roots. -* - BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) ) - BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+1 ) ) ) ) - DO 10 K = 1, MID - BSIZ1 - 1 - Z( K ) = ZERO - 10 CONTINUE - CALL DCOPY( BSIZ1, Q( QPTR( CURR )+BSIZ1-1 ), BSIZ1, - $ Z( MID-BSIZ1 ), 1 ) - CALL DCOPY( BSIZ2, Q( QPTR( CURR+1 ) ), BSIZ2, Z( MID ), 1 ) - DO 20 K = MID + BSIZ2, N - Z( K ) = ZERO - 20 CONTINUE -* -* Loop through remaining levels 1 -> CURLVL applying the Givens -* rotations and permutation and then multiplying the center matrices -* against the current Z. -* - PTR = 2**TLVLS + 1 - DO 70 K = 1, CURLVL - 1 - CURR = PTR + CURPBM*2**( CURLVL-K ) + 2**( CURLVL-K-1 ) - 1 - PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR ) - PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 ) - ZPTR1 = MID - PSIZ1 -* -* Apply Givens at CURR and CURR+1 -* - DO 30 I = GIVPTR( CURR ), GIVPTR( CURR+1 ) - 1 - CALL DROT( 1, Z( ZPTR1+GIVCOL( 1, I )-1 ), 1, - $ Z( ZPTR1+GIVCOL( 2, I )-1 ), 1, GIVNUM( 1, I ), - $ GIVNUM( 2, I ) ) - 30 CONTINUE - DO 40 I = GIVPTR( CURR+1 ), GIVPTR( CURR+2 ) - 1 - CALL DROT( 1, Z( MID-1+GIVCOL( 1, I ) ), 1, - $ Z( MID-1+GIVCOL( 2, I ) ), 1, GIVNUM( 1, I ), - $ GIVNUM( 2, I ) ) - 40 CONTINUE - PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR ) - PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 ) - DO 50 I = 0, PSIZ1 - 1 - ZTEMP( I+1 ) = Z( ZPTR1+PERM( PRMPTR( CURR )+I )-1 ) - 50 CONTINUE - DO 60 I = 0, PSIZ2 - 1 - ZTEMP( PSIZ1+I+1 ) = Z( MID+PERM( PRMPTR( CURR+1 )+I )-1 ) - 60 CONTINUE -* -* Multiply Blocks at CURR and CURR+1 -* -* Determine size of these matrices. We add HALF to the value of -* the SQRT in case the machine underestimates one of these -* square roots. -* - BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) ) - BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+ - $ 1 ) ) ) ) - IF( BSIZ1.GT.0 ) THEN - CALL DGEMV( 'T', BSIZ1, BSIZ1, ONE, Q( QPTR( CURR ) ), - $ BSIZ1, ZTEMP( 1 ), 1, ZERO, Z( ZPTR1 ), 1 ) - END IF - CALL DCOPY( PSIZ1-BSIZ1, ZTEMP( BSIZ1+1 ), 1, Z( ZPTR1+BSIZ1 ), - $ 1 ) - IF( BSIZ2.GT.0 ) THEN - CALL DGEMV( 'T', BSIZ2, BSIZ2, ONE, Q( QPTR( CURR+1 ) ), - $ BSIZ2, ZTEMP( PSIZ1+1 ), 1, ZERO, Z( MID ), 1 ) - END IF - CALL DCOPY( PSIZ2-BSIZ2, ZTEMP( PSIZ1+BSIZ2+1 ), 1, - $ Z( MID+BSIZ2 ), 1 ) -* - PTR = PTR + 2**( TLVLS-K ) - 70 CONTINUE -* - RETURN -* -* End of DLAEDA -* - END diff --git a/lib/linalg/fortran/dlaev2.f b/lib/linalg/fortran/dlaev2.f deleted file mode 100644 index 9e29991a6d..0000000000 --- a/lib/linalg/fortran/dlaev2.f +++ /dev/null @@ -1,235 +0,0 @@ -*> \brief \b DLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAEV2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix -*> [ A B ] -*> [ B C ]. -*> On return, RT1 is the eigenvalue of larger absolute value, RT2 is the -*> eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right -*> eigenvector for RT1, giving the decomposition -*> -*> [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] -*> [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION -*> The (1,1) element of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION -*> The (1,2) element and the conjugate of the (2,1) element of -*> the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[in] C -*> \verbatim -*> C is DOUBLE PRECISION -*> The (2,2) element of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[out] RT1 -*> \verbatim -*> RT1 is DOUBLE PRECISION -*> The eigenvalue of larger absolute value. -*> \endverbatim -*> -*> \param[out] RT2 -*> \verbatim -*> RT2 is DOUBLE PRECISION -*> The eigenvalue of smaller absolute value. -*> \endverbatim -*> -*> \param[out] CS1 -*> \verbatim -*> CS1 is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[out] SN1 -*> \verbatim -*> SN1 is DOUBLE PRECISION -*> The vector (CS1, SN1) is a unit right eigenvector for RT1. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> RT1 is accurate to a few ulps barring over/underflow. -*> -*> RT2 may be inaccurate if there is massive cancellation in the -*> determinant A*C-B*B; higher precision or correctly rounded or -*> correctly truncated arithmetic would be needed to compute RT2 -*> accurately in all cases. -*> -*> CS1 and SN1 are accurate to a few ulps barring over/underflow. -*> -*> Overflow is possible only if RT1 is within a factor of 5 of overflow. -*> Underflow is harmless if the input data is 0 or exceeds -*> underflow_threshold / macheps. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION HALF - PARAMETER ( HALF = 0.5D0 ) -* .. -* .. Local Scalars .. - INTEGER SGN1, SGN2 - DOUBLE PRECISION AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM, - $ TB, TN -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. -* -* Compute the eigenvalues -* - SM = A + C - DF = A - C - ADF = ABS( DF ) - TB = B + B - AB = ABS( TB ) - IF( ABS( A ).GT.ABS( C ) ) THEN - ACMX = A - ACMN = C - ELSE - ACMX = C - ACMN = A - END IF - IF( ADF.GT.AB ) THEN - RT = ADF*SQRT( ONE+( AB / ADF )**2 ) - ELSE IF( ADF.LT.AB ) THEN - RT = AB*SQRT( ONE+( ADF / AB )**2 ) - ELSE -* -* Includes case AB=ADF=0 -* - RT = AB*SQRT( TWO ) - END IF - IF( SM.LT.ZERO ) THEN - RT1 = HALF*( SM-RT ) - SGN1 = -1 -* -* Order of execution important. -* To get fully accurate smaller eigenvalue, -* next line needs to be executed in higher precision. -* - RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B - ELSE IF( SM.GT.ZERO ) THEN - RT1 = HALF*( SM+RT ) - SGN1 = 1 -* -* Order of execution important. -* To get fully accurate smaller eigenvalue, -* next line needs to be executed in higher precision. -* - RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B - ELSE -* -* Includes case RT1 = RT2 = 0 -* - RT1 = HALF*RT - RT2 = -HALF*RT - SGN1 = 1 - END IF -* -* Compute the eigenvector -* - IF( DF.GE.ZERO ) THEN - CS = DF + RT - SGN2 = 1 - ELSE - CS = DF - RT - SGN2 = -1 - END IF - ACS = ABS( CS ) - IF( ACS.GT.AB ) THEN - CT = -TB / CS - SN1 = ONE / SQRT( ONE+CT*CT ) - CS1 = CT*SN1 - ELSE - IF( AB.EQ.ZERO ) THEN - CS1 = ONE - SN1 = ZERO - ELSE - TN = -CS / TB - CS1 = ONE / SQRT( ONE+TN*TN ) - SN1 = TN*CS1 - END IF - END IF - IF( SGN1.EQ.SGN2 ) THEN - TN = CS1 - CS1 = -SN1 - SN1 = TN - END IF - RETURN -* -* End of DLAEV2 -* - END diff --git a/lib/linalg/fortran/dlaisnan.f b/lib/linalg/fortran/dlaisnan.f deleted file mode 100644 index 2caf5fb1d0..0000000000 --- a/lib/linalg/fortran/dlaisnan.f +++ /dev/null @@ -1,88 +0,0 @@ -*> \brief \b DLAISNAN tests input for NaN by comparing two arguments for inequality. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAISNAN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2 -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> This routine is not for general use. It exists solely to avoid -*> over-optimization in DISNAN. -*> -*> DLAISNAN checks for NaNs by comparing its two arguments for -*> inequality. NaN is the only floating-point value where NaN != NaN -*> returns .TRUE. To check for NaNs, pass the same variable as both -*> arguments. -*> -*> A compiler must assume that the two arguments are -*> not the same variable, and the test will not be optimized away. -*> Interprocedural or whole-program optimization may delete this -*> test. The ISNAN functions will be replaced by the correct -*> Fortran 03 intrinsic once the intrinsic is widely available. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] DIN1 -*> \verbatim -*> DIN1 is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] DIN2 -*> \verbatim -*> DIN2 is DOUBLE PRECISION -*> Two numbers to compare for inequality. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2 -* .. -* -* ===================================================================== -* -* .. Executable Statements .. - DLAISNAN = (DIN1.NE.DIN2) - RETURN - END diff --git a/lib/linalg/fortran/dlals0.f b/lib/linalg/fortran/dlals0.f deleted file mode 100644 index cfca222806..0000000000 --- a/lib/linalg/fortran/dlals0.f +++ /dev/null @@ -1,496 +0,0 @@ -*> \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. -* -*> \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 -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. 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/fortran/dlalsa.f b/lib/linalg/fortran/dlalsa.f deleted file mode 100644 index da8e0fa175..0000000000 --- a/lib/linalg/fortran/dlalsa.f +++ /dev/null @@ -1,490 +0,0 @@ -*> \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. -* -*> \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 -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. 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/fortran/dlalsd.f b/lib/linalg/fortran/dlalsd.f deleted file mode 100644 index d22c45dc6e..0000000000 --- a/lib/linalg/fortran/dlalsd.f +++ /dev/null @@ -1,520 +0,0 @@ -*> \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. -* -*> \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 -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. 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/fortran/dlamch.f b/lib/linalg/fortran/dlamch.f deleted file mode 100644 index 76f875cef6..0000000000 --- a/lib/linalg/fortran/dlamch.f +++ /dev/null @@ -1,189 +0,0 @@ -*> \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.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 -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, - $ MINEXPONENT, RADIX, TINY -* .. -* .. Executable Statements .. -* -* -* Assume rounding, not chopping. Always. -* - RND = ONE -* - IF( ONE.EQ.RND ) THEN - EPS = EPSILON(ZERO) * 0.5 - ELSE - EPS = EPSILON(ZERO) - END IF -* - IF( LSAME( CMACH, 'E' ) ) THEN - RMACH = EPS - ELSE IF( LSAME( CMACH, 'S' ) ) THEN - SFMIN = TINY(ZERO) - SMALL = ONE / HUGE(ZERO) - IF( SMALL.GE.SFMIN ) THEN -* -* Use SMALL plus a bit, to avoid the possibility of rounding -* causing overflow when computing 1/sfmin. -* - SFMIN = SMALL*( ONE+EPS ) - END IF - RMACH = SFMIN - ELSE IF( LSAME( CMACH, 'B' ) ) THEN - RMACH = RADIX(ZERO) - ELSE IF( LSAME( CMACH, 'P' ) ) THEN - RMACH = EPS * RADIX(ZERO) - ELSE IF( LSAME( CMACH, 'N' ) ) THEN - RMACH = DIGITS(ZERO) - ELSE IF( LSAME( CMACH, 'R' ) ) THEN - RMACH = RND - ELSE IF( LSAME( CMACH, 'M' ) ) THEN - RMACH = MINEXPONENT(ZERO) - ELSE IF( LSAME( CMACH, 'U' ) ) THEN - RMACH = tiny(zero) - ELSE IF( LSAME( CMACH, 'L' ) ) THEN - RMACH = MAXEXPONENT(ZERO) - ELSE IF( LSAME( CMACH, 'O' ) ) THEN - RMACH = HUGE(ZERO) - ELSE - RMACH = ZERO - END IF -* - DLAMCH = RMACH - RETURN -* -* End of DLAMCH -* - END -************************************************************************ -*> \brief \b DLAMC3 -*> \details -*> \b Purpose: -*> \verbatim -*> DLAMC3 is intended to force A and B to be stored prior to doing -*> the addition of A and B , for use in situations where optimizers -*> might hold one of these in a register. -*> \endverbatim -*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. -*> \date 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.7.0) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2010 -* -* .. Scalar Arguments .. - DOUBLE PRECISION A, B -* .. -* ===================================================================== -* -* .. Executable Statements .. -* - DLAMC3 = A + B -* - RETURN -* -* End of DLAMC3 -* - END -* -************************************************************************ diff --git a/lib/linalg/fortran/dlamrg.f b/lib/linalg/fortran/dlamrg.f deleted file mode 100644 index 80bd354b97..0000000000 --- a/lib/linalg/fortran/dlamrg.f +++ /dev/null @@ -1,168 +0,0 @@ -*> \brief \b DLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single set sorted in ascending order. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAMRG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) -* -* .. Scalar Arguments .. -* INTEGER DTRD1, DTRD2, N1, N2 -* .. -* .. Array Arguments .. -* INTEGER INDEX( * ) -* DOUBLE PRECISION A( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAMRG will create a permutation list which will merge the elements -*> of A (which is composed of two independently sorted sets) into a -*> single set which is sorted in ascending order. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N1 -*> \verbatim -*> N1 is INTEGER -*> \endverbatim -*> -*> \param[in] N2 -*> \verbatim -*> N2 is INTEGER -*> These arguments contain the respective lengths of the two -*> sorted lists to be merged. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (N1+N2) -*> The first N1 elements of A contain a list of numbers which -*> are sorted in either ascending or descending order. Likewise -*> for the final N2 elements. -*> \endverbatim -*> -*> \param[in] DTRD1 -*> \verbatim -*> DTRD1 is INTEGER -*> \endverbatim -*> -*> \param[in] DTRD2 -*> \verbatim -*> DTRD2 is INTEGER -*> These are the strides to be taken through the array A. -*> Allowable strides are 1 and -1. They indicate whether a -*> subset of A is sorted in ascending (DTRDx = 1) or descending -*> (DTRDx = -1) order. -*> \endverbatim -*> -*> \param[out] INDEX -*> \verbatim -*> INDEX is INTEGER array, dimension (N1+N2) -*> On exit this array will contain a permutation such that -*> if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be -*> sorted in ascending order. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER DTRD1, DTRD2, N1, N2 -* .. -* .. Array Arguments .. - INTEGER INDEX( * ) - DOUBLE PRECISION A( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IND1, IND2, N1SV, N2SV -* .. -* .. Executable Statements .. -* - N1SV = N1 - N2SV = N2 - IF( DTRD1.GT.0 ) THEN - IND1 = 1 - ELSE - IND1 = N1 - END IF - IF( DTRD2.GT.0 ) THEN - IND2 = 1 + N1 - ELSE - IND2 = N1 + N2 - END IF - I = 1 -* while ( (N1SV > 0) & (N2SV > 0) ) - 10 CONTINUE - IF( N1SV.GT.0 .AND. N2SV.GT.0 ) THEN - IF( A( IND1 ).LE.A( IND2 ) ) THEN - INDEX( I ) = IND1 - I = I + 1 - IND1 = IND1 + DTRD1 - N1SV = N1SV - 1 - ELSE - INDEX( I ) = IND2 - I = I + 1 - IND2 = IND2 + DTRD2 - N2SV = N2SV - 1 - END IF - GO TO 10 - END IF -* end while - IF( N1SV.EQ.0 ) THEN - DO 20 N1SV = 1, N2SV - INDEX( I ) = IND2 - I = I + 1 - IND2 = IND2 + DTRD2 - 20 CONTINUE - ELSE -* N2SV .EQ. 0 - DO 30 N2SV = 1, N1SV - INDEX( I ) = IND1 - I = I + 1 - IND1 = IND1 + DTRD1 - 30 CONTINUE - END IF -* - RETURN -* -* End of DLAMRG -* - END diff --git a/lib/linalg/fortran/dlange.f b/lib/linalg/fortran/dlange.f deleted file mode 100644 index 9d214cb542..0000000000 --- a/lib/linalg/fortran/dlange.f +++ /dev/null @@ -1,208 +0,0 @@ -*> \brief \b DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of a general rectangular matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLANGE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) -* -* .. Scalar Arguments .. -* CHARACTER NORM -* INTEGER LDA, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLANGE returns the value of the one norm, or the Frobenius norm, or -*> the infinity norm, or the element of largest absolute value of a -*> real matrix A. -*> \endverbatim -*> -*> \return DLANGE -*> \verbatim -*> -*> DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' -*> ( -*> ( norm1(A), NORM = '1', 'O' or 'o' -*> ( -*> ( normI(A), NORM = 'I' or 'i' -*> ( -*> ( normF(A), NORM = 'F', 'f', 'E' or 'e' -*> -*> where norm1 denotes the one norm of a matrix (maximum column sum), -*> normI denotes the infinity norm of a matrix (maximum row sum) and -*> normF denotes the Frobenius norm of a matrix (square root of sum of -*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] NORM -*> \verbatim -*> NORM is CHARACTER*1 -*> Specifies the value to be returned in DLANGE as described -*> above. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. M >= 0. When M = 0, -*> DLANGE is set to zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. N >= 0. When N = 0, -*> DLANGE is set to zero. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The m by n matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(M,1). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), -*> where LWORK >= M when NORM = 'I'; otherwise, WORK is not -*> referenced. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEauxiliary -* -* ===================================================================== - DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER NORM - INTEGER LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION SCALE, SUM, VALUE, TEMP -* .. -* .. External Subroutines .. - EXTERNAL DLASSQ -* .. -* .. External Functions .. - LOGICAL LSAME, DISNAN - EXTERNAL LSAME, DISNAN -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MIN, SQRT -* .. -* .. Executable Statements .. -* - IF( MIN( M, N ).EQ.0 ) THEN - VALUE = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - VALUE = ZERO - DO 20 J = 1, N - DO 10 I = 1, M - TEMP = ABS( A( I, J ) ) - IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP - 10 CONTINUE - 20 CONTINUE - ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN -* -* Find norm1(A). -* - VALUE = ZERO - DO 40 J = 1, N - SUM = ZERO - DO 30 I = 1, M - SUM = SUM + ABS( A( I, J ) ) - 30 CONTINUE - IF( VALUE.LT.SUM .OR. DISNAN( SUM ) ) VALUE = SUM - 40 CONTINUE - ELSE IF( LSAME( NORM, 'I' ) ) THEN -* -* Find normI(A). -* - DO 50 I = 1, M - WORK( I ) = ZERO - 50 CONTINUE - DO 70 J = 1, N - DO 60 I = 1, M - WORK( I ) = WORK( I ) + ABS( A( I, J ) ) - 60 CONTINUE - 70 CONTINUE - VALUE = ZERO - DO 80 I = 1, M - TEMP = WORK( I ) - IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP - 80 CONTINUE - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - DO 90 J = 1, N - CALL DLASSQ( M, A( 1, J ), 1, SCALE, SUM ) - 90 CONTINUE - VALUE = SCALE*SQRT( SUM ) - END IF -* - DLANGE = VALUE - RETURN -* -* End of DLANGE -* - END diff --git a/lib/linalg/fortran/dlanst.f b/lib/linalg/fortran/dlanst.f deleted file mode 100644 index c5bc7ea038..0000000000 --- a/lib/linalg/fortran/dlanst.f +++ /dev/null @@ -1,183 +0,0 @@ -*> \brief \b DLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric tridiagonal matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLANST + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) -* -* .. Scalar Arguments .. -* CHARACTER NORM -* INTEGER N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ), E( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLANST returns the value of the one norm, or the Frobenius norm, or -*> the infinity norm, or the element of largest absolute value of a -*> real symmetric tridiagonal matrix A. -*> \endverbatim -*> -*> \return DLANST -*> \verbatim -*> -*> DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm' -*> ( -*> ( norm1(A), NORM = '1', 'O' or 'o' -*> ( -*> ( normI(A), NORM = 'I' or 'i' -*> ( -*> ( normF(A), NORM = 'F', 'f', 'E' or 'e' -*> -*> where norm1 denotes the one norm of a matrix (maximum column sum), -*> normI denotes the infinity norm of a matrix (maximum row sum) and -*> normF denotes the Frobenius norm of a matrix (square root of sum of -*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] NORM -*> \verbatim -*> NORM is CHARACTER*1 -*> Specifies the value to be returned in DLANST as described -*> above. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. When N = 0, DLANST is -*> set to zero. -*> \endverbatim -*> -*> \param[in] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> The diagonal elements of A. -*> \endverbatim -*> -*> \param[in] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> The (n-1) sub-diagonal or super-diagonal elements of A. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER NORM - INTEGER N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I - DOUBLE PRECISION ANORM, SCALE, SUM -* .. -* .. External Functions .. - LOGICAL LSAME, DISNAN - EXTERNAL LSAME, DISNAN -* .. -* .. External Subroutines .. - EXTERNAL DLASSQ -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. -* - IF( N.LE.0 ) THEN - ANORM = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - ANORM = ABS( D( N ) ) - DO 10 I = 1, N - 1 - SUM = ABS( D( I ) ) - IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM - SUM = ABS( E( I ) ) - IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM - 10 CONTINUE - ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. - $ LSAME( NORM, 'I' ) ) THEN -* -* Find norm1(A). -* - IF( N.EQ.1 ) THEN - ANORM = ABS( D( 1 ) ) - ELSE - ANORM = ABS( D( 1 ) )+ABS( E( 1 ) ) - SUM = ABS( E( N-1 ) )+ABS( D( N ) ) - IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM - DO 20 I = 2, N - 1 - SUM = ABS( D( I ) )+ABS( E( I ) )+ABS( E( I-1 ) ) - IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM - 20 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - IF( N.GT.1 ) THEN - CALL DLASSQ( N-1, E, 1, SCALE, SUM ) - SUM = 2*SUM - END IF - CALL DLASSQ( N, D, 1, SCALE, SUM ) - ANORM = SCALE*SQRT( SUM ) - END IF -* - DLANST = ANORM - RETURN -* -* End of DLANST -* - END diff --git a/lib/linalg/fortran/dlansy.f b/lib/linalg/fortran/dlansy.f deleted file mode 100644 index 949c5535a2..0000000000 --- a/lib/linalg/fortran/dlansy.f +++ /dev/null @@ -1,238 +0,0 @@ -*> \brief \b DLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLANSY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) -* -* .. Scalar Arguments .. -* CHARACTER NORM, UPLO -* INTEGER LDA, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLANSY returns the value of the one norm, or the Frobenius norm, or -*> the infinity norm, or the element of largest absolute value of a -*> real symmetric matrix A. -*> \endverbatim -*> -*> \return DLANSY -*> \verbatim -*> -*> DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm' -*> ( -*> ( norm1(A), NORM = '1', 'O' or 'o' -*> ( -*> ( normI(A), NORM = 'I' or 'i' -*> ( -*> ( normF(A), NORM = 'F', 'f', 'E' or 'e' -*> -*> where norm1 denotes the one norm of a matrix (maximum column sum), -*> normI denotes the infinity norm of a matrix (maximum row sum) and -*> normF denotes the Frobenius norm of a matrix (square root of sum of -*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] NORM -*> \verbatim -*> NORM is CHARACTER*1 -*> Specifies the value to be returned in DLANSY as described -*> above. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies whether the upper or lower triangular part of the -*> symmetric matrix A is to be referenced. -*> = 'U': Upper triangular part of A is referenced -*> = 'L': Lower triangular part of A is referenced -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. When N = 0, DLANSY is -*> set to zero. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The symmetric matrix A. If UPLO = 'U', the leading n by n -*> upper triangular part of A contains the upper triangular part -*> of the matrix A, and the strictly lower triangular part of A -*> is not referenced. If UPLO = 'L', the leading n by n lower -*> triangular part of A contains the lower triangular part of -*> the matrix A, and the strictly upper triangular part of A is -*> not referenced. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(N,1). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), -*> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, -*> WORK is not referenced. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleSYauxiliary -* -* ===================================================================== - DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER NORM, UPLO - INTEGER LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION ABSA, SCALE, SUM, VALUE -* .. -* .. External Subroutines .. - EXTERNAL DLASSQ -* .. -* .. External Functions .. - LOGICAL LSAME, DISNAN - EXTERNAL LSAME, DISNAN -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. -* - IF( N.EQ.0 ) THEN - VALUE = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, J - SUM = ABS( A( I, J ) ) - IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1, N - DO 30 I = J, N - SUM = ABS( A( I, J ) ) - IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM - 30 CONTINUE - 40 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. - $ ( NORM.EQ.'1' ) ) THEN -* -* Find normI(A) ( = norm1(A), since A is symmetric). -* - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - DO 60 J = 1, N - SUM = ZERO - DO 50 I = 1, J - 1 - ABSA = ABS( A( I, J ) ) - SUM = SUM + ABSA - WORK( I ) = WORK( I ) + ABSA - 50 CONTINUE - WORK( J ) = SUM + ABS( A( J, J ) ) - 60 CONTINUE - DO 70 I = 1, N - SUM = WORK( I ) - IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM - 70 CONTINUE - ELSE - DO 80 I = 1, N - WORK( I ) = ZERO - 80 CONTINUE - DO 100 J = 1, N - SUM = WORK( J ) + ABS( A( J, J ) ) - DO 90 I = J + 1, N - ABSA = ABS( A( I, J ) ) - SUM = SUM + ABSA - WORK( I ) = WORK( I ) + ABSA - 90 CONTINUE - IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM - 100 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - IF( LSAME( UPLO, 'U' ) ) THEN - DO 110 J = 2, N - CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) - 110 CONTINUE - ELSE - DO 120 J = 1, N - 1 - CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) - 120 CONTINUE - END IF - SUM = 2*SUM - CALL DLASSQ( N, A, LDA+1, SCALE, SUM ) - VALUE = SCALE*SQRT( SUM ) - END IF -* - DLANSY = VALUE - RETURN -* -* End of DLANSY -* - END diff --git a/lib/linalg/fortran/dlapy2.f b/lib/linalg/fortran/dlapy2.f deleted file mode 100644 index 1f63193bb7..0000000000 --- a/lib/linalg/fortran/dlapy2.f +++ /dev/null @@ -1,117 +0,0 @@ -*> \brief \b DLAPY2 returns sqrt(x2+y2). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAPY2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION X, Y -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary -*> overflow and unnecessary underflow. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] X -*> \verbatim -*> X is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] Y -*> \verbatim -*> Y is DOUBLE PRECISION -*> X and Y specify the values x and y. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION X, Y -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION W, XABS, YABS, Z, HUGEVAL - LOGICAL X_IS_NAN, Y_IS_NAN -* .. -* .. External Functions .. - LOGICAL DISNAN - EXTERNAL DISNAN -* .. -* .. External Subroutines .. - DOUBLE PRECISION DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - X_IS_NAN = DISNAN( X ) - Y_IS_NAN = DISNAN( Y ) - IF ( X_IS_NAN ) DLAPY2 = X - IF ( Y_IS_NAN ) DLAPY2 = Y - HUGEVAL = DLAMCH( 'Overflow' ) -* - 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 .OR. W.GT.HUGEVAL ) THEN - DLAPY2 = W - ELSE - DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) - END IF - END IF - RETURN -* -* End of DLAPY2 -* - END diff --git a/lib/linalg/fortran/dlapy3.f b/lib/linalg/fortran/dlapy3.f deleted file mode 100644 index 230a65cdb2..0000000000 --- a/lib/linalg/fortran/dlapy3.f +++ /dev/null @@ -1,112 +0,0 @@ -*> \brief \b DLAPY3 returns sqrt(x2+y2+z2). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAPY3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION X, Y, Z -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause -*> unnecessary overflow and unnecessary underflow. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] X -*> \verbatim -*> X is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] Y -*> \verbatim -*> Y is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION -*> X, Y and Z specify the values x, y and z. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION X, Y, Z -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION W, XABS, YABS, ZABS, HUGEVAL -* .. -* .. External Subroutines .. - DOUBLE PRECISION DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. -* .. Executable Statements .. -* - HUGEVAL = DLAMCH( 'Overflow' ) - XABS = ABS( X ) - YABS = ABS( Y ) - ZABS = ABS( Z ) - W = MAX( XABS, YABS, ZABS ) - IF( W.EQ.ZERO .OR. W.GT.HUGEVAL ) THEN -* W can be zero for max(0,nan,0) -* adding all three entries together will make sure -* NaN will not disappear. - DLAPY3 = XABS + YABS + ZABS - ELSE - DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+ - $ ( ZABS / W )**2 ) - END IF - RETURN -* -* End of DLAPY3 -* - END diff --git a/lib/linalg/fortran/dlarf.f b/lib/linalg/fortran/dlarf.f deleted file mode 100644 index ed21638645..0000000000 --- a/lib/linalg/fortran/dlarf.f +++ /dev/null @@ -1,224 +0,0 @@ -*> \brief \b DLARF applies an elementary reflector to a general rectangular matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLARF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE -* INTEGER INCV, LDC, M, N -* DOUBLE PRECISION TAU -* .. -* .. Array Arguments .. -* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLARF applies a real elementary reflector H to a real m by n matrix -*> C, from either the left or the right. H is represented in the form -*> -*> H = I - tau * v * v**T -*> -*> where tau is a real scalar and v is a real vector. -*> -*> If tau = 0, then H is taken to be the unit matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': form H * C -*> = 'R': form C * H -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. -*> \endverbatim -*> -*> \param[in] V -*> \verbatim -*> V is DOUBLE PRECISION array, dimension -*> (1 + (M-1)*abs(INCV)) if SIDE = 'L' -*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' -*> The vector v in the representation of H. V is not used if -*> TAU = 0. -*> \endverbatim -*> -*> \param[in] INCV -*> \verbatim -*> INCV is INTEGER -*> The increment between elements of v. INCV <> 0. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION -*> The value tau in the representation of H. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) -*> On entry, the m by n matrix C. -*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', -*> or C * H if SIDE = 'R'. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension -*> (N) if SIDE = 'L' -*> or (M) if SIDE = 'R' -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE - INTEGER INCV, LDC, M, N - DOUBLE PRECISION TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL APPLYLEFT - INTEGER I, LASTV, LASTC -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DGER -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILADLR, ILADLC - EXTERNAL LSAME, ILADLR, ILADLC -* .. -* .. Executable Statements .. -* - APPLYLEFT = LSAME( SIDE, 'L' ) - LASTV = 0 - LASTC = 0 - IF( TAU.NE.ZERO ) THEN -! Set up variables for scanning V. LASTV begins pointing to the end -! of V. - IF( APPLYLEFT ) THEN - LASTV = M - ELSE - LASTV = N - END IF - IF( INCV.GT.0 ) THEN - I = 1 + (LASTV-1) * INCV - ELSE - I = 1 - END IF -! Look for the last non-zero row in V. - DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) - LASTV = LASTV - 1 - I = I - INCV - END DO - IF( APPLYLEFT ) THEN -! Scan for the last non-zero column in C(1:lastv,:). - LASTC = ILADLC(LASTV, N, C, LDC) - ELSE -! Scan for the last non-zero row in C(:,1:lastv). - LASTC = ILADLR(M, LASTV, C, LDC) - END IF - END IF -! Note that lastc.eq.0 renders the BLAS operations null; no special -! case is needed at this level. - IF( APPLYLEFT ) THEN -* -* Form H * C -* - IF( LASTV.GT.0 ) THEN -* -* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) -* - CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV, - $ ZERO, WORK, 1 ) -* -* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T -* - CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) - END IF - ELSE -* -* Form C * H -* - IF( LASTV.GT.0 ) THEN -* -* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) -* - CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, - $ V, INCV, ZERO, WORK, 1 ) -* -* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T -* - CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) - END IF - END IF - RETURN -* -* End of DLARF -* - END diff --git a/lib/linalg/fortran/dlarfb.f b/lib/linalg/fortran/dlarfb.f deleted file mode 100644 index a3fa083b43..0000000000 --- a/lib/linalg/fortran/dlarfb.f +++ /dev/null @@ -1,709 +0,0 @@ -*> \brief \b DLARFB applies a block reflector or its transpose to a general rectangular matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLARFB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, -* T, LDT, C, LDC, WORK, LDWORK ) -* -* .. Scalar Arguments .. -* CHARACTER DIRECT, SIDE, STOREV, TRANS -* INTEGER K, LDC, LDT, LDV, LDWORK, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), -* $ WORK( LDWORK, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLARFB applies a real block reflector H or its transpose H**T to a -*> real m by n matrix C, from either the left or the right. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply H or H**T from the Left -*> = 'R': apply H or H**T from the Right -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': apply H (No transpose) -*> = 'T': apply H**T (Transpose) -*> \endverbatim -*> -*> \param[in] DIRECT -*> \verbatim -*> DIRECT is CHARACTER*1 -*> Indicates how H is formed from a product of elementary -*> reflectors -*> = 'F': H = H(1) H(2) . . . H(k) (Forward) -*> = 'B': H = H(k) . . . H(2) H(1) (Backward) -*> \endverbatim -*> -*> \param[in] STOREV -*> \verbatim -*> STOREV is CHARACTER*1 -*> Indicates how the vectors which define the elementary -*> reflectors are stored: -*> = 'C': Columnwise -*> = 'R': Rowwise -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The order of the matrix T (= the number of elementary -*> reflectors whose product defines the block reflector). -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] V -*> \verbatim -*> V is DOUBLE PRECISION array, dimension -*> (LDV,K) if STOREV = 'C' -*> (LDV,M) if STOREV = 'R' and SIDE = 'L' -*> (LDV,N) if STOREV = 'R' and SIDE = 'R' -*> The matrix V. See Further Details. -*> \endverbatim -*> -*> \param[in] LDV -*> \verbatim -*> LDV is INTEGER -*> The leading dimension of the array V. -*> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); -*> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); -*> if STOREV = 'R', LDV >= K. -*> \endverbatim -*> -*> \param[in] T -*> \verbatim -*> T is DOUBLE PRECISION array, dimension (LDT,K) -*> The triangular k by k matrix T in the representation of the -*> block reflector. -*> \endverbatim -*> -*> \param[in] LDT -*> \verbatim -*> LDT is INTEGER -*> The leading dimension of the array T. LDT >= K. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) -*> On entry, the m by n matrix C. -*> On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (LDWORK,K) -*> \endverbatim -*> -*> \param[in] LDWORK -*> \verbatim -*> LDWORK is INTEGER -*> The leading dimension of the array WORK. -*> If SIDE = 'L', LDWORK >= max(1,N); -*> if SIDE = 'R', LDWORK >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The shape of the matrix V and the storage of the vectors which define -*> the H(i) is best illustrated by the following example with n = 5 and -*> k = 3. The elements equal to 1 are not stored; the corresponding -*> array elements are modified but restored on exit. The rest of the -*> array is not used. -*> -*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -*> -*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -*> ( v1 1 ) ( 1 v2 v2 v2 ) -*> ( v1 v2 1 ) ( 1 v3 v3 ) -*> ( v1 v2 v3 ) -*> ( v1 v2 v3 ) -*> -*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -*> -*> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -*> ( v1 v2 v3 ) ( v2 v2 v2 1 ) -*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -*> ( 1 v3 ) -*> ( 1 ) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, - $ T, LDT, C, LDC, WORK, LDWORK ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, SIDE, STOREV, TRANS - INTEGER K, LDC, LDT, LDV, LDWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), - $ WORK( LDWORK, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - CHARACTER TRANST - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DTRMM -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - IF( LSAME( TRANS, 'N' ) ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF -* - IF( LSAME( STOREV, 'C' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 ) (first K rows) -* ( V2 ) -* where V1 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* -* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) -* -* W := C1**T -* - DO 10 J = 1, K - CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 10 CONTINUE -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, V, LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C2**T * V2 -* - 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', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W**T -* - IF( M.GT.K ) THEN -* -* C2 := C2 - V2 * W**T -* - 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', N, K, - $ ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W**T -* - DO 30 J = 1, K - DO 20 I = 1, N - C( J, I ) = C( J, I ) - WORK( I, J ) - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C1 -* - DO 40 J = 1, K - CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) - 40 CONTINUE -* -* W := W * V1 -* - 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', 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', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V**T -* - IF( N.GT.K ) THEN -* -* C2 := C2 - W * V2**T -* - 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', M, K, - $ ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 60 J = 1, K - DO 50 I = 1, M - C( I, J ) = C( I, J ) - WORK( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF -* - ELSE -* -* Let V = ( V1 ) -* ( V2 ) (last K rows) -* where V2 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* -* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) -* -* W := C2**T -* - DO 70 J = 1, K - 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', N, - $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C1**T * V1 -* - 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', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W**T -* - IF( M.GT.K ) THEN -* -* C1 := C1 - V1 * W**T -* - 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', N, K, - $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) -* -* C2 := C2 - W**T -* - DO 90 J = 1, K - 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 ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C2 -* - DO 100 J = 1, K - 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', 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', 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', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V**T -* - IF( N.GT.K ) THEN -* -* C1 := C1 - W * V1**T -* - 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', M, K, - $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) -* -* C2 := C2 - W -* - DO 120 J = 1, K - DO 110 I = 1, M - C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) - 110 CONTINUE - 120 CONTINUE - END IF - END IF -* - ELSE IF( LSAME( STOREV, 'R' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 V2 ) (V1: first K columns) -* where V1 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* -* 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( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 130 CONTINUE -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, - $ ONE, V, LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C2**T * V2**T -* - 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', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V**T * W**T -* - IF( M.GT.K ) THEN -* -* C2 := C2 - V2**T * W**T -* - 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', N, - $ K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W**T -* - DO 150 J = 1, K - DO 140 I = 1, N - C( J, I ) = C( J, I ) - WORK( I, J ) - 140 CONTINUE - 150 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* -* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) -* -* W := C1 -* - DO 160 J = 1, K - CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) - 160 CONTINUE -* -* W := W * V1**T -* - 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', 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', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( N.GT.K ) THEN -* -* C2 := C2 - W * V2 -* - 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', M, - $ K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 180 J = 1, K - DO 170 I = 1, M - C( I, J ) = C( I, J ) - WORK( I, J ) - 170 CONTINUE - 180 CONTINUE -* - END IF -* - ELSE -* -* Let V = ( V1 V2 ) (V2: last K columns) -* where V2 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* -* 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( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) - 190 CONTINUE -* -* W := W * V2**T -* - 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', 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', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V**T * W**T -* - IF( M.GT.K ) THEN -* -* C1 := C1 - V1**T * W**T -* - 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', N, - $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) -* -* C2 := C2 - W**T -* - DO 210 J = 1, K - 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' 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( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) - 220 CONTINUE -* -* W := W * V2**T -* - 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', 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', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( N.GT.K ) THEN -* -* C1 := C1 - W * V1 -* - 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', M, - $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 240 J = 1, K - DO 230 I = 1, M - C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) - 230 CONTINUE - 240 CONTINUE -* - END IF -* - END IF - END IF -* - RETURN -* -* End of DLARFB -* - END diff --git a/lib/linalg/fortran/dlarfg.f b/lib/linalg/fortran/dlarfg.f deleted file mode 100644 index 9bfb45a6b0..0000000000 --- a/lib/linalg/fortran/dlarfg.f +++ /dev/null @@ -1,193 +0,0 @@ -*> \brief \b DLARFG generates an elementary reflector (Householder matrix). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLARFG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) -* -* .. Scalar Arguments .. -* INTEGER INCX, N -* DOUBLE PRECISION ALPHA, TAU -* .. -* .. Array Arguments .. -* DOUBLE PRECISION X( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLARFG generates a real elementary reflector H of order n, such -*> that -*> -*> H * ( alpha ) = ( beta ), H**T * H = I. -*> ( x ) ( 0 ) -*> -*> where alpha and beta are scalars, and x is an (n-1)-element real -*> vector. H is represented in the form -*> -*> H = I - tau * ( 1 ) * ( 1 v**T ) , -*> ( v ) -*> -*> where tau is a real scalar and v is a real (n-1)-element -*> vector. -*> -*> If the elements of x are all zero, then tau = 0 and H is taken to be -*> the unit matrix. -*> -*> Otherwise 1 <= tau <= 2. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the elementary reflector. -*> \endverbatim -*> -*> \param[in,out] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION -*> On entry, the value alpha. -*> On exit, it is overwritten with the value beta. -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension -*> (1+(N-2)*abs(INCX)) -*> On entry, the vector x. -*> On exit, it is overwritten with the vector v. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> The increment between elements of X. INCX > 0. -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION -*> The value tau. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX, N - DOUBLE PRECISION ALPHA, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION X( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER J, KNT - DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 - EXTERNAL DLAMCH, DLAPY2, DNRM2 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SIGN -* .. -* .. External Subroutines .. - EXTERNAL DSCAL -* .. -* .. Executable Statements .. -* - IF( N.LE.1 ) THEN - TAU = ZERO - RETURN - END IF -* - XNORM = DNRM2( N-1, X, INCX ) -* - IF( XNORM.EQ.ZERO ) THEN -* -* H = I -* - TAU = ZERO - ELSE -* -* general case -* - BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) - SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) - KNT = 0 - IF( ABS( BETA ).LT.SAFMIN ) THEN -* -* XNORM, BETA may be inaccurate; scale X and recompute them -* - RSAFMN = ONE / SAFMIN - 10 CONTINUE - KNT = KNT + 1 - CALL DSCAL( N-1, RSAFMN, X, INCX ) - BETA = BETA*RSAFMN - ALPHA = ALPHA*RSAFMN - IF( (ABS( BETA ).LT.SAFMIN) .AND. (KNT .LT. 20) ) - $ GO TO 10 -* -* New BETA is at most 1, at least SAFMIN -* - XNORM = DNRM2( N-1, X, INCX ) - BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) - END IF - TAU = ( BETA-ALPHA ) / BETA - CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) -* -* If ALPHA is subnormal, it may lose relative accuracy -* - DO 20 J = 1, KNT - BETA = BETA*SAFMIN - 20 CONTINUE - ALPHA = BETA - END IF -* - RETURN -* -* End of DLARFG -* - END diff --git a/lib/linalg/fortran/dlarft.f b/lib/linalg/fortran/dlarft.f deleted file mode 100644 index a8d9de61f1..0000000000 --- a/lib/linalg/fortran/dlarft.f +++ /dev/null @@ -1,323 +0,0 @@ -*> \brief \b DLARFT forms the triangular factor T of a block reflector H = I - vtvH -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLARFT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* -* .. Scalar Arguments .. -* CHARACTER DIRECT, STOREV -* INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLARFT forms the triangular factor T of a real block reflector H -*> of order n, which is defined as a product of k elementary reflectors. -*> -*> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; -*> -*> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. -*> -*> If STOREV = 'C', the vector which defines the elementary reflector -*> H(i) is stored in the i-th column of the array V, and -*> -*> H = I - V * T * V**T -*> -*> If STOREV = 'R', the vector which defines the elementary reflector -*> H(i) is stored in the i-th row of the array V, and -*> -*> H = I - V**T * T * V -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] DIRECT -*> \verbatim -*> DIRECT is CHARACTER*1 -*> Specifies the order in which the elementary reflectors are -*> multiplied to form the block reflector: -*> = 'F': H = H(1) H(2) . . . H(k) (Forward) -*> = 'B': H = H(k) . . . H(2) H(1) (Backward) -*> \endverbatim -*> -*> \param[in] STOREV -*> \verbatim -*> STOREV is CHARACTER*1 -*> Specifies how the vectors which define the elementary -*> reflectors are stored (see also Further Details): -*> = 'C': columnwise -*> = 'R': rowwise -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the block reflector H. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The order of the triangular factor T (= the number of -*> elementary reflectors). K >= 1. -*> \endverbatim -*> -*> \param[in] V -*> \verbatim -*> V is DOUBLE PRECISION array, dimension -*> (LDV,K) if STOREV = 'C' -*> (LDV,N) if STOREV = 'R' -*> The matrix V. See further details. -*> \endverbatim -*> -*> \param[in] LDV -*> \verbatim -*> LDV is INTEGER -*> The leading dimension of the array V. -*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i). -*> \endverbatim -*> -*> \param[out] T -*> \verbatim -*> T is DOUBLE PRECISION array, dimension (LDT,K) -*> The k by k triangular factor T of the block reflector. -*> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is -*> lower triangular. The rest of the array is not used. -*> \endverbatim -*> -*> \param[in] LDT -*> \verbatim -*> LDT is INTEGER -*> The leading dimension of the array T. LDT >= K. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The shape of the matrix V and the storage of the vectors which define -*> the H(i) is best illustrated by the following example with n = 5 and -*> k = 3. The elements equal to 1 are not stored. -*> -*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -*> -*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -*> ( v1 1 ) ( 1 v2 v2 v2 ) -*> ( v1 v2 1 ) ( 1 v3 v3 ) -*> ( v1 v2 v3 ) -*> ( v1 v2 v3 ) -*> -*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -*> -*> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -*> ( v1 v2 v3 ) ( v2 v2 v2 1 ) -*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -*> ( 1 v3 ) -*> ( 1 ) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, STOREV - INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, PREVLASTV, LASTV -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DTRMV -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( LSAME( DIRECT, 'F' ) ) THEN - PREVLASTV = N - DO I = 1, K - PREVLASTV = MAX( I, PREVLASTV ) - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = 1, I - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * V( I , J ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) -* - CALL DGEMV( 'Transpose', J-I, I-1, -TAU( I ), - $ V( I+1, 1 ), LDV, V( I+1, I ), 1, ONE, - $ T( 1, I ), 1 ) - ELSE -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * V( J , I ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T -* - CALL DGEMV( 'No transpose', I-1, J-I, -TAU( I ), - $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, ONE, - $ T( 1, I ), 1 ) - END IF -* -* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) -* - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, - $ LDT, T( 1, I ), 1 ) - T( I, I ) = TAU( I ) - IF( I.GT.1 ) THEN - PREVLASTV = MAX( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - END DO - ELSE - PREVLASTV = 1 - DO I = K, 1, -1 - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = I, K - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( I.LT.K ) THEN - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - DO J = I+1, K - T( J, I ) = -TAU( I ) * V( N-K+I , J ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) -* - CALL DGEMV( 'Transpose', N-K+I-J, K-I, -TAU( I ), - $ V( J, I+1 ), LDV, V( J, I ), 1, ONE, - $ T( I+1, I ), 1 ) - ELSE -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - DO J = I+1, K - T( J, I ) = -TAU( I ) * V( J, N-K+I ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T -* - CALL DGEMV( 'No transpose', K-I, N-K+I-J, - $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, - $ ONE, T( I+1, I ), 1 ) - END IF -* -* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) -* - CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, - $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) - IF( I.GT.1 ) THEN - PREVLASTV = MIN( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - T( I, I ) = TAU( I ) - END IF - END DO - END IF - RETURN -* -* End of DLARFT -* - END diff --git a/lib/linalg/fortran/dlartg.f b/lib/linalg/fortran/dlartg.f deleted file mode 100644 index 1c7c46f638..0000000000 --- a/lib/linalg/fortran/dlartg.f +++ /dev/null @@ -1,204 +0,0 @@ -*> \brief \b DLARTG generates a plane rotation with real cosine and real sine. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLARTG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLARTG( F, G, CS, SN, R ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION CS, F, G, R, SN -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLARTG generate a plane rotation so that -*> -*> [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. -*> [ -SN CS ] [ G ] [ 0 ] -*> -*> This is a slower, more accurate version of the BLAS1 routine DROTG, -*> with the following other differences: -*> F and G are unchanged on return. -*> If G=0, then CS=1 and SN=0. -*> If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any -*> floating point operations (saves work in DBDSQR when -*> there are zeros on the diagonal). -*> -*> If F exceeds G in magnitude, CS will be positive. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] F -*> \verbatim -*> F is DOUBLE PRECISION -*> The first component of vector to be rotated. -*> \endverbatim -*> -*> \param[in] G -*> \verbatim -*> G is DOUBLE PRECISION -*> The second component of vector to be rotated. -*> \endverbatim -*> -*> \param[out] CS -*> \verbatim -*> CS is DOUBLE PRECISION -*> The cosine of the rotation. -*> \endverbatim -*> -*> \param[out] SN -*> \verbatim -*> SN is DOUBLE PRECISION -*> The sine of the rotation. -*> \endverbatim -*> -*> \param[out] R -*> \verbatim -*> R is DOUBLE PRECISION -*> The nonzero component of the rotated vector. -*> -*> This version has a few statements commented out for thread safety -*> (machine parameters are computed on each entry). 10 feb 03, SJH. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date December 2016 -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLARTG( F, G, CS, SN, R ) -* -* -- 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 .. - DOUBLE PRECISION CS, F, G, R, SN -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) -* .. -* .. Local Scalars .. -* LOGICAL FIRST - INTEGER COUNT, I - DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, INT, LOG, MAX, SQRT -* .. -* .. Save statement .. -* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 -* .. -* .. Data statements .. -* DATA FIRST / .TRUE. / -* .. -* .. Executable Statements .. -* -* IF( FIRST ) THEN - SAFMIN = DLAMCH( 'S' ) - EPS = DLAMCH( 'E' ) - SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / - $ LOG( DLAMCH( 'B' ) ) / TWO ) - SAFMX2 = ONE / SAFMN2 -* FIRST = .FALSE. -* END IF - IF( G.EQ.ZERO ) THEN - CS = ONE - SN = ZERO - R = F - ELSE IF( F.EQ.ZERO ) THEN - CS = ZERO - SN = ONE - R = G - ELSE - F1 = F - G1 = G - SCALE = MAX( ABS( F1 ), ABS( G1 ) ) - IF( SCALE.GE.SAFMX2 ) THEN - COUNT = 0 - 10 CONTINUE - COUNT = COUNT + 1 - F1 = F1*SAFMN2 - G1 = G1*SAFMN2 - SCALE = MAX( ABS( F1 ), ABS( G1 ) ) - IF( SCALE.GE.SAFMX2 ) - $ GO TO 10 - R = SQRT( F1**2+G1**2 ) - CS = F1 / R - SN = G1 / R - DO 20 I = 1, COUNT - R = R*SAFMX2 - 20 CONTINUE - ELSE IF( SCALE.LE.SAFMN2 ) THEN - COUNT = 0 - 30 CONTINUE - COUNT = COUNT + 1 - F1 = F1*SAFMX2 - G1 = G1*SAFMX2 - SCALE = MAX( ABS( F1 ), ABS( G1 ) ) - IF( SCALE.LE.SAFMN2 ) - $ GO TO 30 - R = SQRT( F1**2+G1**2 ) - CS = F1 / R - SN = G1 / R - DO 40 I = 1, COUNT - R = R*SAFMN2 - 40 CONTINUE - ELSE - R = SQRT( F1**2+G1**2 ) - CS = F1 / R - SN = G1 / R - END IF - IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN - CS = -CS - SN = -SN - R = -R - END IF - END IF - RETURN -* -* End of DLARTG -* - END diff --git a/lib/linalg/fortran/dlas2.f b/lib/linalg/fortran/dlas2.f deleted file mode 100644 index ea929e86f7..0000000000 --- a/lib/linalg/fortran/dlas2.f +++ /dev/null @@ -1,180 +0,0 @@ -*> \brief \b DLAS2 computes singular values of a 2-by-2 triangular matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION F, G, H, SSMAX, SSMIN -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAS2 computes the singular values of the 2-by-2 matrix -*> [ F G ] -*> [ 0 H ]. -*> On return, SSMIN is the smaller singular value and SSMAX is the -*> larger singular value. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] F -*> \verbatim -*> F is DOUBLE PRECISION -*> The (1,1) element of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[in] G -*> \verbatim -*> G is DOUBLE PRECISION -*> The (1,2) element of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[in] H -*> \verbatim -*> H is DOUBLE PRECISION -*> The (2,2) element of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[out] SSMIN -*> \verbatim -*> SSMIN is DOUBLE PRECISION -*> The smaller singular value. -*> \endverbatim -*> -*> \param[out] SSMAX -*> \verbatim -*> SSMAX is DOUBLE PRECISION -*> The larger singular value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Barring over/underflow, all output quantities are correct to within -*> a few units in the last place (ulps), even in the absence of a guard -*> digit in addition/subtraction. -*> -*> In IEEE arithmetic, the code works correctly if one matrix element is -*> infinite. -*> -*> Overflow will not occur unless the largest singular value itself -*> overflows, or is within a few ulps of overflow. (On machines with -*> partial overflow, like the Cray, overflow may occur if the largest -*> singular value is within a factor of 2 of overflow.) -*> -*> Underflow is harmless if underflow is gradual. Otherwise, results -*> may correspond to a matrix modified by perturbations of size near -*> the underflow threshold. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION F, G, H, SSMAX, SSMIN -* .. -* -* ==================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION AS, AT, AU, C, FA, FHMN, FHMX, GA, HA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - FA = ABS( F ) - GA = ABS( G ) - HA = ABS( H ) - FHMN = MIN( FA, HA ) - FHMX = MAX( FA, HA ) - IF( FHMN.EQ.ZERO ) THEN - SSMIN = ZERO - IF( FHMX.EQ.ZERO ) THEN - SSMAX = GA - ELSE - SSMAX = MAX( FHMX, GA )*SQRT( ONE+ - $ ( MIN( FHMX, GA ) / MAX( FHMX, GA ) )**2 ) - END IF - ELSE - IF( GA.LT.FHMX ) THEN - AS = ONE + FHMN / FHMX - AT = ( FHMX-FHMN ) / FHMX - AU = ( GA / FHMX )**2 - C = TWO / ( SQRT( AS*AS+AU )+SQRT( AT*AT+AU ) ) - SSMIN = FHMN*C - SSMAX = FHMX / C - ELSE - AU = FHMX / GA - IF( AU.EQ.ZERO ) THEN -* -* Avoid possible harmful underflow if exponent range -* asymmetric (true SSMIN may not underflow even if -* AU underflows) -* - SSMIN = ( FHMN*FHMX ) / GA - SSMAX = GA - ELSE - AS = ONE + FHMN / FHMX - AT = ( FHMX-FHMN ) / FHMX - C = ONE / ( SQRT( ONE+( AS*AU )**2 )+ - $ SQRT( ONE+( AT*AU )**2 ) ) - SSMIN = ( FHMN*C )*AU - SSMIN = SSMIN + SSMIN - SSMAX = GA / ( C+C ) - END IF - END IF - END IF - RETURN -* -* End of DLAS2 -* - END diff --git a/lib/linalg/fortran/dlascl.f b/lib/linalg/fortran/dlascl.f deleted file mode 100644 index 0a4bf21ce1..0000000000 --- a/lib/linalg/fortran/dlascl.f +++ /dev/null @@ -1,367 +0,0 @@ -*> \brief \b DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASCL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* DOUBLE PRECISION CFROM, CTO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASCL multiplies the M by N real matrix A by the real scalar -*> CTO/CFROM. This is done without over/underflow as long as the final -*> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that -*> A may be full, upper triangular, lower triangular, upper Hessenberg, -*> or banded. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] TYPE -*> \verbatim -*> TYPE is CHARACTER*1 -*> TYPE indices the storage type of the input matrix. -*> = 'G': A is a full matrix. -*> = 'L': A is a lower triangular matrix. -*> = 'U': A is an upper triangular matrix. -*> = 'H': A is an upper Hessenberg matrix. -*> = 'B': A is a symmetric band matrix with lower bandwidth KL -*> and upper bandwidth KU and with the only the lower -*> half stored. -*> = 'Q': A is a symmetric band matrix with lower bandwidth KL -*> and upper bandwidth KU and with the only the upper -*> half stored. -*> = 'Z': A is a band matrix with lower bandwidth KL and upper -*> bandwidth KU. See DGBTRF for storage details. -*> \endverbatim -*> -*> \param[in] KL -*> \verbatim -*> KL is INTEGER -*> The lower bandwidth of A. Referenced only if TYPE = 'B', -*> 'Q' or 'Z'. -*> \endverbatim -*> -*> \param[in] KU -*> \verbatim -*> KU is INTEGER -*> The upper bandwidth of A. Referenced only if TYPE = 'B', -*> 'Q' or 'Z'. -*> \endverbatim -*> -*> \param[in] CFROM -*> \verbatim -*> CFROM is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] CTO -*> \verbatim -*> CTO is DOUBLE PRECISION -*> -*> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed -*> without over/underflow if the final result CTO*A(I,J)/CFROM -*> can be represented without over/underflow. CFROM must be -*> nonzero. -*> \endverbatim -*> -*> \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) -*> The matrix to be multiplied by CTO/CFROM. See TYPE for the -*> storage type. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> 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 -*> \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. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER TYPE - INTEGER INFO, KL, KU, LDA, M, N - DOUBLE PRECISION CFROM, CTO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL DONE - INTEGER I, ITYPE, J, K1, K2, K3, K4 - DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME, DISNAN - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, DLAMCH, DISNAN -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 -* - IF( LSAME( TYPE, 'G' ) ) THEN - ITYPE = 0 - ELSE IF( LSAME( TYPE, 'L' ) ) THEN - ITYPE = 1 - ELSE IF( LSAME( TYPE, 'U' ) ) THEN - ITYPE = 2 - ELSE IF( LSAME( TYPE, 'H' ) ) THEN - ITYPE = 3 - ELSE IF( LSAME( TYPE, 'B' ) ) THEN - ITYPE = 4 - ELSE IF( LSAME( TYPE, 'Q' ) ) THEN - ITYPE = 5 - ELSE IF( LSAME( TYPE, 'Z' ) ) THEN - ITYPE = 6 - ELSE - ITYPE = -1 - END IF -* - IF( ITYPE.EQ.-1 ) THEN - INFO = -1 - ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN - INFO = -4 - ELSE IF( DISNAN(CTO) ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. - $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN - INFO = -7 - ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( ITYPE.GE.4 ) THEN - IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN - INFO = -2 - ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. - $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) - $ THEN - INFO = -3 - ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. - $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. - $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN - INFO = -9 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLASCL', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -* -* Get machine parameters -* - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM -* - CFROMC = CFROM - CTOC = CTO -* - 10 CONTINUE - CFROM1 = CFROMC*SMLNUM - IF( CFROM1.EQ.CFROMC ) THEN -! CFROMC is an inf. Multiply by a correctly signed zero for -! finite CTOC, or a NaN if CTOC is infinite. - MUL = CTOC / CFROMC - DONE = .TRUE. - CTO1 = CTOC - ELSE - CTO1 = CTOC / BIGNUM - IF( CTO1.EQ.CTOC ) THEN -! CTOC is either 0 or an inf. In both cases, CTOC itself -! serves as the correct multiplication factor. - MUL = CTOC - DONE = .TRUE. - CFROMC = ONE - ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN - MUL = SMLNUM - DONE = .FALSE. - CFROMC = CFROM1 - ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN - MUL = BIGNUM - DONE = .FALSE. - CTOC = CTO1 - ELSE - MUL = CTOC / CFROMC - DONE = .TRUE. - IF (MUL .EQ. ONE) - $ RETURN - END IF - END IF -* - IF( ITYPE.EQ.0 ) THEN -* -* Full matrix -* - DO 30 J = 1, N - DO 20 I = 1, M - A( I, J ) = A( I, J )*MUL - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( ITYPE.EQ.1 ) THEN -* -* Lower triangular matrix -* - DO 50 J = 1, N - DO 40 I = J, M - A( I, J ) = A( I, J )*MUL - 40 CONTINUE - 50 CONTINUE -* - ELSE IF( ITYPE.EQ.2 ) THEN -* -* Upper triangular matrix -* - DO 70 J = 1, N - DO 60 I = 1, MIN( J, M ) - A( I, J ) = A( I, J )*MUL - 60 CONTINUE - 70 CONTINUE -* - ELSE IF( ITYPE.EQ.3 ) THEN -* -* Upper Hessenberg matrix -* - DO 90 J = 1, N - DO 80 I = 1, MIN( J+1, M ) - A( I, J ) = A( I, J )*MUL - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( ITYPE.EQ.4 ) THEN -* -* Lower half of a symmetric band matrix -* - K3 = KL + 1 - K4 = N + 1 - DO 110 J = 1, N - DO 100 I = 1, MIN( K3, K4-J ) - A( I, J ) = A( I, J )*MUL - 100 CONTINUE - 110 CONTINUE -* - ELSE IF( ITYPE.EQ.5 ) THEN -* -* Upper half of a symmetric band matrix -* - K1 = KU + 2 - K3 = KU + 1 - DO 130 J = 1, N - DO 120 I = MAX( K1-J, 1 ), K3 - A( I, J ) = A( I, J )*MUL - 120 CONTINUE - 130 CONTINUE -* - ELSE IF( ITYPE.EQ.6 ) THEN -* -* Band matrix -* - K1 = KL + KU + 2 - K2 = KL + 1 - K3 = 2*KL + KU + 1 - K4 = KL + KU + 1 + M - DO 150 J = 1, N - DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) - A( I, J ) = A( I, J )*MUL - 140 CONTINUE - 150 CONTINUE -* - END IF -* - IF( .NOT.DONE ) - $ GO TO 10 -* - RETURN -* -* End of DLASCL -* - END diff --git a/lib/linalg/fortran/dlasd4.f b/lib/linalg/fortran/dlasd4.f deleted file mode 100644 index acfd896b3b..0000000000 --- a/lib/linalg/fortran/dlasd4.f +++ /dev/null @@ -1,1058 +0,0 @@ -*> \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. -* -*> \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 -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. 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/fortran/dlasd5.f b/lib/linalg/fortran/dlasd5.f deleted file mode 100644 index 645c2fdc3e..0000000000 --- a/lib/linalg/fortran/dlasd5.f +++ /dev/null @@ -1,228 +0,0 @@ -*> \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. -* -*> \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 -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. 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/fortran/dlasd6.f b/lib/linalg/fortran/dlasd6.f deleted file mode 100644 index 51e67588dd..0000000000 --- a/lib/linalg/fortran/dlasd6.f +++ /dev/null @@ -1,440 +0,0 @@ -*> \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. -* -*> \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 -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. 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/fortran/dlasd7.f b/lib/linalg/fortran/dlasd7.f deleted file mode 100644 index ff9ba4c36a..0000000000 --- a/lib/linalg/fortran/dlasd7.f +++ /dev/null @@ -1,577 +0,0 @@ -*> \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. -* -*> \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 -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. 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 tolerance -* - 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/fortran/dlasd8.f b/lib/linalg/fortran/dlasd8.f deleted file mode 100644 index a769bdb22e..0000000000 --- a/lib/linalg/fortran/dlasd8.f +++ /dev/null @@ -1,339 +0,0 @@ -*> \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. -* -*> \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 -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. 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/fortran/dlasda.f b/lib/linalg/fortran/dlasda.f deleted file mode 100644 index 3e169a4edb..0000000000 --- a/lib/linalg/fortran/dlasda.f +++ /dev/null @@ -1,511 +0,0 @@ -*> \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. -* -*> \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 -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. 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/fortran/dlasdq.f b/lib/linalg/fortran/dlasdq.f deleted file mode 100644 index 0c39b24f0d..0000000000 --- a/lib/linalg/fortran/dlasdq.f +++ /dev/null @@ -1,410 +0,0 @@ -*> \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. -* -*> \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 -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. 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/fortran/dlasdt.f b/lib/linalg/fortran/dlasdt.f deleted file mode 100644 index 0d9999ea62..0000000000 --- a/lib/linalg/fortran/dlasdt.f +++ /dev/null @@ -1,169 +0,0 @@ -*> \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. -* -*> \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 -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. 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 diff --git a/lib/linalg/fortran/dlaset.f b/lib/linalg/fortran/dlaset.f deleted file mode 100644 index 625c757b6b..0000000000 --- a/lib/linalg/fortran/dlaset.f +++ /dev/null @@ -1,181 +0,0 @@ -*> \brief \b DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASET + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER LDA, M, N -* DOUBLE PRECISION ALPHA, BETA -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASET initializes an m-by-n matrix A to BETA on the diagonal and -*> ALPHA on the offdiagonals. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies the part of the matrix A to be set. -*> = 'U': Upper triangular part is set; the strictly lower -*> triangular part of A is not changed. -*> = 'L': Lower triangular part is set; the strictly upper -*> triangular part of A is not changed. -*> Otherwise: All of the matrix A is set. -*> \endverbatim -*> -*> \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] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION -*> The constant to which the offdiagonal elements are to be set. -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is DOUBLE PRECISION -*> The constant to which the diagonal elements are to be set. -*> \endverbatim -*> -*> \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: -*> -*> if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, -*> if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, -*> otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, -*> -*> and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, M, N - DOUBLE PRECISION ALPHA, BETA -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Set the strictly upper triangular or trapezoidal part of the -* array to ALPHA. -* - DO 20 J = 2, N - DO 10 I = 1, MIN( J-1, M ) - A( I, J ) = ALPHA - 10 CONTINUE - 20 CONTINUE -* - ELSE IF( LSAME( UPLO, 'L' ) ) THEN -* -* Set the strictly lower triangular or trapezoidal part of the -* array to ALPHA. -* - DO 40 J = 1, MIN( M, N ) - DO 30 I = J + 1, M - A( I, J ) = ALPHA - 30 CONTINUE - 40 CONTINUE -* - ELSE -* -* Set the leading m-by-n submatrix to ALPHA. -* - DO 60 J = 1, N - DO 50 I = 1, M - A( I, J ) = ALPHA - 50 CONTINUE - 60 CONTINUE - END IF -* -* Set the first min(M,N) diagonal elements to BETA. -* - DO 70 I = 1, MIN( M, N ) - A( I, I ) = BETA - 70 CONTINUE -* - RETURN -* -* End of DLASET -* - END diff --git a/lib/linalg/fortran/dlasq1.f b/lib/linalg/fortran/dlasq1.f deleted file mode 100644 index 27fa30736e..0000000000 --- a/lib/linalg/fortran/dlasq1.f +++ /dev/null @@ -1,221 +0,0 @@ -*> \brief \b DLASQ1 computes the singular values of a real square bidiagonal matrix. Used by sbdsqr. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASQ1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ), E( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASQ1 computes the singular values of a real N-by-N bidiagonal -*> matrix with diagonal D and off-diagonal E. The singular values -*> are computed to high relative accuracy, in the absence of -*> denormalization, underflow and overflow. The algorithm was first -*> presented in -*> -*> "Accurate singular values and differential qd algorithms" by K. V. -*> Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230, -*> 1994, -*> -*> and the present implementation is described in "An implementation of -*> the dqds Algorithm (Positive Case)", LAPACK Working Note. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of rows and columns in the matrix. N >= 0. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, D contains the diagonal elements of the -*> bidiagonal matrix whose SVD is desired. On normal exit, -*> D contains the singular values in decreasing order. -*> \endverbatim -*> -*> \param[in,out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N) -*> On entry, elements E(1:N-1) contain the off-diagonal elements -*> of the bidiagonal matrix whose SVD is desired. -*> On exit, E is overwritten. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (4*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 -*> = 1, a split was marked by a positive value in E -*> = 2, current block of Z not diagonalized after 100*N -*> iterations (in inner while loop) On exit D and E -*> 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 -*> (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. -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO - DOUBLE PRECISION EPS, SCALE, SAFMIN, SIGMN, SIGMX -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLAS2, DLASCL, DLASQ2, DLASRT, XERBLA -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. -* .. Executable Statements .. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - CALL XERBLA( 'DLASQ1', -INFO ) - RETURN - ELSE IF( N.EQ.0 ) THEN - RETURN - ELSE IF( N.EQ.1 ) THEN - D( 1 ) = ABS( D( 1 ) ) - RETURN - ELSE IF( N.EQ.2 ) THEN - CALL DLAS2( D( 1 ), E( 1 ), D( 2 ), SIGMN, SIGMX ) - D( 1 ) = SIGMX - D( 2 ) = SIGMN - RETURN - END IF -* -* Estimate the largest singular value. -* - SIGMX = ZERO - DO 10 I = 1, N - 1 - D( I ) = ABS( D( I ) ) - SIGMX = MAX( SIGMX, ABS( E( I ) ) ) - 10 CONTINUE - D( N ) = ABS( D( N ) ) -* -* Early return if SIGMX is zero (matrix is already diagonal). -* - IF( SIGMX.EQ.ZERO ) THEN - CALL DLASRT( 'D', N, D, IINFO ) - RETURN - END IF -* - DO 20 I = 1, N - SIGMX = MAX( SIGMX, D( I ) ) - 20 CONTINUE -* -* Copy D and E into WORK (in the Z format) and scale (squaring the -* input data makes scaling by a power of the radix pointless). -* - EPS = DLAMCH( 'Precision' ) - SAFMIN = DLAMCH( 'Safe minimum' ) - SCALE = SQRT( EPS / SAFMIN ) - CALL DCOPY( N, D, 1, WORK( 1 ), 2 ) - 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 - WORK( I ) = WORK( I )**2 - 30 CONTINUE - WORK( 2*N ) = ZERO -* - CALL DLASQ2( N, WORK, INFO ) -* - IF( INFO.EQ.0 ) THEN - DO 40 I = 1, N - D( I ) = SQRT( WORK( I ) ) - 40 CONTINUE - CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO ) - ELSE IF( INFO.EQ.2 ) THEN -* -* Maximum number of iterations exceeded. Move data from WORK -* into D and E so the calling subroutine can try to finish -* - DO I = 1, N - D( I ) = SQRT( WORK( 2*I-1 ) ) - E( I ) = SQRT( WORK( 2*I ) ) - END DO - CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO ) - CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, E, N, IINFO ) - END IF -* - RETURN -* -* End of DLASQ1 -* - END diff --git a/lib/linalg/fortran/dlasq2.f b/lib/linalg/fortran/dlasq2.f deleted file mode 100644 index 608ca7a619..0000000000 --- a/lib/linalg/fortran/dlasq2.f +++ /dev/null @@ -1,586 +0,0 @@ -*> \brief \b DLASQ2 computes all the eigenvalues of the symmetric positive definite tridiagonal matrix associated with the qd Array Z to high relative accuracy. Used by sbdsqr and sstegr. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASQ2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -*> 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. -*> -*> To see the relation of Z to the tridiagonal matrix, let L be a -*> unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and -*> let U be an upper bidiagonal matrix with 1's above and diagonal -*> Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the -*> symmetric tridiagonal to which it is similar. -*> -*> Note : DLASQ2 defines a logical variable, IEEE, which is true -*> on machines which follow ieee-754 floating-point standard in their -*> handling of infinities and NaNs, and false otherwise. This variable -*> is passed to DLASQ3. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of rows and columns in the matrix. N >= 0. -*> \endverbatim -*> -*> \param[in,out] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( 4*N ) -*> On entry Z holds the qd array. On exit, entries 1 to N hold -*> the eigenvalues in decreasing order, Z( 2*N+1 ) holds the -*> trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If -*> N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 ) -*> holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of -*> shifts that failed. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if the i-th argument is a scalar and had an illegal -*> value, then INFO = -i, if the i-th argument is an -*> array and the j-entry had an illegal value, then -*> INFO = -(i*100+j) -*> > 0: the algorithm failed -*> = 1, a split was marked by a positive value in E -*> = 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 -*> (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. -* -*> \ingroup auxOTHERcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Local Variables: I0:N0 defines a current unreduced segment of Z. -*> The shifts are accumulated in SIGMA. Iteration count is in ITER. -*> Ping-pong is controlled by PP (alternates between 0 and 1). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLASQ2( N, Z, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION Z( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION CBIAS - PARAMETER ( CBIAS = 1.50D0 ) - DOUBLE PRECISION ZERO, HALF, ONE, TWO, FOUR, HUNDRD - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, - $ TWO = 2.0D0, FOUR = 4.0D0, HUNDRD = 100.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL IEEE - INTEGER I0, I1, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, - $ 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, - $ QMIN, S, SAFMIN, SIGMA, T, TAU, TEMP, TOL, - $ TOL2, TRACE, ZMAX, TEMPE, TEMPQ -* .. -* .. External Subroutines .. - EXTERNAL DLASQ3, DLASRT, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, ILAENV -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input arguments. -* (in case DLASQ2 is not called by DLASQ1) -* - INFO = 0 - EPS = DLAMCH( 'Precision' ) - SAFMIN = DLAMCH( 'Safe minimum' ) - TOL = EPS*HUNDRD - TOL2 = TOL**2 -* - IF( N.LT.0 ) THEN - INFO = -1 - CALL XERBLA( 'DLASQ2', 1 ) - RETURN - ELSE IF( N.EQ.0 ) THEN - RETURN - ELSE IF( N.EQ.1 ) THEN -* -* 1-by-1 case. -* - IF( Z( 1 ).LT.ZERO ) THEN - INFO = -201 - CALL XERBLA( 'DLASQ2', 2 ) - END IF - RETURN - ELSE IF( N.EQ.2 ) THEN -* -* 2-by-2 case. -* - IF( Z( 1 ).LT.ZERO ) THEN - INFO = -201 - CALL XERBLA( 'DLASQ2', 2 ) - RETURN - ELSE IF( Z( 2 ).LT.ZERO ) THEN - INFO = -202 - CALL XERBLA( 'DLASQ2', 2 ) - RETURN - ELSE IF( Z( 3 ).LT.ZERO ) THEN - INFO = -203 - CALL XERBLA( 'DLASQ2', 2 ) - RETURN - ELSE IF( Z( 3 ).GT.Z( 1 ) ) THEN - D = Z( 3 ) - Z( 3 ) = Z( 1 ) - Z( 1 ) = D - 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 ) ) - S = Z( 3 )*( Z( 2 ) / T ) - IF( S.LE.T ) THEN - S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) ) - ELSE - S = Z( 3 )*( Z( 2 ) / ( T+SQRT( T )*SQRT( T+S ) ) ) - END IF - T = Z( 1 ) + ( S+Z( 2 ) ) - Z( 3 ) = Z( 3 )*( Z( 1 ) / T ) - Z( 1 ) = T - END IF - Z( 2 ) = Z( 3 ) - Z( 6 ) = Z( 2 ) + Z( 1 ) - RETURN - END IF -* -* Check for negative data and compute sums of q's and e's. -* - Z( 2*N ) = ZERO - EMIN = Z( 2 ) - QMAX = ZERO - ZMAX = ZERO - D = ZERO - E = ZERO -* - DO 10 K = 1, 2*( N-1 ), 2 - IF( Z( K ).LT.ZERO ) THEN - INFO = -( 200+K ) - CALL XERBLA( 'DLASQ2', 2 ) - RETURN - ELSE IF( Z( K+1 ).LT.ZERO ) THEN - INFO = -( 200+K+1 ) - CALL XERBLA( 'DLASQ2', 2 ) - RETURN - END IF - D = D + Z( K ) - E = E + Z( K+1 ) - QMAX = MAX( QMAX, Z( K ) ) - EMIN = MIN( EMIN, Z( K+1 ) ) - ZMAX = MAX( QMAX, ZMAX, Z( K+1 ) ) - 10 CONTINUE - IF( Z( 2*N-1 ).LT.ZERO ) THEN - INFO = -( 200+2*N-1 ) - CALL XERBLA( 'DLASQ2', 2 ) - RETURN - END IF - D = D + Z( 2*N-1 ) - QMAX = MAX( QMAX, Z( 2*N-1 ) ) - ZMAX = MAX( QMAX, ZMAX ) -* -* Check for diagonality. -* - IF( E.EQ.ZERO ) THEN - DO 20 K = 2, N - Z( K ) = Z( 2*K-1 ) - 20 CONTINUE - CALL DLASRT( 'D', N, Z, IINFO ) - Z( 2*N-1 ) = D - RETURN - END IF -* - TRACE = D + E -* -* Check for zero data. -* - IF( TRACE.EQ.ZERO ) THEN - 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 ) -* -* 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 ) - 30 CONTINUE -* - I0 = 1 - N0 = N -* -* Reverse the qd-array, if warranted. -* - IF( CBIAS*Z( 4*I0-3 ).LT.Z( 4*N0-3 ) ) THEN - IPN4 = 4*( I0+N0 ) - DO 40 I4 = 4*I0, 2*( I0+N0-1 ), 4 - TEMP = Z( I4-3 ) - Z( I4-3 ) = Z( IPN4-I4-3 ) - Z( IPN4-I4-3 ) = TEMP - TEMP = Z( I4-1 ) - Z( I4-1 ) = Z( IPN4-I4-5 ) - Z( IPN4-I4-5 ) = TEMP - 40 CONTINUE - END IF -* -* Initial split checking via dqd and Li's test. -* - PP = 0 -* - DO 80 K = 1, 2 -* - D = Z( 4*N0+PP-3 ) - DO 50 I4 = 4*( N0-1 ) + PP, 4*I0 + PP, -4 - IF( Z( I4-1 ).LE.TOL2*D ) THEN - Z( I4-1 ) = -ZERO - D = Z( I4-3 ) - ELSE - D = Z( I4-3 )*( D / ( D+Z( I4-1 ) ) ) - END IF - 50 CONTINUE -* -* dqd maps Z to ZZ plus Li's test. -* - EMIN = Z( 4*I0+PP+1 ) - D = Z( 4*I0+PP-3 ) - DO 60 I4 = 4*I0 + PP, 4*( N0-1 ) + PP, 4 - Z( I4-2*PP-2 ) = D + Z( I4-1 ) - IF( Z( I4-1 ).LE.TOL2*D ) THEN - Z( I4-1 ) = -ZERO - Z( I4-2*PP-2 ) = D - Z( I4-2*PP ) = ZERO - D = Z( I4+1 ) - ELSE IF( SAFMIN*Z( I4+1 ).LT.Z( I4-2*PP-2 ) .AND. - $ SAFMIN*Z( I4-2*PP-2 ).LT.Z( I4+1 ) ) THEN - TEMP = Z( I4+1 ) / Z( I4-2*PP-2 ) - Z( I4-2*PP ) = Z( I4-1 )*TEMP - D = D*TEMP - ELSE - Z( I4-2*PP ) = Z( I4+1 )*( Z( I4-1 ) / Z( I4-2*PP-2 ) ) - D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) ) - END IF - EMIN = MIN( EMIN, Z( I4-2*PP ) ) - 60 CONTINUE - Z( 4*N0-PP-2 ) = D -* -* Now find qmax. -* - QMAX = Z( 4*I0-PP-2 ) - DO 70 I4 = 4*I0 - PP + 2, 4*N0 - PP - 2, 4 - QMAX = MAX( QMAX, Z( I4 ) ) - 70 CONTINUE -* -* Prepare for the next iteration on K. -* - PP = 1 - PP - 80 CONTINUE -* -* Initialise variables to pass to DLASQ3. -* - TTYPE = 0 - DMIN1 = ZERO - DMIN2 = ZERO - DN = ZERO - DN1 = ZERO - DN2 = ZERO - G = ZERO - TAU = ZERO -* - ITER = 2 - NFAIL = 0 - NDIV = 2*( N0-I0 ) -* - DO 160 IWHILA = 1, N + 1 - IF( N0.LT.1 ) - $ GO TO 170 -* -* 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 - ELSE - SIGMA = -Z( 4*N0-1 ) - END IF - IF( SIGMA.LT.ZERO ) THEN - INFO = 1 - RETURN - END IF -* -* 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 - IF( N0.GT.I0 ) THEN - EMIN = ABS( Z( 4*N0-5 ) ) - ELSE - EMIN = ZERO - END IF - QMIN = Z( 4*N0-3 ) - QMAX = QMIN - DO 90 I4 = 4*N0, 8, -4 - IF( Z( I4-5 ).LE.ZERO ) - $ GO TO 100 - IF( QMIN.GE.FOUR*EMAX ) THEN - QMIN = MIN( QMIN, Z( I4-3 ) ) - EMAX = MAX( EMAX, Z( I4-5 ) ) - END IF - QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) ) - EMIN = MIN( EMIN, Z( I4-5 ) ) - 90 CONTINUE - I4 = 4 -* - 100 CONTINUE - I0 = I4 / 4 - PP = 0 -* - IF( N0-I0.GT.1 ) THEN - DEE = Z( 4*I0-3 ) - DEEMIN = DEE - KMIN = I0 - DO 110 I4 = 4*I0+1, 4*N0-3, 4 - DEE = Z( I4 )*( DEE /( DEE+Z( I4-2 ) ) ) - IF( DEE.LE.DEEMIN ) THEN - DEEMIN = DEE - KMIN = ( I4+3 )/4 - END IF - 110 CONTINUE - IF( (KMIN-I0)*2.LT.N0-KMIN .AND. - $ DEEMIN.LE.HALF*Z(4*N0-3) ) THEN - IPN4 = 4*( I0+N0 ) - PP = 2 - DO 120 I4 = 4*I0, 2*( I0+N0-1 ), 4 - TEMP = Z( I4-3 ) - Z( I4-3 ) = Z( IPN4-I4-3 ) - Z( IPN4-I4-3 ) = TEMP - TEMP = Z( I4-2 ) - Z( I4-2 ) = Z( IPN4-I4-2 ) - Z( IPN4-I4-2 ) = TEMP - TEMP = Z( I4-1 ) - Z( I4-1 ) = Z( IPN4-I4-5 ) - Z( IPN4-I4-5 ) = TEMP - TEMP = Z( I4 ) - Z( I4 ) = Z( IPN4-I4-4 ) - Z( IPN4-I4-4 ) = TEMP - 120 CONTINUE - END IF - END IF -* -* Put -(initial shift) into DMIN. -* - DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) ) -* -* 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 -* should not be performed. -* - NBIG = 100*( N0-I0+1 ) - DO 140 IWHILB = 1, NBIG - IF( I0.GT.N0 ) - $ GO TO 150 -* -* While submatrix unfinished take a good dqds step. -* - CALL DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, - $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, - $ DN2, G, TAU ) -* - PP = 1 - PP -* -* When EMIN is very small check for splits. -* - IF( PP.EQ.0 .AND. N0-I0.GE.3 ) THEN - IF( Z( 4*N0 ).LE.TOL2*QMAX .OR. - $ Z( 4*N0-1 ).LE.TOL2*SIGMA ) THEN - SPLT = I0 - 1 - QMAX = Z( 4*I0-3 ) - EMIN = Z( 4*I0-1 ) - OLDEMN = Z( 4*I0 ) - DO 130 I4 = 4*I0, 4*( N0-3 ), 4 - IF( Z( I4 ).LE.TOL2*Z( I4-3 ) .OR. - $ Z( I4-1 ).LE.TOL2*SIGMA ) THEN - Z( I4-1 ) = -SIGMA - SPLT = I4 / 4 - QMAX = ZERO - EMIN = Z( I4+3 ) - OLDEMN = Z( I4+4 ) - ELSE - QMAX = MAX( QMAX, Z( I4+1 ) ) - EMIN = MIN( EMIN, Z( I4-1 ) ) - OLDEMN = MIN( OLDEMN, Z( I4 ) ) - END IF - 130 CONTINUE - Z( 4*N0-1 ) = EMIN - Z( 4*N0 ) = OLDEMN - I0 = SPLT + 1 - END IF - END IF -* - 140 CONTINUE -* - INFO = 2 -* -* 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 -* - I1 = I0 - N1 = N0 - 145 CONTINUE - TEMPQ = Z( 4*I0-3 ) - Z( 4*I0-3 ) = Z( 4*I0-3 ) + SIGMA - DO K = I0+1, N0 - TEMPE = Z( 4*K-5 ) - Z( 4*K-5 ) = Z( 4*K-5 ) * (TEMPQ / Z( 4*K-7 )) - TEMPQ = Z( 4*K-3 ) - Z( 4*K-3 ) = Z( 4*K-3 ) + SIGMA + TEMPE - Z( 4*K-5 ) - END DO -* -* Prepare to do this on the previous block if there is one -* - IF( I1.GT.1 ) THEN - N1 = I1-1 - DO WHILE( ( I1.GE.2 ) .AND. ( Z(4*I1-5).GE.ZERO ) ) - I1 = I1 - 1 - END DO - SIGMA = -Z(4*N1-1) - GO TO 145 - END IF - - DO K = 1, N - Z( 2*K-1 ) = Z( 4*K-3 ) -* -* Only the block 1..N0 is unfinished. The rest of the e's -* must be essentially zero, although sometimes other data -* has been stored in them. -* - IF( K.LT.N0 ) THEN - Z( 2*K ) = Z( 4*K-1 ) - ELSE - Z( 2*K ) = 0 - END IF - END DO - RETURN -* -* end IWHILB -* - 150 CONTINUE -* - 160 CONTINUE -* - INFO = 3 - RETURN -* -* 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 ) -* - E = ZERO - DO 190 K = N, 1, -1 - E = E + Z( K ) - 190 CONTINUE -* -* Store trace, sum(eigenvalues) and information on performance. -* - 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 ) - Z( 2*N+5 ) = HUNDRD*NFAIL / DBLE( ITER ) - RETURN -* -* End of DLASQ2 -* - END diff --git a/lib/linalg/fortran/dlasq3.f b/lib/linalg/fortran/dlasq3.f deleted file mode 100644 index e4bdafe06e..0000000000 --- a/lib/linalg/fortran/dlasq3.f +++ /dev/null @@ -1,418 +0,0 @@ -*> \brief \b DLASQ3 checks for deflation, computes a shift and calls dqds. Used by sbdsqr. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASQ3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* 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 -* DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, -* $ QMAX, SIGMA, TAU -* .. -* .. Array Arguments .. -* DOUBLE PRECISION Z( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds. -*> In case of failure it changes shifts, and tries again until output -*> is positive. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] I0 -*> \verbatim -*> I0 is INTEGER -*> First index. -*> \endverbatim -*> -*> \param[in,out] N0 -*> \verbatim -*> N0 is INTEGER -*> Last index. -*> \endverbatim -*> -*> \param[in,out] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( 4*N0 ) -*> Z holds the qd array. -*> \endverbatim -*> -*> \param[in,out] PP -*> \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 -*> performed. -*> \endverbatim -*> -*> \param[out] DMIN -*> \verbatim -*> DMIN is DOUBLE PRECISION -*> Minimum value of d. -*> \endverbatim -*> -*> \param[out] SIGMA -*> \verbatim -*> SIGMA is DOUBLE PRECISION -*> Sum of shifts used in current segment. -*> \endverbatim -*> -*> \param[in,out] DESIG -*> \verbatim -*> DESIG is DOUBLE PRECISION -*> Lower order part of SIGMA -*> \endverbatim -*> -*> \param[in] QMAX -*> \verbatim -*> QMAX is DOUBLE PRECISION -*> Maximum value of q. -*> \endverbatim -*> -*> \param[in,out] NFAIL -*> \verbatim -*> NFAIL is INTEGER -*> Increment NFAIL by 1 each time the shift was too big. -*> \endverbatim -*> -*> \param[in,out] ITER -*> \verbatim -*> ITER is INTEGER -*> Increment ITER by 1 for each iteration. -*> \endverbatim -*> -*> \param[in,out] NDIV -*> \verbatim -*> NDIV is INTEGER -*> Increment NDIV by 1 for each division. -*> \endverbatim -*> -*> \param[in] IEEE -*> \verbatim -*> IEEE is LOGICAL -*> Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). -*> \endverbatim -*> -*> \param[in,out] TTYPE -*> \verbatim -*> TTYPE is INTEGER -*> Shift type. -*> \endverbatim -*> -*> \param[in,out] DMIN1 -*> \verbatim -*> DMIN1 is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in,out] DMIN2 -*> \verbatim -*> DMIN2 is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in,out] DN -*> \verbatim -*> DN is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in,out] DN1 -*> \verbatim -*> DN1 is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in,out] DN2 -*> \verbatim -*> DN2 is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in,out] G -*> \verbatim -*> G is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in,out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION -*> -*> These are passed as arguments in order to save their values -*> between calls to DLASQ3. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, - $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, - $ DN2, G, TAU ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - LOGICAL IEEE - INTEGER I0, ITER, N0, NDIV, NFAIL, PP - DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, - $ QMAX, SIGMA, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION Z( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION CBIAS - PARAMETER ( CBIAS = 1.50D0 ) - DOUBLE PRECISION ZERO, QURTR, HALF, ONE, TWO, HUNDRD - PARAMETER ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0, - $ ONE = 1.0D0, TWO = 2.0D0, HUNDRD = 100.0D0 ) -* .. -* .. Local Scalars .. - INTEGER IPN4, J4, N0IN, NN, TTYPE - DOUBLE PRECISION EPS, S, T, TEMP, TOL, TOL2 -* .. -* .. External Subroutines .. - EXTERNAL DLASQ4, DLASQ5, DLASQ6 -* .. -* .. External Function .. - DOUBLE PRECISION DLAMCH - LOGICAL DISNAN - EXTERNAL DISNAN, DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - N0IN = N0 - EPS = DLAMCH( 'Precision' ) - TOL = EPS*HUNDRD - TOL2 = TOL**2 -* -* Check for deflation. -* - 10 CONTINUE -* - IF( N0.LT.I0 ) - $ RETURN - IF( N0.EQ.I0 ) - $ GO TO 20 - NN = 4*N0 + PP - IF( N0.EQ.( I0+1 ) ) - $ GO TO 40 -* -* Check whether E(N0-1) is negligible, 1 eigenvalue. -* - IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND. - $ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) ) - $ GO TO 30 -* - 20 CONTINUE -* - Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA - N0 = N0 - 1 - GO TO 10 -* -* Check whether E(N0-2) is negligible, 2 eigenvalues. -* - 30 CONTINUE -* - IF( Z( NN-9 ).GT.TOL2*SIGMA .AND. - $ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) ) - $ GO TO 50 -* - 40 CONTINUE -* - IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN - S = Z( NN-3 ) - Z( NN-3 ) = Z( NN-7 ) - Z( NN-7 ) = S - END IF - T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) ) - IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2.AND.T.NE.ZERO ) THEN - S = Z( NN-3 )*( Z( NN-5 ) / T ) - IF( S.LE.T ) THEN - S = Z( NN-3 )*( Z( NN-5 ) / - $ ( T*( ONE+SQRT( ONE+S / T ) ) ) ) - ELSE - S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) ) - END IF - T = Z( NN-7 ) + ( S+Z( NN-5 ) ) - Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T ) - Z( NN-7 ) = T - END IF - Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA - Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA - N0 = N0 - 2 - GO TO 10 -* - 50 CONTINUE - IF( PP.EQ.2 ) - $ PP = 0 -* -* Reverse the qd-array, if warranted. -* - IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN - IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN - IPN4 = 4*( I0+N0 ) - DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4 - TEMP = Z( J4-3 ) - Z( J4-3 ) = Z( IPN4-J4-3 ) - Z( IPN4-J4-3 ) = TEMP - TEMP = Z( J4-2 ) - Z( J4-2 ) = Z( IPN4-J4-2 ) - Z( IPN4-J4-2 ) = TEMP - TEMP = Z( J4-1 ) - Z( J4-1 ) = Z( IPN4-J4-5 ) - Z( IPN4-J4-5 ) = TEMP - TEMP = Z( J4 ) - Z( J4 ) = Z( IPN4-J4-4 ) - Z( IPN4-J4-4 ) = TEMP - 60 CONTINUE - IF( N0-I0.LE.4 ) THEN - Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 ) - Z( 4*N0-PP ) = Z( 4*I0-PP ) - END IF - DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) ) - Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ), - $ Z( 4*I0+PP+3 ) ) - Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ), - $ Z( 4*I0-PP+4 ) ) - QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) ) - DMIN = -ZERO - END IF - END IF -* -* Choose a shift. -* - CALL DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, - $ DN2, TAU, TTYPE, G ) -* -* Call dqds until DMIN > 0. -* - 70 CONTINUE -* - CALL DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DN, - $ DN1, DN2, IEEE, EPS ) -* - NDIV = NDIV + ( N0-I0+2 ) - ITER = ITER + 1 -* -* Check status. -* - IF( DMIN.GE.ZERO .AND. DMIN1.GE.ZERO ) THEN -* -* Success. -* - GO TO 90 -* - 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 -* -* Convergence hidden by negative DN. -* - Z( 4*( N0-1 )-PP+2 ) = ZERO - DMIN = ZERO - GO TO 90 - ELSE IF( DMIN.LT.ZERO ) THEN -* -* TAU too big. Select new TAU and try again. -* - NFAIL = NFAIL + 1 - IF( TTYPE.LT.-22 ) THEN -* -* Failed twice. Play it safe. -* - TAU = ZERO - ELSE IF( DMIN1.GT.ZERO ) THEN -* -* Late failure. Gives excellent shift. -* - TAU = ( TAU+DMIN )*( ONE-TWO*EPS ) - TTYPE = TTYPE - 11 - ELSE -* -* Early failure. Divide by 4. -* - TAU = QURTR*TAU - TTYPE = TTYPE - 12 - END IF - GO TO 70 - ELSE IF( DISNAN( DMIN ) ) THEN -* -* NaN. -* - IF( TAU.EQ.ZERO ) THEN - GO TO 80 - ELSE - TAU = ZERO - GO TO 70 - END IF - ELSE -* -* Possible underflow. Play it safe. -* - GO TO 80 - END IF -* -* Risk of underflow. -* - 80 CONTINUE - CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 ) - NDIV = NDIV + ( N0-I0+2 ) - ITER = ITER + 1 - TAU = ZERO -* - 90 CONTINUE - IF( TAU.LT.SIGMA ) THEN - DESIG = DESIG + TAU - T = SIGMA + DESIG - DESIG = DESIG - ( T-SIGMA ) - ELSE - T = SIGMA + TAU - DESIG = SIGMA - ( T-TAU ) + DESIG - END IF - SIGMA = T -* - RETURN -* -* End of DLASQ3 -* - END diff --git a/lib/linalg/fortran/dlasq4.f b/lib/linalg/fortran/dlasq4.f deleted file mode 100644 index 2652ddb2ba..0000000000 --- a/lib/linalg/fortran/dlasq4.f +++ /dev/null @@ -1,421 +0,0 @@ -*> \brief \b DLASQ4 computes an approximation to the smallest eigenvalue using values of d from the previous transform. Used by sbdsqr. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASQ4 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* DOUBLE PRECISION Z( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASQ4 computes an approximation TAU to the smallest eigenvalue -*> using values of d from the previous transform. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] I0 -*> \verbatim -*> I0 is INTEGER -*> First index. -*> \endverbatim -*> -*> \param[in] N0 -*> \verbatim -*> N0 is INTEGER -*> Last index. -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( 4*N0 ) -*> Z holds the qd array. -*> \endverbatim -*> -*> \param[in] PP -*> \verbatim -*> PP is INTEGER -*> PP=0 for ping, PP=1 for pong. -*> \endverbatim -*> -*> \param[in] N0IN -*> \verbatim -*> N0IN is INTEGER -*> The value of N0 at start of EIGTEST. -*> \endverbatim -*> -*> \param[in] DMIN -*> \verbatim -*> DMIN is DOUBLE PRECISION -*> Minimum value of d. -*> \endverbatim -*> -*> \param[in] DMIN1 -*> \verbatim -*> DMIN1 is DOUBLE PRECISION -*> Minimum value of d, excluding D( N0 ). -*> \endverbatim -*> -*> \param[in] DMIN2 -*> \verbatim -*> DMIN2 is DOUBLE PRECISION -*> Minimum value of d, excluding D( N0 ) and D( N0-1 ). -*> \endverbatim -*> -*> \param[in] DN -*> \verbatim -*> DN is DOUBLE PRECISION -*> d(N) -*> \endverbatim -*> -*> \param[in] DN1 -*> \verbatim -*> DN1 is DOUBLE PRECISION -*> d(N-1) -*> \endverbatim -*> -*> \param[in] DN2 -*> \verbatim -*> DN2 is DOUBLE PRECISION -*> d(N-2) -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION -*> This is the shift. -*> \endverbatim -*> -*> \param[out] TTYPE -*> \verbatim -*> TTYPE is INTEGER -*> Shift type. -*> \endverbatim -*> -*> \param[in,out] G -*> \verbatim -*> G is DOUBLE PRECISION -*> G is passed as an argument in order to save its value between -*> calls to DLASQ4. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> CNST1 = 9/16 -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, - $ DN1, DN2, TAU, TTYPE, G ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER I0, N0, N0IN, PP, TTYPE - DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION Z( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION CNST1, CNST2, CNST3 - PARAMETER ( CNST1 = 0.5630D0, CNST2 = 1.010D0, - $ CNST3 = 1.050D0 ) - DOUBLE PRECISION QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD - PARAMETER ( QURTR = 0.250D0, THIRD = 0.3330D0, - $ HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0, - $ TWO = 2.0D0, HUNDRD = 100.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I4, NN, NP - DOUBLE PRECISION A2, B1, B2, GAM, GAP1, GAP2, S -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* A negative DMIN forces the shift to take that absolute value -* TTYPE records the type of shift. -* - IF( DMIN.LE.ZERO ) THEN - TAU = -DMIN - TTYPE = -1 - RETURN - END IF -* - NN = 4*N0 + PP - IF( N0IN.EQ.N0 ) THEN -* -* No eigenvalues deflated. -* - IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN -* - B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) ) - B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) ) - A2 = Z( NN-7 ) + Z( NN-5 ) -* -* Cases 2 and 3. -* - IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN - GAP2 = DMIN2 - A2 - DMIN2*QURTR - IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN - GAP1 = A2 - DN - ( B2 / GAP2 )*B2 - ELSE - GAP1 = A2 - DN - ( B1+B2 ) - END IF - IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN - S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN ) - TTYPE = -2 - ELSE - S = ZERO - IF( DN.GT.B1 ) - $ S = DN - B1 - IF( A2.GT.( B1+B2 ) ) - $ S = MIN( S, A2-( B1+B2 ) ) - S = MAX( S, THIRD*DMIN ) - TTYPE = -3 - END IF - ELSE -* -* Case 4. -* - TTYPE = -4 - S = QURTR*DMIN - IF( DMIN.EQ.DN ) THEN - GAM = DN - A2 = ZERO - IF( Z( NN-5 ) .GT. Z( NN-7 ) ) - $ RETURN - B2 = Z( NN-5 ) / Z( NN-7 ) - NP = NN - 9 - ELSE - NP = NN - 2*PP - GAM = DN1 - IF( Z( NP-4 ) .GT. Z( NP-2 ) ) - $ RETURN - A2 = Z( NP-4 ) / Z( NP-2 ) - IF( Z( NN-9 ) .GT. Z( NN-11 ) ) - $ RETURN - B2 = Z( NN-9 ) / Z( NN-11 ) - NP = NN - 13 - END IF -* -* Approximate contribution to norm squared from I < NN-1. -* - A2 = A2 + B2 - DO 10 I4 = NP, 4*I0 - 1 + PP, -4 - IF( B2.EQ.ZERO ) - $ GO TO 20 - B1 = B2 - IF( Z( I4 ) .GT. Z( I4-2 ) ) - $ RETURN - B2 = B2*( Z( I4 ) / Z( I4-2 ) ) - A2 = A2 + B2 - IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) - $ GO TO 20 - 10 CONTINUE - 20 CONTINUE - A2 = CNST3*A2 -* -* Rayleigh quotient residual bound. -* - IF( A2.LT.CNST1 ) - $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) - END IF - ELSE IF( DMIN.EQ.DN2 ) THEN -* -* Case 5. -* - TTYPE = -5 - S = QURTR*DMIN -* -* Compute contribution to norm squared from I > NN-2. -* - NP = NN - 2*PP - B1 = Z( NP-2 ) - B2 = Z( NP-6 ) - GAM = DN2 - IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 ) - $ RETURN - A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 ) -* -* Approximate contribution to norm squared from I < NN-2. -* - IF( N0-I0.GT.2 ) THEN - B2 = Z( NN-13 ) / Z( NN-15 ) - A2 = A2 + B2 - DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4 - IF( B2.EQ.ZERO ) - $ GO TO 40 - B1 = B2 - IF( Z( I4 ) .GT. Z( I4-2 ) ) - $ RETURN - B2 = B2*( Z( I4 ) / Z( I4-2 ) ) - A2 = A2 + B2 - IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) - $ GO TO 40 - 30 CONTINUE - 40 CONTINUE - A2 = CNST3*A2 - END IF -* - IF( A2.LT.CNST1 ) - $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) - ELSE -* -* Case 6, no information to guide us. -* - IF( TTYPE.EQ.-6 ) THEN - G = G + THIRD*( ONE-G ) - ELSE IF( TTYPE.EQ.-18 ) THEN - G = QURTR*THIRD - ELSE - G = QURTR - END IF - S = G*DMIN - TTYPE = -6 - END IF -* - ELSE IF( N0IN.EQ.( N0+1 ) ) THEN -* -* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. -* - IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN -* -* Cases 7 and 8. -* - TTYPE = -7 - S = THIRD*DMIN1 - IF( Z( NN-5 ).GT.Z( NN-7 ) ) - $ RETURN - B1 = Z( NN-5 ) / Z( NN-7 ) - B2 = B1 - IF( B2.EQ.ZERO ) - $ GO TO 60 - DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 - A2 = B1 - IF( Z( I4 ).GT.Z( I4-2 ) ) - $ RETURN - B1 = B1*( Z( I4 ) / Z( I4-2 ) ) - B2 = B2 + B1 - IF( HUNDRD*MAX( B1, A2 ).LT.B2 ) - $ GO TO 60 - 50 CONTINUE - 60 CONTINUE - B2 = SQRT( CNST3*B2 ) - A2 = DMIN1 / ( ONE+B2**2 ) - 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 - S = MAX( S, A2*( ONE-CNST2*B2 ) ) - TTYPE = -8 - END IF - ELSE -* -* Case 9. -* - S = QURTR*DMIN1 - IF( DMIN1.EQ.DN1 ) - $ S = HALF*DMIN1 - TTYPE = -9 - END IF -* - ELSE IF( N0IN.EQ.( N0+2 ) ) THEN -* -* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. -* -* Cases 10 and 11. -* - 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 ) ) - $ RETURN - B1 = Z( NN-5 ) / Z( NN-7 ) - B2 = B1 - IF( B2.EQ.ZERO ) - $ GO TO 80 - DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 - IF( Z( I4 ).GT.Z( I4-2 ) ) - $ RETURN - B1 = B1*( Z( I4 ) / Z( I4-2 ) ) - B2 = B2 + B1 - IF( HUNDRD*B1.LT.B2 ) - $ GO TO 80 - 70 CONTINUE - 80 CONTINUE - B2 = SQRT( CNST3*B2 ) - A2 = DMIN2 / ( ONE+B2**2 ) - GAP2 = Z( NN-7 ) + Z( NN-9 ) - - $ 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 - S = MAX( S, A2*( ONE-CNST2*B2 ) ) - END IF - ELSE - S = QURTR*DMIN2 - TTYPE = -11 - END IF - ELSE IF( N0IN.GT.( N0+2 ) ) THEN -* -* Case 12, more than two eigenvalues deflated. No information. -* - S = ZERO - TTYPE = -12 - END IF -* - TAU = S - RETURN -* -* End of DLASQ4 -* - END diff --git a/lib/linalg/fortran/dlasq5.f b/lib/linalg/fortran/dlasq5.f deleted file mode 100644 index 5679ab60a5..0000000000 --- a/lib/linalg/fortran/dlasq5.f +++ /dev/null @@ -1,407 +0,0 @@ -*> \brief \b DLASQ5 computes one dqds transform in ping-pong form. Used by sbdsqr and sstegr. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASQ5 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU, SIGMA, EPS -* .. -* .. Array Arguments .. -* DOUBLE PRECISION Z( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASQ5 computes one dqds transform in ping-pong form, one -*> version for IEEE machines another for non IEEE machines. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] I0 -*> \verbatim -*> I0 is INTEGER -*> First index. -*> \endverbatim -*> -*> \param[in] N0 -*> \verbatim -*> N0 is INTEGER -*> Last index. -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( 4*N ) -*> Z holds the qd array. EMIN is stored in Z(4*N0) to avoid -*> an extra argument. -*> \endverbatim -*> -*> \param[in] PP -*> \verbatim -*> PP is INTEGER -*> PP=0 for ping, PP=1 for pong. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION -*> This is the shift. -*> \endverbatim -*> -*> \param[in] SIGMA -*> \verbatim -*> SIGMA is DOUBLE PRECISION -*> This is the accumulated shift up to this step. -*> \endverbatim -*> -*> \param[out] DMIN -*> \verbatim -*> DMIN is DOUBLE PRECISION -*> Minimum value of d. -*> \endverbatim -*> -*> \param[out] DMIN1 -*> \verbatim -*> DMIN1 is DOUBLE PRECISION -*> Minimum value of d, excluding D( N0 ). -*> \endverbatim -*> -*> \param[out] DMIN2 -*> \verbatim -*> DMIN2 is DOUBLE PRECISION -*> Minimum value of d, excluding D( N0 ) and D( N0-1 ). -*> \endverbatim -*> -*> \param[out] DN -*> \verbatim -*> DN is DOUBLE PRECISION -*> d(N0), the last value of d. -*> \endverbatim -*> -*> \param[out] DNM1 -*> \verbatim -*> DNM1 is DOUBLE PRECISION -*> d(N0-1). -*> \endverbatim -*> -*> \param[out] DNM2 -*> \verbatim -*> DNM2 is DOUBLE PRECISION -*> d(N0-2). -*> \endverbatim -*> -*> \param[in] IEEE -*> \verbatim -*> IEEE is LOGICAL -*> Flag for IEEE or non IEEE arithmetic. -*> \endverbatim -*> -*> \param[in] EPS -*> \verbatim -*> EPS is DOUBLE PRECISION -*> This is the value of epsilon used. -*> \endverbatim -*> -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, - $ DN, DNM1, DNM2, IEEE, EPS ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - LOGICAL IEEE - INTEGER I0, N0, PP - DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU, - $ SIGMA, EPS -* .. -* .. Array Arguments .. - DOUBLE PRECISION Z( * ) -* .. -* -* ===================================================================== -* -* .. Parameter .. - DOUBLE PRECISION ZERO, HALF - PARAMETER ( ZERO = 0.0D0, HALF = 0.5 ) -* .. -* .. Local Scalars .. - INTEGER J4, J4P2 - DOUBLE PRECISION D, EMIN, TEMP, DTHRESH -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( ( N0-I0-1 ).LE.0 ) - $ RETURN -* - DTHRESH = EPS*(SIGMA+TAU) - IF( TAU.LT.DTHRESH*HALF ) TAU = ZERO - IF( TAU.NE.ZERO ) THEN - J4 = 4*I0 + PP - 3 - 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 10 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) - TEMP = Z( J4+1 ) / Z( J4-2 ) - D = D*TEMP - TAU - DMIN = MIN( DMIN, D ) - Z( J4 ) = Z( J4-1 )*TEMP - EMIN = MIN( Z( J4 ), EMIN ) - 10 CONTINUE - ELSE - DO 20 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) - TEMP = Z( J4+2 ) / Z( J4-3 ) - D = D*TEMP - TAU - DMIN = MIN( DMIN, D ) - Z( J4-1 ) = Z( J4 )*TEMP - EMIN = MIN( Z( J4-1 ), EMIN ) - 20 CONTINUE - END IF -* -* Unroll last two steps. -* - DNM2 = D - DMIN2 = DMIN - J4 = 4*( N0-2 ) - PP - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM2 + Z( J4P2 ) - 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 - Z( J4-2 ) = DNM1 + Z( J4P2 ) - 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 30 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) - IF( D.LT.ZERO ) THEN - RETURN - ELSE - Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) - D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU - END IF - DMIN = MIN( DMIN, D ) - EMIN = MIN( EMIN, Z( J4 ) ) - 30 CONTINUE - ELSE - DO 40 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) - IF( D.LT.ZERO ) THEN - RETURN - ELSE - Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) - D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU - END IF - DMIN = MIN( DMIN, D ) - EMIN = MIN( EMIN, Z( J4-1 ) ) - 40 CONTINUE - END IF -* -* Unroll last two steps. -* - DNM2 = D - DMIN2 = DMIN - J4 = 4*( N0-2 ) - PP - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM2 + Z( J4P2 ) - IF( DNM2.LT.ZERO ) THEN - RETURN - ELSE - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - 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 - Z( J4-2 ) = DNM1 + Z( J4P2 ) - IF( DNM1.LT.ZERO ) THEN - RETURN - ELSE - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU - END IF - DMIN = MIN( DMIN, DN ) -* - END IF - 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 ) - 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 ) - TEMP = Z( J4+1 ) / Z( J4-2 ) - D = D*TEMP - TAU - IF( D.LT.DTHRESH ) D = ZERO - DMIN = MIN( DMIN, D ) - Z( J4 ) = Z( J4-1 )*TEMP - EMIN = MIN( Z( J4 ), EMIN ) - 50 CONTINUE - ELSE - DO 60 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) - TEMP = Z( J4+2 ) / Z( J4-3 ) - D = D*TEMP - TAU - IF( D.LT.DTHRESH ) D = ZERO - DMIN = MIN( DMIN, D ) - Z( J4-1 ) = Z( J4 )*TEMP - EMIN = MIN( Z( J4-1 ), EMIN ) - 60 CONTINUE - END IF -* -* Unroll last two steps. -* - DNM2 = D - DMIN2 = DMIN - J4 = 4*( N0-2 ) - PP - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM2 + Z( J4P2 ) - 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 - Z( J4-2 ) = DNM1 + Z( J4P2 ) - 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 ) - IF( D.LT.ZERO ) THEN - RETURN - ELSE - Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) - D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU - END IF - IF( D.LT.DTHRESH) D = ZERO - DMIN = MIN( DMIN, D ) - EMIN = MIN( EMIN, Z( J4 ) ) - 70 CONTINUE - ELSE - DO 80 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) - IF( D.LT.ZERO ) THEN - RETURN - ELSE - Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) - D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU - END IF - IF( D.LT.DTHRESH) D = ZERO - DMIN = MIN( DMIN, D ) - EMIN = MIN( EMIN, Z( J4-1 ) ) - 80 CONTINUE - END IF -* -* Unroll last two steps. -* - DNM2 = D - DMIN2 = DMIN - J4 = 4*( N0-2 ) - PP - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM2 + Z( J4P2 ) - IF( DNM2.LT.ZERO ) THEN - RETURN - ELSE - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - 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 - Z( J4-2 ) = DNM1 + Z( J4P2 ) - IF( DNM1.LT.ZERO ) THEN - RETURN - ELSE - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - 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 -* -* End of DLASQ5 -* - END diff --git a/lib/linalg/fortran/dlasq6.f b/lib/linalg/fortran/dlasq6.f deleted file mode 100644 index 9218b5060e..0000000000 --- a/lib/linalg/fortran/dlasq6.f +++ /dev/null @@ -1,251 +0,0 @@ -*> \brief \b DLASQ6 computes one dqd transform in ping-pong form. Used by sbdsqr and sstegr. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASQ6 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* DOUBLE PRECISION Z( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASQ6 computes one dqd (shift equal to zero) transform in -*> ping-pong form, with protection against underflow and overflow. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] I0 -*> \verbatim -*> I0 is INTEGER -*> First index. -*> \endverbatim -*> -*> \param[in] N0 -*> \verbatim -*> N0 is INTEGER -*> Last index. -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( 4*N ) -*> Z holds the qd array. EMIN is stored in Z(4*N0) to avoid -*> an extra argument. -*> \endverbatim -*> -*> \param[in] PP -*> \verbatim -*> PP is INTEGER -*> PP=0 for ping, PP=1 for pong. -*> \endverbatim -*> -*> \param[out] DMIN -*> \verbatim -*> DMIN is DOUBLE PRECISION -*> Minimum value of d. -*> \endverbatim -*> -*> \param[out] DMIN1 -*> \verbatim -*> DMIN1 is DOUBLE PRECISION -*> Minimum value of d, excluding D( N0 ). -*> \endverbatim -*> -*> \param[out] DMIN2 -*> \verbatim -*> DMIN2 is DOUBLE PRECISION -*> Minimum value of d, excluding D( N0 ) and D( N0-1 ). -*> \endverbatim -*> -*> \param[out] DN -*> \verbatim -*> DN is DOUBLE PRECISION -*> d(N0), the last value of d. -*> \endverbatim -*> -*> \param[out] DNM1 -*> \verbatim -*> DNM1 is DOUBLE PRECISION -*> d(N0-1). -*> \endverbatim -*> -*> \param[out] DNM2 -*> \verbatim -*> DNM2 is DOUBLE PRECISION -*> d(N0-2). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, - $ DNM1, DNM2 ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER I0, N0, PP - DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 -* .. -* .. Array Arguments .. - DOUBLE PRECISION Z( * ) -* .. -* -* ===================================================================== -* -* .. Parameter .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -* .. -* .. Local Scalars .. - INTEGER J4, J4P2 - DOUBLE PRECISION D, EMIN, SAFMIN, TEMP -* .. -* .. External Function .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( ( N0-I0-1 ).LE.0 ) - $ RETURN -* - SAFMIN = DLAMCH( 'Safe minimum' ) - J4 = 4*I0 + PP - 3 - 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 ) - IF( Z( J4-2 ).EQ.ZERO ) THEN - Z( J4 ) = ZERO - D = Z( J4+1 ) - DMIN = D - EMIN = ZERO - ELSE IF( SAFMIN*Z( J4+1 ).LT.Z( J4-2 ) .AND. - $ SAFMIN*Z( J4-2 ).LT.Z( J4+1 ) ) THEN - TEMP = Z( J4+1 ) / Z( J4-2 ) - Z( J4 ) = Z( J4-1 )*TEMP - D = D*TEMP - ELSE - Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) - D = Z( J4+1 )*( D / Z( J4-2 ) ) - END IF - DMIN = MIN( DMIN, D ) - EMIN = MIN( EMIN, Z( J4 ) ) - 10 CONTINUE - ELSE - DO 20 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) - IF( Z( J4-3 ).EQ.ZERO ) THEN - Z( J4-1 ) = ZERO - D = Z( J4+2 ) - DMIN = D - EMIN = ZERO - ELSE IF( SAFMIN*Z( J4+2 ).LT.Z( J4-3 ) .AND. - $ SAFMIN*Z( J4-3 ).LT.Z( J4+2 ) ) THEN - TEMP = Z( J4+2 ) / Z( J4-3 ) - Z( J4-1 ) = Z( J4 )*TEMP - D = D*TEMP - ELSE - Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) - D = Z( J4+2 )*( D / Z( J4-3 ) ) - END IF - DMIN = MIN( DMIN, D ) - EMIN = MIN( EMIN, Z( J4-1 ) ) - 20 CONTINUE - END IF -* -* Unroll last two steps. -* - DNM2 = D - DMIN2 = DMIN - J4 = 4*( N0-2 ) - PP - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM2 + Z( J4P2 ) - IF( Z( J4-2 ).EQ.ZERO ) THEN - Z( J4 ) = ZERO - DNM1 = Z( J4P2+2 ) - DMIN = DNM1 - EMIN = ZERO - ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND. - $ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN - TEMP = Z( J4P2+2 ) / Z( J4-2 ) - Z( J4 ) = Z( J4P2 )*TEMP - DNM1 = DNM2*TEMP - ELSE - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - END IF - DMIN = MIN( DMIN, DNM1 ) -* - DMIN1 = DMIN - J4 = J4 + 4 - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM1 + Z( J4P2 ) - IF( Z( J4-2 ).EQ.ZERO ) THEN - Z( J4 ) = ZERO - DN = Z( J4P2+2 ) - DMIN = DN - EMIN = ZERO - ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND. - $ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN - TEMP = Z( J4P2+2 ) / Z( J4-2 ) - Z( J4 ) = Z( J4P2 )*TEMP - DN = DNM1*TEMP - ELSE - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - END IF - DMIN = MIN( DMIN, DN ) -* - Z( J4+2 ) = DN - Z( 4*N0-PP ) = EMIN - RETURN -* -* End of DLASQ6 -* - END diff --git a/lib/linalg/fortran/dlasr.f b/lib/linalg/fortran/dlasr.f deleted file mode 100644 index dd0cedd85e..0000000000 --- a/lib/linalg/fortran/dlasr.f +++ /dev/null @@ -1,433 +0,0 @@ -*> \brief \b DLASR applies a sequence of plane rotations to a general rectangular matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) -* -* .. Scalar Arguments .. -* CHARACTER DIRECT, PIVOT, SIDE -* INTEGER LDA, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> 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 ) -*> ( c(k) s(k) ) -*> ( -s(k) c(k) ) -*> ( 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 ) -*> ( ... ) -*> ( 1 ) -*> ( -s(k) c(k) ) -*> ( 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 ) -*> ( c(k) s(k) ) -*> ( 1 ) -*> ( ... ) -*> ( 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 -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> Specifies whether the plane rotation matrix P is applied to -*> A on the left or the right. -*> = 'L': Left, compute A := P*A -*> = 'R': Right, compute A:= A*P**T -*> \endverbatim -*> -*> \param[in] PIVOT -*> \verbatim -*> PIVOT is CHARACTER*1 -*> Specifies the plane for which P(k) is a plane rotation -*> matrix. -*> = 'V': Variable pivot, the plane (k,k+1) -*> = 'T': Top pivot, the plane (1,k+1) -*> = 'B': Bottom pivot, the plane (k,z) -*> \endverbatim -*> -*> \param[in] DIRECT -*> \verbatim -*> DIRECT is CHARACTER*1 -*> Specifies whether P is a forward or backward sequence of -*> plane rotations. -*> = 'F': Forward, P = P(z-1)*...*P(2)*P(1) -*> = 'B': Backward, P = P(1)*P(2)*...*P(z-1) -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. If m <= 1, an immediate -*> return is effected. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. If n <= 1, an -*> immediate return is effected. -*> \endverbatim -*> -*> \param[in] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension -*> (M-1) if SIDE = 'L' -*> (N-1) if SIDE = 'R' -*> The cosines c(k) of the plane rotations. -*> \endverbatim -*> -*> \param[in] S -*> \verbatim -*> S is DOUBLE PRECISION array, dimension -*> (M-1) if SIDE = 'L' -*> (N-1) if SIDE = 'R' -*> The sines s(k) of the plane rotations. The 2-by-2 plane -*> rotation part of the matrix P(k), R(k), has the form -*> R(k) = ( c(k) s(k) ) -*> ( -s(k) c(k) ). -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The M-by-N matrix A. On exit, A is overwritten by P*A if -*> SIDE = 'L' or by A*P**T if SIDE = 'R'. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, PIVOT, SIDE - INTEGER LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, INFO, J - DOUBLE PRECISION CTEMP, STEMP, TEMP -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN - INFO = 1 - ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, - $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN - INFO = 2 - ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) - $ THEN - INFO = 3 - ELSE IF( M.LT.0 ) THEN - INFO = 4 - ELSE IF( N.LT.0 ) THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = 9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLASR ', INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) - $ RETURN - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form P * A -* - IF( LSAME( PIVOT, 'V' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 20 J = 1, M - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 10 I = 1, N - TEMP = A( J+1, I ) - A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) - A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 40 J = M - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 30 I = 1, N - TEMP = A( J+1, I ) - A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) - A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) - 30 CONTINUE - END IF - 40 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'T' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 60 J = 2, M - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 50 I = 1, N - TEMP = A( J, I ) - A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) - A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 80 J = M, 2, -1 - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 70 I = 1, N - TEMP = A( J, I ) - A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) - A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) - 70 CONTINUE - END IF - 80 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'B' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 100 J = 1, M - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 90 I = 1, N - TEMP = A( J, I ) - A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP - A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP - 90 CONTINUE - END IF - 100 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 120 J = M - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 110 I = 1, N - TEMP = A( J, I ) - A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP - A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP - 110 CONTINUE - END IF - 120 CONTINUE - END IF - END IF - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form A * P**T -* - IF( LSAME( PIVOT, 'V' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 140 J = 1, N - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 130 I = 1, M - TEMP = A( I, J+1 ) - A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) - A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) - 130 CONTINUE - END IF - 140 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 160 J = N - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 150 I = 1, M - TEMP = A( I, J+1 ) - A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) - A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) - 150 CONTINUE - END IF - 160 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'T' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 180 J = 2, N - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 170 I = 1, M - TEMP = A( I, J ) - A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) - A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) - 170 CONTINUE - END IF - 180 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 200 J = N, 2, -1 - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 190 I = 1, M - TEMP = A( I, J ) - A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) - A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) - 190 CONTINUE - END IF - 200 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'B' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 220 J = 1, N - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 210 I = 1, M - TEMP = A( I, J ) - A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP - A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP - 210 CONTINUE - END IF - 220 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 240 J = N - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 230 I = 1, M - TEMP = A( I, J ) - A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP - A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP - 230 CONTINUE - END IF - 240 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DLASR -* - END diff --git a/lib/linalg/fortran/dlasrt.f b/lib/linalg/fortran/dlasrt.f deleted file mode 100644 index d789239e3d..0000000000 --- a/lib/linalg/fortran/dlasrt.f +++ /dev/null @@ -1,300 +0,0 @@ -*> \brief \b DLASRT sorts numbers in increasing or decreasing order. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASRT( ID, N, D, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER ID -* INTEGER INFO, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Sort the numbers in D in increasing order (if ID = 'I') or -*> in decreasing order (if ID = 'D' ). -*> -*> Use Quick Sort, reverting to Insertion sort on arrays of -*> size <= 20. Dimension of STACK limits N to about 2**32. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ID -*> \verbatim -*> ID is CHARACTER*1 -*> = 'I': sort D in increasing order; -*> = 'D': sort D in decreasing order. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The length of the array D. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the array to be sorted. -*> On exit, D has been sorted into increasing order -*> (D(1) <= ... <= D(N) ) or into decreasing order -*> (D(1) >= ... >= D(N) ), depending on ID. -*> \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. -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DLASRT( ID, N, D, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER ID - INTEGER INFO, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER SELECT - PARAMETER ( SELECT = 20 ) -* .. -* .. Local Scalars .. - INTEGER DIR, ENDD, I, J, START, STKPNT - DOUBLE PRECISION D1, D2, D3, DMNMX, TMP -* .. -* .. Local Arrays .. - INTEGER STACK( 2, 32 ) -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - DIR = -1 - IF( LSAME( ID, 'D' ) ) THEN - DIR = 0 - ELSE IF( LSAME( ID, 'I' ) ) THEN - DIR = 1 - END IF - IF( DIR.EQ.-1 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLASRT', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.1 ) - $ RETURN -* - STKPNT = 1 - STACK( 1, 1 ) = 1 - STACK( 2, 1 ) = N - 10 CONTINUE - START = STACK( 1, STKPNT ) - ENDD = STACK( 2, STKPNT ) - STKPNT = STKPNT - 1 - IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN -* -* Do Insertion sort on D( START:ENDD ) -* - IF( DIR.EQ.0 ) THEN -* -* Sort into decreasing order -* - DO 30 I = START + 1, ENDD - DO 20 J = I, START + 1, -1 - IF( D( J ).GT.D( J-1 ) ) THEN - DMNMX = D( J ) - D( J ) = D( J-1 ) - D( J-1 ) = DMNMX - ELSE - GO TO 30 - END IF - 20 CONTINUE - 30 CONTINUE -* - ELSE -* -* Sort into increasing order -* - DO 50 I = START + 1, ENDD - DO 40 J = I, START + 1, -1 - IF( D( J ).LT.D( J-1 ) ) THEN - DMNMX = D( J ) - D( J ) = D( J-1 ) - D( J-1 ) = DMNMX - ELSE - GO TO 50 - END IF - 40 CONTINUE - 50 CONTINUE -* - END IF -* - ELSE IF( ENDD-START.GT.SELECT ) THEN -* -* Partition D( START:ENDD ) and stack parts, largest one first -* -* Choose partition entry as median of 3 -* - D1 = D( START ) - D2 = D( ENDD ) - I = ( START+ENDD ) / 2 - D3 = D( I ) - IF( D1.LT.D2 ) THEN - IF( D3.LT.D1 ) THEN - DMNMX = D1 - ELSE IF( D3.LT.D2 ) THEN - DMNMX = D3 - ELSE - DMNMX = D2 - END IF - ELSE - IF( D3.LT.D2 ) THEN - DMNMX = D2 - ELSE IF( D3.LT.D1 ) THEN - DMNMX = D3 - ELSE - DMNMX = D1 - END IF - END IF -* - IF( DIR.EQ.0 ) THEN -* -* Sort into decreasing order -* - I = START - 1 - J = ENDD + 1 - 60 CONTINUE - 70 CONTINUE - J = J - 1 - IF( D( J ).LT.DMNMX ) - $ GO TO 70 - 80 CONTINUE - I = I + 1 - IF( D( I ).GT.DMNMX ) - $ GO TO 80 - IF( I.LT.J ) THEN - TMP = D( I ) - D( I ) = D( J ) - D( J ) = TMP - GO TO 60 - END IF - IF( J-START.GT.ENDD-J-1 ) THEN - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = START - STACK( 2, STKPNT ) = J - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = J + 1 - STACK( 2, STKPNT ) = ENDD - ELSE - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = J + 1 - STACK( 2, STKPNT ) = ENDD - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = START - STACK( 2, STKPNT ) = J - END IF - ELSE -* -* Sort into increasing order -* - I = START - 1 - J = ENDD + 1 - 90 CONTINUE - 100 CONTINUE - J = J - 1 - IF( D( J ).GT.DMNMX ) - $ GO TO 100 - 110 CONTINUE - I = I + 1 - IF( D( I ).LT.DMNMX ) - $ GO TO 110 - IF( I.LT.J ) THEN - TMP = D( I ) - D( I ) = D( J ) - D( J ) = TMP - GO TO 90 - END IF - IF( J-START.GT.ENDD-J-1 ) THEN - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = START - STACK( 2, STKPNT ) = J - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = J + 1 - STACK( 2, STKPNT ) = ENDD - ELSE - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = J + 1 - STACK( 2, STKPNT ) = ENDD - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = START - STACK( 2, STKPNT ) = J - END IF - END IF - END IF - IF( STKPNT.GT.0 ) - $ GO TO 10 - RETURN -* -* End of DLASRT -* - END diff --git a/lib/linalg/fortran/dlassq.f b/lib/linalg/fortran/dlassq.f deleted file mode 100644 index 885395e3c9..0000000000 --- a/lib/linalg/fortran/dlassq.f +++ /dev/null @@ -1,155 +0,0 @@ -*> \brief \b DLASSQ updates a sum of squares represented in scaled form. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASSQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) -* -* .. Scalar Arguments .. -* INTEGER INCX, N -* DOUBLE PRECISION SCALE, SUMSQ -* .. -* .. Array Arguments .. -* DOUBLE PRECISION X( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASSQ returns the values scl and smsq such that -*> -*> ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, -*> -*> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is -*> assumed to be non-negative and scl returns the value -*> -*> scl = max( scale, abs( x( i ) ) ). -*> -*> scale and sumsq must be supplied in SCALE and SUMSQ and -*> scl and smsq are overwritten on SCALE and SUMSQ respectively. -*> -*> The routine makes only one pass through the vector x. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of elements to be used from the vector X. -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension (N) -*> The vector for which a scaled sum of squares is computed. -*> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> The increment between successive values of the vector X. -*> INCX > 0. -*> \endverbatim -*> -*> \param[in,out] SCALE -*> \verbatim -*> SCALE is DOUBLE PRECISION -*> On entry, the value scale in the equation above. -*> On exit, SCALE is overwritten with scl , the scaling factor -*> for the sum of squares. -*> \endverbatim -*> -*> \param[in,out] SUMSQ -*> \verbatim -*> SUMSQ is DOUBLE PRECISION -*> On entry, the value sumsq in the equation above. -*> On exit, SUMSQ is overwritten with smsq , the basic sum of -*> squares from which scl has been factored out. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date December 2016 -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) -* -* -- 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 INCX, N - DOUBLE PRECISION SCALE, SUMSQ -* .. -* .. Array Arguments .. - DOUBLE PRECISION X( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER IX - DOUBLE PRECISION ABSXI -* .. -* .. External Functions .. - LOGICAL DISNAN - EXTERNAL DISNAN -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Executable Statements .. -* - IF( N.GT.0 ) THEN - DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX - ABSXI = ABS( X( IX ) ) - IF( ABSXI.GT.ZERO.OR.DISNAN( ABSXI ) ) THEN - IF( SCALE.LT.ABSXI ) THEN - SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 - SCALE = ABSXI - ELSE - SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 - END IF - END IF - 10 CONTINUE - END IF - RETURN -* -* End of DLASSQ -* - END diff --git a/lib/linalg/fortran/dlasv2.f b/lib/linalg/fortran/dlasv2.f deleted file mode 100644 index 64a06dee1a..0000000000 --- a/lib/linalg/fortran/dlasv2.f +++ /dev/null @@ -1,322 +0,0 @@ -*> \brief \b DLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASV2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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: -* ============= -*> -*> \verbatim -*> -*> DLASV2 computes the singular value decomposition of a 2-by-2 -*> triangular matrix -*> [ F G ] -*> [ 0 H ]. -*> On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the -*> smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and -*> right singular vectors for abs(SSMAX), giving the decomposition -*> -*> [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] -*> [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] F -*> \verbatim -*> F is DOUBLE PRECISION -*> The (1,1) element of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[in] G -*> \verbatim -*> G is DOUBLE PRECISION -*> The (1,2) element of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[in] H -*> \verbatim -*> H is DOUBLE PRECISION -*> The (2,2) element of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[out] SSMIN -*> \verbatim -*> SSMIN is DOUBLE PRECISION -*> abs(SSMIN) is the smaller singular value. -*> \endverbatim -*> -*> \param[out] SSMAX -*> \verbatim -*> SSMAX is DOUBLE PRECISION -*> abs(SSMAX) is the larger singular value. -*> \endverbatim -*> -*> \param[out] SNL -*> \verbatim -*> SNL is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[out] CSL -*> \verbatim -*> CSL is DOUBLE PRECISION -*> The vector (CSL, SNL) is a unit left singular vector for the -*> singular value abs(SSMAX). -*> \endverbatim -*> -*> \param[out] SNR -*> \verbatim -*> SNR is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[out] CSR -*> \verbatim -*> CSR is DOUBLE PRECISION -*> The vector (CSR, SNR) is a unit right singular vector for the -*> singular value abs(SSMAX). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Any input parameter may be aliased with any output parameter. -*> -*> Barring over/underflow and assuming a guard digit in subtraction, all -*> output quantities are correct to within a few units in the last -*> place (ulps). -*> -*> In IEEE arithmetic, the code works correctly if one matrix element is -*> infinite. -*> -*> Overflow will not occur unless the largest singular value itself -*> overflows or is within a few ulps of overflow. (On machines with -*> partial overflow, like the Cray, overflow may occur if the largest -*> singular value is within a factor of 2 of overflow.) -*> -*> Underflow is harmless if underflow is gradual. Otherwise, results -*> may correspond to a matrix modified by perturbations of size near -*> the underflow threshold. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION HALF - PARAMETER ( HALF = 0.5D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) - DOUBLE PRECISION FOUR - PARAMETER ( FOUR = 4.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL GASMAL, SWAP - INTEGER PMAX - DOUBLE PRECISION A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M, - $ MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SIGN, SQRT -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Executable Statements .. -* - FT = F - FA = ABS( FT ) - HT = H - HA = ABS( H ) -* -* PMAX points to the maximum absolute element of matrix -* PMAX = 1 if F largest in absolute values -* PMAX = 2 if G largest in absolute values -* PMAX = 3 if H largest in absolute values -* - PMAX = 1 - SWAP = ( HA.GT.FA ) - IF( SWAP ) THEN - PMAX = 3 - TEMP = FT - FT = HT - HT = TEMP - TEMP = FA - FA = HA - HA = TEMP -* -* Now FA .ge. HA -* - END IF - GT = G - GA = ABS( GT ) - IF( GA.EQ.ZERO ) THEN -* -* Diagonal matrix -* - SSMIN = HA - SSMAX = FA - CLT = ONE - CRT = ONE - SLT = ZERO - SRT = ZERO - ELSE - GASMAL = .TRUE. - IF( GA.GT.FA ) THEN - PMAX = 2 - IF( ( FA / GA ).LT.DLAMCH( 'EPS' ) ) THEN -* -* Case of very large GA -* - GASMAL = .FALSE. - SSMAX = GA - IF( HA.GT.ONE ) THEN - SSMIN = FA / ( GA / HA ) - ELSE - SSMIN = ( FA / GA )*HA - END IF - CLT = ONE - SLT = HT / GT - SRT = ONE - CRT = FT / GT - END IF - END IF - IF( GASMAL ) THEN -* -* Normal case -* - D = FA - HA - IF( D.EQ.FA ) THEN -* -* Copes with infinite F or H -* - L = ONE - ELSE - L = D / FA - END IF -* -* Note that 0 .le. L .le. 1 -* - M = GT / FT -* -* Note that abs(M) .le. 1/macheps -* - T = TWO - L -* -* Note that T .ge. 1 -* - MM = M*M - TT = T*T - S = SQRT( TT+MM ) -* -* Note that 1 .le. S .le. 1 + 1/macheps -* - IF( L.EQ.ZERO ) THEN - R = ABS( M ) - ELSE - R = SQRT( L*L+MM ) - END IF -* -* Note that 0 .le. R .le. 1 + 1/macheps -* - A = HALF*( S+R ) -* -* Note that 1 .le. A .le. 1 + abs(M) -* - SSMIN = HA / A - SSMAX = FA*A - IF( MM.EQ.ZERO ) THEN -* -* Note that M is very tiny -* - IF( L.EQ.ZERO ) THEN - T = SIGN( TWO, FT )*SIGN( ONE, GT ) - ELSE - T = GT / SIGN( D, FT ) + M / T - END IF - ELSE - T = ( M / ( S+T )+M / ( R+L ) )*( ONE+A ) - END IF - L = SQRT( T*T+FOUR ) - CRT = TWO / L - SRT = T / L - CLT = ( CRT+SRT*M ) / A - SLT = ( HT / FT )*SRT / A - END IF - END IF - IF( SWAP ) THEN - CSL = SRT - SNL = CRT - CSR = SLT - SNR = CLT - ELSE - CSL = CLT - SNL = SLT - CSR = CRT - SNR = SRT - END IF -* -* Correct signs of SSMAX and SSMIN -* - IF( PMAX.EQ.1 ) - $ TSIGN = SIGN( ONE, CSR )*SIGN( ONE, CSL )*SIGN( ONE, F ) - IF( PMAX.EQ.2 ) - $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, CSL )*SIGN( ONE, G ) - IF( PMAX.EQ.3 ) - $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, SNL )*SIGN( ONE, H ) - SSMAX = SIGN( SSMAX, TSIGN ) - SSMIN = SIGN( SSMIN, TSIGN*SIGN( ONE, F )*SIGN( ONE, H ) ) - RETURN -* -* End of DLASV2 -* - END diff --git a/lib/linalg/fortran/dlaswp.f b/lib/linalg/fortran/dlaswp.f deleted file mode 100644 index b35729a205..0000000000 --- a/lib/linalg/fortran/dlaswp.f +++ /dev/null @@ -1,190 +0,0 @@ -*> \brief \b DLASWP performs a series of row interchanges on a general rectangular matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASWP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* -* .. Scalar Arguments .. -* INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASWP performs a series of row interchanges on the matrix A. -*> One row interchange is initiated for each of rows K1 through K2 of A. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the matrix of column dimension N to which the row -*> interchanges will be applied. -*> On exit, the permuted matrix. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> \endverbatim -*> -*> \param[in] K1 -*> \verbatim -*> K1 is INTEGER -*> The first element of IPIV for which a row interchange will -*> be done. -*> \endverbatim -*> -*> \param[in] K2 -*> \verbatim -*> K2 is INTEGER -*> (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 (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 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. -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Modified by -*> R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 - DOUBLE PRECISION TEMP -* .. -* .. Executable Statements .. -* -* 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 - I1 = K1 - I2 = K2 - INC = 1 - ELSE IF( INCX.LT.0 ) THEN - IX0 = K1 + ( K1-K2 )*INCX - I1 = K2 - I2 = K1 - INC = -1 - ELSE - RETURN - END IF -* - N32 = ( N / 32 )*32 - IF( N32.NE.0 ) THEN - DO 30 J = 1, N32, 32 - IX = IX0 - DO 20 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 10 K = J, J + 31 - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 10 CONTINUE - END IF - IX = IX + INCX - 20 CONTINUE - 30 CONTINUE - END IF - IF( N32.NE.N ) THEN - N32 = N32 + 1 - IX = IX0 - DO 50 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 40 K = N32, N - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 40 CONTINUE - END IF - IX = IX + INCX - 50 CONTINUE - END IF -* - RETURN -* -* End of DLASWP -* - END diff --git a/lib/linalg/fortran/dlatrd.f b/lib/linalg/fortran/dlatrd.f deleted file mode 100644 index 010a85a212..0000000000 --- a/lib/linalg/fortran/dlatrd.f +++ /dev/null @@ -1,333 +0,0 @@ -*> \brief \b DLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiagonal form by an orthogonal similarity transformation. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLATRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER LDA, LDW, N, NB -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLATRD reduces NB rows and columns of a real symmetric matrix A to -*> symmetric tridiagonal form by an orthogonal similarity -*> transformation Q**T * A * Q, and returns the matrices V and W which are -*> needed to apply the transformation to the unreduced part of A. -*> -*> If UPLO = 'U', DLATRD reduces the last NB rows and columns of a -*> matrix, of which the upper triangle is supplied; -*> if UPLO = 'L', DLATRD reduces the first NB rows and columns of a -*> matrix, of which the lower triangle is supplied. -*> -*> This is an auxiliary routine called by DSYTRD. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies whether the upper or lower triangular part of the -*> symmetric matrix A is stored: -*> = 'U': Upper triangular -*> = 'L': Lower triangular -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. -*> \endverbatim -*> -*> \param[in] NB -*> \verbatim -*> NB is INTEGER -*> The number of rows and columns to be reduced. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the leading -*> n-by-n upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading n-by-n lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> On exit: -*> if UPLO = 'U', the last NB columns have been reduced to -*> tridiagonal form, with the diagonal elements overwriting -*> the diagonal elements of A; the elements above the diagonal -*> with the array TAU, represent the orthogonal matrix Q as a -*> product of elementary reflectors; -*> if UPLO = 'L', the first NB columns have been reduced to -*> tridiagonal form, with the diagonal elements overwriting -*> the diagonal elements of A; the elements below the diagonal -*> with the array TAU, represent the orthogonal matrix Q as a -*> product of elementary reflectors. -*> See Further Details. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= (1,N). -*> \endverbatim -*> -*> \param[out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal -*> elements of the last NB columns of the reduced matrix; -*> if UPLO = 'L', E(1:nb) contains the subdiagonal elements of -*> the first NB columns of the reduced matrix. -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (N-1) -*> The scalar factors of the elementary reflectors, stored in -*> TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. -*> See Further Details. -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (LDW,NB) -*> The n-by-nb matrix W required to update the unreduced part -*> of A. -*> \endverbatim -*> -*> \param[in] LDW -*> \verbatim -*> LDW is INTEGER -*> The leading dimension of the array W. LDW >= max(1,N). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> If UPLO = 'U', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(n) H(n-1) . . . H(n-nb+1). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**T -*> -*> where tau is a real scalar, and v is a real vector with -*> v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), -*> and tau in TAU(i-1). -*> -*> If UPLO = 'L', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(1) H(2) . . . H(nb). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**T -*> -*> where tau is a real scalar, and v is a real vector with -*> v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), -*> and tau in TAU(i). -*> -*> The elements of the vectors v together form the n-by-nb matrix V -*> which is needed, with W, to apply the transformation to the unreduced -*> part of the matrix, using a symmetric rank-2k update of the form: -*> A := A - V*W**T - W*V**T. -*> -*> The contents of A on exit are illustrated by the following examples -*> with n = 5 and nb = 2: -*> -*> if UPLO = 'U': if UPLO = 'L': -*> -*> ( a a a v4 v5 ) ( d ) -*> ( a a v4 v5 ) ( 1 d ) -*> ( a 1 v5 ) ( v1 1 a ) -*> ( d 1 ) ( v1 v2 a a ) -*> ( d ) ( v1 v2 a a a ) -*> -*> where d denotes a diagonal element of the reduced matrix, a denotes -*> an element of the original matrix that is unchanged, and vi denotes -*> an element of the vector defining H(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDW, N, NB -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IW - DOUBLE PRECISION ALPHA -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DGEMV, DLARFG, DSCAL, DSYMV -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL LSAME, DDOT -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Reduce last NB columns of upper triangle -* - DO 10 I = N, N - NB + 1, -1 - IW = I - N + NB - IF( I.LT.N ) THEN -* -* Update A(1:i,i) -* - CALL DGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ), - $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 ) - CALL DGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ), - $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 ) - END IF - IF( I.GT.1 ) THEN -* -* Generate elementary reflector H(i) to annihilate -* A(1:i-2,i) -* - CALL DLARFG( I-1, A( I-1, I ), A( 1, I ), 1, TAU( I-1 ) ) - E( I-1 ) = A( I-1, I ) - A( I-1, I ) = ONE -* -* Compute W(1:i-1,i) -* - CALL DSYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1, - $ ZERO, W( 1, IW ), 1 ) - IF( I.LT.N ) THEN - CALL DGEMV( 'Transpose', I-1, N-I, ONE, W( 1, IW+1 ), - $ LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, -ONE, - $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, - $ W( 1, IW ), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ), - $ LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, -ONE, - $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, - $ W( 1, IW ), 1 ) - END IF - CALL DSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 ) - ALPHA = -HALF*TAU( I-1 )*DDOT( I-1, W( 1, IW ), 1, - $ A( 1, I ), 1 ) - CALL DAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 ) - END IF -* - 10 CONTINUE - ELSE -* -* Reduce first NB columns of lower triangle -* - DO 20 I = 1, NB -* -* Update A(i:n,i) -* - CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ), - $ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 ) - CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ), - $ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 ) - IF( I.LT.N ) THEN -* -* Generate elementary reflector H(i) to annihilate -* A(i+2:n,i) -* - CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, - $ TAU( I ) ) - E( I ) = A( I+1, I ) - A( I+1, I ) = ONE -* -* Compute W(i+1:n,i) -* - CALL DSYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA, - $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), LDW, - $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ), - $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA, - $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ), - $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) - CALL DSCAL( N-I, TAU( I ), W( I+1, I ), 1 ) - ALPHA = -HALF*TAU( I )*DDOT( N-I, W( I+1, I ), 1, - $ A( I+1, I ), 1 ) - CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 ) - END IF -* - 20 CONTINUE - END IF -* - RETURN -* -* End of DLATRD -* - END diff --git a/lib/linalg/fortran/dlatrs.f b/lib/linalg/fortran/dlatrs.f deleted file mode 100644 index be156bee20..0000000000 --- a/lib/linalg/fortran/dlatrs.f +++ /dev/null @@ -1,843 +0,0 @@ -*> \brief \b DLATRS solves a triangular system of equations with the scale factor set to prevent overflow. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLATRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* DOUBLE PRECISION SCALE -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), CNORM( * ), X( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLATRS solves one of the triangular systems -*> -*> A *x = s*b or A**T *x = s*b -*> -*> with scaling to prevent overflow. Here A is an upper or lower -*> triangular matrix, A**T denotes the transpose of A, x and b are -*> n-element vectors, and s is a scaling factor, usually less than -*> or equal to 1, chosen so that the components of x will be less than -*> the overflow threshold. If the unscaled problem will not cause -*> overflow, the Level 2 BLAS routine DTRSV is called. If the matrix A -*> is singular (A(j,j) = 0 for some j), then s is set to 0 and a -*> non-trivial solution to A*x = 0 is returned. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies whether the matrix A is upper or lower triangular. -*> = 'U': Upper triangular -*> = 'L': Lower triangular -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> Specifies the operation applied to A. -*> = 'N': Solve A * x = s*b (No transpose) -*> = 'T': Solve A**T* x = s*b (Transpose) -*> = 'C': Solve A**T* x = s*b (Conjugate transpose = Transpose) -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> Specifies whether or not the matrix A is unit triangular. -*> = 'N': Non-unit triangular -*> = 'U': Unit triangular -*> \endverbatim -*> -*> \param[in] NORMIN -*> \verbatim -*> NORMIN is CHARACTER*1 -*> Specifies whether CNORM has been set or not. -*> = 'Y': CNORM contains the column norms on entry -*> = 'N': CNORM is not set on entry. On exit, the norms will -*> be computed and stored in CNORM. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The triangular matrix A. If UPLO = 'U', the leading n by n -*> upper triangular part of the array A contains the upper -*> triangular matrix, and the strictly lower triangular part of -*> A is not referenced. If UPLO = 'L', the leading n by n lower -*> triangular part of the array A contains the lower triangular -*> matrix, and the strictly upper triangular part of A is not -*> referenced. If DIAG = 'U', the diagonal elements of A are -*> also not referenced and are assumed to be 1. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max (1,N). -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension (N) -*> On entry, the right hand side b of the triangular system. -*> On exit, X is overwritten by the solution vector x. -*> \endverbatim -*> -*> \param[out] SCALE -*> \verbatim -*> SCALE is DOUBLE PRECISION -*> The scaling factor s for the triangular system -*> A * x = s*b or A**T* x = s*b. -*> If SCALE = 0, the matrix A is singular or badly scaled, and -*> the vector x is an exact or approximate solution to A*x = 0. -*> \endverbatim -*> -*> \param[in,out] CNORM -*> \verbatim -*> CNORM is DOUBLE PRECISION array, dimension (N) -*> -*> If NORMIN = 'Y', CNORM is an input argument and CNORM(j) -*> contains the norm of the off-diagonal part of the j-th column -*> of A. If TRANS = 'N', CNORM(j) must be greater than or equal -*> to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) -*> must be greater than or equal to the 1-norm. -*> -*> If NORMIN = 'N', CNORM is an output argument and CNORM(j) -*> returns the 1-norm of the offdiagonal part of the j-th column -*> of A. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -k, the k-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. -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> A rough bound on x is computed; if that is less than overflow, DTRSV -*> is called, otherwise, specific code is used which checks for possible -*> overflow or divide-by-zero at every operation. -*> -*> A columnwise scheme is used for solving A*x = b. The basic algorithm -*> if A is lower triangular is -*> -*> x[1:n] := b[1:n] -*> for j = 1, ..., n -*> x(j) := x(j) / A(j,j) -*> x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] -*> end -*> -*> Define bounds on the components of x after j iterations of the loop: -*> M(j) = bound on x[1:j] -*> G(j) = bound on x[j+1:n] -*> Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. -*> -*> Then for iteration j+1 we have -*> M(j+1) <= G(j) / | A(j+1,j+1) | -*> G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | -*> <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) -*> -*> where CNORM(j+1) is greater than or equal to the infinity-norm of -*> column j+1 of A, not counting the diagonal. Hence -*> -*> G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) -*> 1<=i<=j -*> and -*> -*> |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) -*> 1<=i< j -*> -*> Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the -*> reciprocal of the largest M(j), j=1,..,n, is larger than -*> max(underflow, 1/overflow). -*> -*> The bound on x(j) is also used to determine when a step in the -*> columnwise method can be performed without fear of overflow. If -*> the computed bound is greater than a large constant, x is scaled to -*> prevent overflow, but if the bound overflows, x is set to 0, x(j) to -*> 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. -*> -*> Similarly, a row-wise scheme is used to solve A**T*x = b. The basic -*> algorithm for A upper triangular is -*> -*> for j = 1, ..., n -*> x(j) := ( b(j) - A[1:j-1,j]**T * x[1:j-1] ) / A(j,j) -*> end -*> -*> We simultaneously compute two bounds -*> G(j) = bound on ( b(i) - A[1:i-1,i]**T * x[1:i-1] ), 1<=i<=j -*> M(j) = bound on x(i), 1<=i<=j -*> -*> The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we -*> add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. -*> Then the bound on x(j) is -*> -*> M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | -*> -*> <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) -*> 1<=i<=j -*> -*> and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater -*> than max(underflow, 1/overflow). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, - $ CNORM, INFO ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIAG, NORMIN, TRANS, UPLO - INTEGER INFO, LDA, N - DOUBLE PRECISION SCALE -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), CNORM( * ), X( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN, NOUNIT, UPPER - INTEGER I, IMAX, J, JFIRST, JINC, JLAST - DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS, - $ TMAX, TSCAL, USCAL, XBND, XJ, XMAX -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DASUM, DDOT, DLAMCH, DLANGE - EXTERNAL LSAME, IDAMAX, DASUM, DDOT, DLAMCH, DLANGE -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DSCAL, DTRSV, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. Executable Statements .. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOTRAN = LSAME( TRANS, 'N' ) - NOUNIT = LSAME( DIAG, 'N' ) -* -* Test the input parameters. -* - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -3 - ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. - $ LSAME( NORMIN, 'N' ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLATRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - SCALE = ONE - IF( N.EQ.0 ) - $ RETURN -* -* Determine machine dependent parameters to control overflow. -* - SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM -* - IF( LSAME( NORMIN, 'N' ) ) THEN -* -* Compute the 1-norm of each column, not including the diagonal. -* - IF( UPPER ) THEN -* -* A is upper triangular. -* - DO 10 J = 1, N - CNORM( J ) = DASUM( J-1, A( 1, J ), 1 ) - 10 CONTINUE - ELSE -* -* A is lower triangular. -* - DO 20 J = 1, N - 1 - CNORM( J ) = DASUM( N-J, A( J+1, J ), 1 ) - 20 CONTINUE - CNORM( N ) = ZERO - END IF - END IF -* -* Scale the column norms by TSCAL if the maximum element in CNORM is -* greater than BIGNUM. -* - IMAX = IDAMAX( N, CNORM, 1 ) - TMAX = CNORM( IMAX ) - IF( TMAX.LE.BIGNUM ) THEN - TSCAL = ONE - ELSE -* -* Avoid NaN generation if entries in CNORM exceed the -* overflow threshold -* - IF( TMAX.LE.DLAMCH('Overflow') ) THEN -* Case 1: All entries in CNORM are valid floating-point numbers - TSCAL = ONE / ( SMLNUM*TMAX ) - CALL DSCAL( N, TSCAL, CNORM, 1 ) - ELSE -* Case 2: At least one column norm of A cannot be represented -* as floating-point number. Find the offdiagonal entry A( I, J ) -* with the largest absolute value. If this entry is not +/- Infinity, -* use this value as TSCAL. - TMAX = ZERO - IF( UPPER ) THEN -* -* A is upper triangular. -* - DO J = 2, N - TMAX = MAX( DLANGE( 'M', J-1, 1, A( 1, J ), 1, SUMJ ), - $ TMAX ) - END DO - ELSE -* -* A is lower triangular. -* - DO J = 1, N - 1 - TMAX = MAX( DLANGE( 'M', N-J, 1, A( J+1, J ), 1, - $ SUMJ ), TMAX ) - END DO - END IF -* - IF( TMAX.LE.DLAMCH('Overflow') ) THEN - TSCAL = ONE / ( SMLNUM*TMAX ) - DO J = 1, N - IF( CNORM( J ).LE.DLAMCH('Overflow') ) THEN - CNORM( J ) = CNORM( J )*TSCAL - ELSE -* Recompute the 1-norm without introducing Infinity -* in the summation - CNORM( J ) = ZERO - IF( UPPER ) THEN - DO I = 1, J - 1 - CNORM( J ) = CNORM( J ) + - $ TSCAL * ABS( A( I, J ) ) - END DO - ELSE - DO I = J + 1, N - CNORM( J ) = CNORM( J ) + - $ TSCAL * ABS( A( I, J ) ) - END DO - END IF - END IF - END DO - ELSE -* At least one entry of A is not a valid floating-point entry. -* Rely on TRSV to propagate Inf and NaN. - CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 ) - RETURN - END IF - END IF - END IF -* -* Compute a bound on the computed solution vector to see if the -* Level 2 BLAS routine DTRSV can be used. -* - J = IDAMAX( N, X, 1 ) - XMAX = ABS( X( J ) ) - XBND = XMAX - IF( NOTRAN ) THEN -* -* Compute the growth in A * x = b. -* - IF( UPPER ) THEN - JFIRST = N - JLAST = 1 - JINC = -1 - ELSE - JFIRST = 1 - JLAST = N - JINC = 1 - END IF -* - IF( TSCAL.NE.ONE ) THEN - GROW = ZERO - GO TO 50 - END IF -* - IF( NOUNIT ) THEN -* -* A is non-unit triangular. -* -* Compute GROW = 1/G(j) and XBND = 1/M(j). -* Initially, G(0) = max{x(i), i=1,...,n}. -* - GROW = ONE / MAX( XBND, SMLNUM ) - XBND = GROW - DO 30 J = JFIRST, JLAST, JINC -* -* Exit the loop if the growth factor is too small. -* - IF( GROW.LE.SMLNUM ) - $ GO TO 50 -* -* M(j) = G(j-1) / abs(A(j,j)) -* - TJJ = ABS( A( J, J ) ) - XBND = MIN( XBND, MIN( ONE, TJJ )*GROW ) - IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN -* -* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) -* - GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) ) - ELSE -* -* G(j) could overflow, set GROW to 0. -* - GROW = ZERO - END IF - 30 CONTINUE - GROW = XBND - ELSE -* -* A is unit triangular. -* -* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. -* - GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) - DO 40 J = JFIRST, JLAST, JINC -* -* Exit the loop if the growth factor is too small. -* - IF( GROW.LE.SMLNUM ) - $ GO TO 50 -* -* G(j) = G(j-1)*( 1 + CNORM(j) ) -* - GROW = GROW*( ONE / ( ONE+CNORM( J ) ) ) - 40 CONTINUE - END IF - 50 CONTINUE -* - ELSE -* -* Compute the growth in A**T * x = b. -* - IF( UPPER ) THEN - JFIRST = 1 - JLAST = N - JINC = 1 - ELSE - JFIRST = N - JLAST = 1 - JINC = -1 - END IF -* - IF( TSCAL.NE.ONE ) THEN - GROW = ZERO - GO TO 80 - END IF -* - IF( NOUNIT ) THEN -* -* A is non-unit triangular. -* -* Compute GROW = 1/G(j) and XBND = 1/M(j). -* Initially, M(0) = max{x(i), i=1,...,n}. -* - GROW = ONE / MAX( XBND, SMLNUM ) - XBND = GROW - DO 60 J = JFIRST, JLAST, JINC -* -* Exit the loop if the growth factor is too small. -* - IF( GROW.LE.SMLNUM ) - $ GO TO 80 -* -* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) -* - XJ = ONE + CNORM( J ) - GROW = MIN( GROW, XBND / XJ ) -* -* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) -* - TJJ = ABS( A( J, J ) ) - IF( XJ.GT.TJJ ) - $ XBND = XBND*( TJJ / XJ ) - 60 CONTINUE - GROW = MIN( GROW, XBND ) - ELSE -* -* A is unit triangular. -* -* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. -* - GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) - DO 70 J = JFIRST, JLAST, JINC -* -* Exit the loop if the growth factor is too small. -* - IF( GROW.LE.SMLNUM ) - $ GO TO 80 -* -* G(j) = ( 1 + CNORM(j) )*G(j-1) -* - XJ = ONE + CNORM( J ) - GROW = GROW / XJ - 70 CONTINUE - END IF - 80 CONTINUE - END IF -* - IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN -* -* Use the Level 2 BLAS solve if the reciprocal of the bound on -* elements of X is not too small. -* - CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 ) - ELSE -* -* Use a Level 1 BLAS solve, scaling intermediate results. -* - IF( XMAX.GT.BIGNUM ) THEN -* -* Scale X so that its components are less than or equal to -* BIGNUM in absolute value. -* - SCALE = BIGNUM / XMAX - CALL DSCAL( N, SCALE, X, 1 ) - XMAX = BIGNUM - END IF -* - IF( NOTRAN ) THEN -* -* Solve A * x = b -* - DO 110 J = JFIRST, JLAST, JINC -* -* Compute x(j) = b(j) / A(j,j), scaling x if necessary. -* - XJ = ABS( X( J ) ) - IF( NOUNIT ) THEN - TJJS = A( J, J )*TSCAL - ELSE - TJJS = TSCAL - IF( TSCAL.EQ.ONE ) - $ GO TO 100 - END IF - TJJ = ABS( TJJS ) - IF( TJJ.GT.SMLNUM ) THEN -* -* abs(A(j,j)) > SMLNUM: -* - IF( TJJ.LT.ONE ) THEN - IF( XJ.GT.TJJ*BIGNUM ) THEN -* -* Scale x by 1/b(j). -* - REC = ONE / XJ - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - END IF - X( J ) = X( J ) / TJJS - XJ = ABS( X( J ) ) - ELSE IF( TJJ.GT.ZERO ) THEN -* -* 0 < abs(A(j,j)) <= SMLNUM: -* - IF( XJ.GT.TJJ*BIGNUM ) THEN -* -* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM -* to avoid overflow when dividing by A(j,j). -* - REC = ( TJJ*BIGNUM ) / XJ - IF( CNORM( J ).GT.ONE ) THEN -* -* Scale by 1/CNORM(j) to avoid overflow when -* multiplying x(j) times column j. -* - REC = REC / CNORM( J ) - END IF - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - X( J ) = X( J ) / TJJS - XJ = ABS( X( J ) ) - ELSE -* -* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and -* scale = 0, and compute a solution to A*x = 0. -* - DO 90 I = 1, N - X( I ) = ZERO - 90 CONTINUE - X( J ) = ONE - XJ = ONE - SCALE = ZERO - XMAX = ZERO - END IF - 100 CONTINUE -* -* Scale x if necessary to avoid overflow when adding a -* multiple of column j of A. -* - IF( XJ.GT.ONE ) THEN - REC = ONE / XJ - IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN -* -* Scale x by 1/(2*abs(x(j))). -* - REC = REC*HALF - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - END IF - ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN -* -* Scale x by 1/2. -* - CALL DSCAL( N, HALF, X, 1 ) - SCALE = SCALE*HALF - END IF -* - IF( UPPER ) THEN - IF( J.GT.1 ) THEN -* -* Compute the update -* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) -* - CALL DAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X, - $ 1 ) - I = IDAMAX( J-1, X, 1 ) - XMAX = ABS( X( I ) ) - END IF - ELSE - IF( J.LT.N ) THEN -* -* Compute the update -* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) -* - CALL DAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1, - $ X( J+1 ), 1 ) - I = J + IDAMAX( N-J, X( J+1 ), 1 ) - XMAX = ABS( X( I ) ) - END IF - END IF - 110 CONTINUE -* - ELSE -* -* Solve A**T * x = b -* - DO 160 J = JFIRST, JLAST, JINC -* -* Compute x(j) = b(j) - sum A(k,j)*x(k). -* k<>j -* - XJ = ABS( X( J ) ) - USCAL = TSCAL - REC = ONE / MAX( XMAX, ONE ) - IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN -* -* If x(j) could overflow, scale x by 1/(2*XMAX). -* - REC = REC*HALF - IF( NOUNIT ) THEN - TJJS = A( J, J )*TSCAL - ELSE - TJJS = TSCAL - END IF - TJJ = ABS( TJJS ) - IF( TJJ.GT.ONE ) THEN -* -* Divide by A(j,j) when scaling x if A(j,j) > 1. -* - REC = MIN( ONE, REC*TJJ ) - USCAL = USCAL / TJJS - END IF - IF( REC.LT.ONE ) THEN - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - END IF -* - SUMJ = ZERO - IF( USCAL.EQ.ONE ) THEN -* -* If the scaling needed for A in the dot product is 1, -* call DDOT to perform the dot product. -* - IF( UPPER ) THEN - SUMJ = DDOT( J-1, A( 1, J ), 1, X, 1 ) - ELSE IF( J.LT.N ) THEN - SUMJ = DDOT( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) - END IF - ELSE -* -* Otherwise, use in-line code for the dot product. -* - IF( UPPER ) THEN - DO 120 I = 1, J - 1 - SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I ) - 120 CONTINUE - ELSE IF( J.LT.N ) THEN - DO 130 I = J + 1, N - SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I ) - 130 CONTINUE - END IF - END IF -* - IF( USCAL.EQ.TSCAL ) THEN -* -* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) -* was not used to scale the dotproduct. -* - X( J ) = X( J ) - SUMJ - XJ = ABS( X( J ) ) - IF( NOUNIT ) THEN - TJJS = A( J, J )*TSCAL - ELSE - TJJS = TSCAL - IF( TSCAL.EQ.ONE ) - $ GO TO 150 - END IF -* -* Compute x(j) = x(j) / A(j,j), scaling if necessary. -* - TJJ = ABS( TJJS ) - IF( TJJ.GT.SMLNUM ) THEN -* -* abs(A(j,j)) > SMLNUM: -* - IF( TJJ.LT.ONE ) THEN - IF( XJ.GT.TJJ*BIGNUM ) THEN -* -* Scale X by 1/abs(x(j)). -* - REC = ONE / XJ - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - END IF - X( J ) = X( J ) / TJJS - ELSE IF( TJJ.GT.ZERO ) THEN -* -* 0 < abs(A(j,j)) <= SMLNUM: -* - IF( XJ.GT.TJJ*BIGNUM ) THEN -* -* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. -* - REC = ( TJJ*BIGNUM ) / XJ - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - X( J ) = X( J ) / TJJS - ELSE -* -* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and -* scale = 0, and compute a solution to A**T*x = 0. -* - DO 140 I = 1, N - X( I ) = ZERO - 140 CONTINUE - X( J ) = ONE - SCALE = ZERO - XMAX = ZERO - END IF - 150 CONTINUE - ELSE -* -* Compute x(j) := x(j) / A(j,j) - sumj if the dot -* product has already been divided by 1/A(j,j). -* - X( J ) = X( J ) / TJJS - SUMJ - END IF - XMAX = MAX( XMAX, ABS( X( J ) ) ) - 160 CONTINUE - END IF - SCALE = SCALE / TSCAL - END IF -* -* Scale the column norms by 1/TSCAL for return. -* - IF( TSCAL.NE.ONE ) THEN - CALL DSCAL( N, ONE / TSCAL, CNORM, 1 ) - END IF -* - RETURN -* -* End of DLATRS -* - END diff --git a/lib/linalg/fortran/dnrm2.f b/lib/linalg/fortran/dnrm2.f deleted file mode 100644 index 30552e1d1d..0000000000 --- a/lib/linalg/fortran/dnrm2.f +++ /dev/null @@ -1,132 +0,0 @@ -*> \brief \b DNRM2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) -* -* .. Scalar Arguments .. -* INTEGER INCX,N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION X(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DNRM2 returns the euclidean norm of a vector via the function -*> name, so that -*> -*> DNRM2 := sqrt( x'*x ) -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of DX -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date December 2016 -* -*> \ingroup double_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> -- This version written on 25-October-1982. -*> Modified on 14-October-1993 to inline the call to DLASSQ. -*> Sven Hammarling, Nag Ltd. -*> \endverbatim -*> -* ===================================================================== - DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) -* -* -- 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..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION X(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ - INTEGER IX -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS,SQRT -* .. - IF (N.LT.1 .OR. INCX.LT.1) THEN - NORM = ZERO - ELSE IF (N.EQ.1) THEN - NORM = ABS(X(1)) - ELSE - SCALE = ZERO - SSQ = ONE -* The following loop is equivalent to this call to the LAPACK -* auxiliary routine: -* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) -* - DO 10 IX = 1,1 + (N-1)*INCX,INCX - IF (X(IX).NE.ZERO) THEN - ABSXI = ABS(X(IX)) - IF (SCALE.LT.ABSXI) THEN - SSQ = ONE + SSQ* (SCALE/ABSXI)**2 - SCALE = ABSXI - ELSE - SSQ = SSQ + (ABSXI/SCALE)**2 - END IF - END IF - 10 CONTINUE - NORM = SCALE*SQRT(SSQ) - END IF -* - DNRM2 = NORM - RETURN -* -* End of DNRM2. -* - END diff --git a/lib/linalg/fortran/dorg2l.f b/lib/linalg/fortran/dorg2l.f deleted file mode 100644 index 0a42d4cf5a..0000000000 --- a/lib/linalg/fortran/dorg2l.f +++ /dev/null @@ -1,195 +0,0 @@ -*> \brief \b DORG2L generates all or part of the orthogonal matrix Q from a QL factorization determined by sgeqlf (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORG2L + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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: -* ============= -*> -*> \verbatim -*> -*> DORG2L generates an m by n real matrix Q with orthonormal columns, -*> which is defined as the last n columns of a product of k elementary -*> reflectors of order m -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by DGEQLF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. M >= N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. N >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the (n-k+i)-th column must contain the vector which -*> defines the elementary reflector H(i), for i = 1,2,...,k, as -*> returned by DGEQLF in the last k columns of its array -*> argument A. -*> On exit, the m by n matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGEQLF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (N) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, II, J, L -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORG2L', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* -* Initialise columns 1:n-k to columns of the unit matrix -* - DO 20 J = 1, N - K - DO 10 L = 1, M - A( L, J ) = ZERO - 10 CONTINUE - A( M-N+J, J ) = ONE - 20 CONTINUE -* - DO 40 I = 1, K - II = N - K + I -* -* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left -* - A( M-N+II, II ) = ONE - CALL DLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, - $ LDA, WORK ) - CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) - A( M-N+II, II ) = ONE - TAU( I ) -* -* Set A(m-k+i+1:m,n-k+i) to zero -* - DO 30 L = M - N + II + 1, M - A( L, II ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of DORG2L -* - END diff --git a/lib/linalg/fortran/dorg2r.f b/lib/linalg/fortran/dorg2r.f deleted file mode 100644 index c64ad4b0ac..0000000000 --- a/lib/linalg/fortran/dorg2r.f +++ /dev/null @@ -1,197 +0,0 @@ -*> \brief \b DORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by sgeqrf (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORG2R + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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: -* ============= -*> -*> \verbatim -*> -*> DORG2R generates an m by n real matrix Q with orthonormal columns, -*> which is defined as the first n columns of a product of k elementary -*> reflectors of order m -*> -*> Q = H(1) H(2) . . . H(k) -*> -*> as returned by DGEQRF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. M >= N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. N >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the i-th column must contain the vector which -*> defines the elementary reflector H(i), for i = 1,2,...,k, as -*> returned by DGEQRF in the first k columns of its array -*> argument A. -*> On exit, the m-by-n matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGEQRF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (N) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, L -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORG2R', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* -* Initialise columns k+1:n to columns of the unit matrix -* - DO 20 J = K + 1, N - DO 10 L = 1, M - A( L, J ) = ZERO - 10 CONTINUE - A( J, J ) = ONE - 20 CONTINUE -* - DO 40 I = K, 1, -1 -* -* Apply H(i) to A(i:m,i:n) from the left -* - IF( I.LT.N ) THEN - A( I, I ) = ONE - CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - END IF - IF( I.LT.M ) - $ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) - A( I, I ) = ONE - TAU( I ) -* -* Set A(1:i-1,i) to zero -* - DO 30 L = 1, I - 1 - A( L, I ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of DORG2R -* - END diff --git a/lib/linalg/fortran/dorgbr.f b/lib/linalg/fortran/dorgbr.f deleted file mode 100644 index 7dfd03961e..0000000000 --- a/lib/linalg/fortran/dorgbr.f +++ /dev/null @@ -1,334 +0,0 @@ -*> \brief \b DORGBR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORGBR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORGBR generates one of the real orthogonal matrices Q or P**T -*> determined by DGEBRD when reducing a real matrix A to bidiagonal -*> form: A = Q * B * P**T. Q and P**T are defined as products of -*> elementary reflectors H(i) or G(i) respectively. -*> -*> If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q -*> is of order M: -*> if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n -*> columns of Q, where m >= n >= k; -*> if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an -*> M-by-M matrix. -*> -*> If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T -*> is of order N: -*> if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m -*> rows of P**T, where n >= m >= k; -*> if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as -*> an N-by-N matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] VECT -*> \verbatim -*> VECT is CHARACTER*1 -*> Specifies whether the matrix Q or the matrix P**T is -*> required, as defined in the transformation applied by DGEBRD: -*> = 'Q': generate Q; -*> = 'P': generate P**T. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q or P**T to be returned. -*> M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q or P**T to be returned. -*> N >= 0. -*> If VECT = 'Q', M >= N >= min(M,K); -*> if VECT = 'P', N >= M >= min(N,K). -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> If VECT = 'Q', the number of columns in the original M-by-K -*> matrix reduced by DGEBRD. -*> If VECT = 'P', the number of rows in the original K-by-N -*> matrix reduced by DGEBRD. -*> K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the vectors which define the elementary reflectors, -*> as returned by DGEBRD. -*> On exit, the M-by-N matrix Q or P**T. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension -*> (min(M,K)) if VECT = 'Q' -*> (min(N,K)) if VECT = 'P' -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i) or G(i), which determines Q or P**T, as -*> returned by DGEBRD in its array argument TAUQ or TAUP. -*> \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 >= max(1,min(M,N)). -*> For optimum performance LWORK >= min(M,N)*NB, where NB -*> is the optimal blocksize. -*> -*> 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 -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGBcomputational -* -* ===================================================================== - SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER VECT - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, WANTQ - INTEGER I, IINFO, J, LWKOPT, MN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DORGLQ, DORGQR, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - WANTQ = LSAME( VECT, 'Q' ) - MN = MIN( M, N ) - LQUERY = ( LWORK.EQ.-1 ) - IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M, - $ K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT. - $ MIN( N, K ) ) ) ) THEN - INFO = -3 - ELSE IF( K.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN - INFO = -9 - END IF -* - IF( INFO.EQ.0 ) THEN - WORK( 1 ) = 1 - IF( WANTQ ) THEN - IF( M.GE.K ) THEN - CALL DORGQR( M, N, K, A, LDA, TAU, WORK, -1, IINFO ) - ELSE - IF( M.GT.1 ) THEN - CALL DORGQR( M-1, M-1, M-1, A, LDA, TAU, WORK, -1, - $ IINFO ) - END IF - END IF - ELSE - IF( K.LT.N ) THEN - CALL DORGLQ( M, N, K, A, LDA, TAU, WORK, -1, IINFO ) - ELSE - IF( N.GT.1 ) THEN - CALL DORGLQ( N-1, N-1, N-1, A, LDA, TAU, WORK, -1, - $ IINFO ) - END IF - END IF - END IF - LWKOPT = INT( WORK( 1 ) ) - LWKOPT = MAX (LWKOPT, MN) - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGBR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - WORK( 1 ) = LWKOPT - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( WANTQ ) THEN -* -* Form Q, determined by a call to DGEBRD to reduce an m-by-k -* matrix -* - IF( M.GE.K ) THEN -* -* If m >= k, assume m >= n >= k -* - CALL DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) -* - ELSE -* -* If m < k, assume m = n -* -* Shift the vectors which define the elementary reflectors one -* column to the right, and set the first row and column of Q -* to those of the unit matrix -* - DO 20 J = M, 2, -1 - A( 1, J ) = ZERO - DO 10 I = J + 1, M - A( I, J ) = A( I, J-1 ) - 10 CONTINUE - 20 CONTINUE - A( 1, 1 ) = ONE - DO 30 I = 2, M - A( I, 1 ) = ZERO - 30 CONTINUE - IF( M.GT.1 ) THEN -* -* Form Q(2:m,2:m) -* - CALL DORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK, - $ LWORK, IINFO ) - END IF - END IF - ELSE -* -* Form P**T, determined by a call to DGEBRD to reduce a k-by-n -* matrix -* - IF( K.LT.N ) THEN -* -* If k < n, assume k <= m <= n -* - CALL DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) -* - ELSE -* -* If k >= n, assume m = n -* -* Shift the vectors which define the elementary reflectors one -* row downward, and set the first row and column of P**T to -* those of the unit matrix -* - A( 1, 1 ) = ONE - DO 40 I = 2, N - A( I, 1 ) = ZERO - 40 CONTINUE - DO 60 J = 2, N - DO 50 I = J - 1, 2, -1 - A( I, J ) = A( I-1, J ) - 50 CONTINUE - A( 1, J ) = ZERO - 60 CONTINUE - IF( N.GT.1 ) THEN -* -* Form P**T(2:n,2:n) -* - CALL DORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, - $ LWORK, IINFO ) - END IF - END IF - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORGBR -* - END diff --git a/lib/linalg/fortran/dorgl2.f b/lib/linalg/fortran/dorgl2.f deleted file mode 100644 index ce1d2c6750..0000000000 --- a/lib/linalg/fortran/dorgl2.f +++ /dev/null @@ -1,201 +0,0 @@ -*> \brief \b DORGL2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORGL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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: -* ============= -*> -*> \verbatim -*> -*> DORGL2 generates an m by n real matrix Q with orthonormal rows, -*> which is defined as the first m rows of a product of k elementary -*> reflectors of order n -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by DGELQF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. N >= M. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. M >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the i-th row must contain the vector which defines -*> the elementary reflector H(i), for i = 1,2,...,k, as returned -*> by DGELQF in the first k rows of its array argument A. -*> On exit, the m-by-n matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGELQF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (M) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, L -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.M ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGL2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 ) - $ RETURN -* - IF( K.LT.M ) THEN -* -* Initialise rows k+1:m to rows of the unit matrix -* - DO 20 J = 1, N - DO 10 L = K + 1, M - A( L, J ) = ZERO - 10 CONTINUE - IF( J.GT.K .AND. J.LE.M ) - $ A( J, J ) = ONE - 20 CONTINUE - END IF -* - DO 40 I = K, 1, -1 -* -* Apply H(i) to A(i:m,i:n) from the right -* - IF( I.LT.N ) THEN - IF( I.LT.M ) THEN - A( I, I ) = ONE - CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ TAU( I ), A( I+1, I ), LDA, WORK ) - END IF - CALL DSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) - END IF - A( I, I ) = ONE - TAU( I ) -* -* Set A(i,1:i-1) to zero -* - DO 30 L = 1, I - 1 - A( I, L ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of DORGL2 -* - END diff --git a/lib/linalg/fortran/dorglq.f b/lib/linalg/fortran/dorglq.f deleted file mode 100644 index 8c37c18b75..0000000000 --- a/lib/linalg/fortran/dorglq.f +++ /dev/null @@ -1,286 +0,0 @@ -*> \brief \b DORGLQ -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORGLQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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: -* ============= -*> -*> \verbatim -*> -*> DORGLQ generates an M-by-N real matrix Q with orthonormal rows, -*> which is defined as the first M rows of a product of K elementary -*> reflectors of order N -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by DGELQF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. N >= M. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. M >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the i-th row must contain the vector which defines -*> the elementary reflector H(i), for i = 1,2,...,k, as returned -*> by DGELQF in the first k rows of its array argument A. -*> On exit, the M-by-N matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGELQF. -*> \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 >= max(1,M). -*> For optimum performance LWORK >= M*NB, where NB is -*> the optimal blocksize. -*> -*> 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 has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, - $ LWKOPT, NB, NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORGL2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 ) - LWKOPT = MAX( 1, M )*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.M ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGLQ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = M - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DORGLQ', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = M - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORGLQ', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the last block. -* The first kk rows are handled by the block method. -* - KI = ( ( K-NX-1 ) / NB )*NB - KK = MIN( K, KI+NB ) -* -* Set A(kk+1:m,1:kk) to zero. -* - DO 20 J = 1, KK - DO 10 I = KK + 1, M - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the last or only block. -* - IF( KK.LT.M ) - $ CALL DORGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, - $ TAU( KK+1 ), WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF( I+IB.LE.M ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), - $ LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H**T to A(i+ib:m,i:n) from the right -* - CALL DLARFB( 'Right', 'Transpose', 'Forward', 'Rowwise', - $ M-I-IB+1, N-I+1, IB, A( I, I ), LDA, WORK, - $ LDWORK, A( I+IB, I ), LDA, WORK( IB+1 ), - $ LDWORK ) - END IF -* -* Apply H**T to columns i:n of current block -* - CALL DORGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* -* Set columns 1:i-1 of current block to zero -* - DO 40 J = 1, I - 1 - DO 30 L = I, I + IB - 1 - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of DORGLQ -* - END diff --git a/lib/linalg/fortran/dorgql.f b/lib/linalg/fortran/dorgql.f deleted file mode 100644 index 45e5bf19f1..0000000000 --- a/lib/linalg/fortran/dorgql.f +++ /dev/null @@ -1,293 +0,0 @@ -*> \brief \b DORGQL -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORGQL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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: -* ============= -*> -*> \verbatim -*> -*> DORGQL generates an M-by-N real matrix Q with orthonormal columns, -*> which is defined as the last N columns of a product of K elementary -*> reflectors of order M -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by DGEQLF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. M >= N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. N >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the (n-k+i)-th column must contain the vector which -*> defines the elementary reflector H(i), for i = 1,2,...,k, as -*> returned by DGEQLF in the last k columns of its array -*> argument A. -*> On exit, the M-by-N matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGEQLF. -*> \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 >= max(1,N). -*> For optimum performance LWORK >= N*NB, where NB is the -*> optimal blocksize. -*> -*> 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 has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT, - $ NB, NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORG2L, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( N.EQ.0 ) THEN - LWKOPT = 1 - ELSE - NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 ) - LWKOPT = N*NB - END IF - WORK( 1 ) = LWKOPT -* - IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGQL', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) THEN - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DORGQL', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORGQL', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the first block. -* The last kk columns are handled by the block method. -* - KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) -* -* Set A(m-kk+1:m,1:n-kk) to zero. -* - DO 20 J = 1, N - KK - DO 10 I = M - KK + 1, M - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the first or only block. -* - CALL DORG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = K - KK + 1, K, NB - IB = MIN( NB, K-I+1 ) - IF( N-K+I.GT.1 ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i+ib-1) . . . H(i+1) H(i) -* - CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, - $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left -* - CALL DLARFB( 'Left', 'No transpose', 'Backward', - $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB, - $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, - $ WORK( IB+1 ), LDWORK ) - END IF -* -* Apply H to rows 1:m-k+i+ib-1 of current block -* - CALL DORG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA, - $ TAU( I ), WORK, IINFO ) -* -* Set rows m-k+i+ib:m of current block to zero -* - DO 40 J = N - K + I, N - K + I + IB - 1 - DO 30 L = M - K + I + IB, M - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of DORGQL -* - END diff --git a/lib/linalg/fortran/dorgqr.f b/lib/linalg/fortran/dorgqr.f deleted file mode 100644 index a41ce7ed56..0000000000 --- a/lib/linalg/fortran/dorgqr.f +++ /dev/null @@ -1,287 +0,0 @@ -*> \brief \b DORGQR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORGQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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: -* ============= -*> -*> \verbatim -*> -*> DORGQR generates an M-by-N real matrix Q with orthonormal columns, -*> which is defined as the first N columns of a product of K elementary -*> reflectors of order M -*> -*> Q = H(1) H(2) . . . H(k) -*> -*> as returned by DGEQRF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. M >= N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. N >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the i-th column must contain the vector which -*> defines the elementary reflector H(i), for i = 1,2,...,k, as -*> returned by DGEQRF in the first k columns of its array -*> argument A. -*> On exit, the M-by-N matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGEQRF. -*> \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 >= max(1,N). -*> For optimum performance LWORK >= N*NB, where NB is the -*> optimal blocksize. -*> -*> 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 has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, - $ LWKOPT, NB, NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) - LWKOPT = MAX( 1, N )*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGQR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the last block. -* The first kk columns are handled by the block method. -* - KI = ( ( K-NX-1 ) / NB )*NB - KK = MIN( K, KI+NB ) -* -* Set A(1:kk,kk+1:n) to zero. -* - DO 20 J = KK + 1, N - DO 10 I = 1, KK - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the last or only block. -* - IF( KK.LT.N ) - $ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, - $ TAU( KK+1 ), WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF( I+IB.LE.N ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(i:m,i+ib:n) from the left -* - CALL DLARFB( 'Left', 'No transpose', 'Forward', - $ 'Columnwise', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), - $ LDA, WORK( IB+1 ), LDWORK ) - END IF -* -* Apply H to rows i:m of current block -* - CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* -* Set rows 1:i-1 of current block to zero -* - DO 40 J = I, I + IB - 1 - DO 30 L = 1, I - 1 - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of DORGQR -* - END diff --git a/lib/linalg/fortran/dorgtr.f b/lib/linalg/fortran/dorgtr.f deleted file mode 100644 index 0a0ab15a78..0000000000 --- a/lib/linalg/fortran/dorgtr.f +++ /dev/null @@ -1,252 +0,0 @@ -*> \brief \b DORGTR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORGTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORGTR generates a real orthogonal matrix Q which is defined as the -*> product of n-1 elementary reflectors of order N, as returned by -*> DSYTRD: -*> -*> if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), -*> -*> if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A contains elementary reflectors -*> from DSYTRD; -*> = 'L': Lower triangle of A contains elementary reflectors -*> from DSYTRD. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix Q. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the vectors which define the elementary reflectors, -*> as returned by DSYTRD. -*> On exit, the N-by-N orthogonal matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (N-1) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DSYTRD. -*> \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 >= max(1,N-1). -*> For optimum performance LWORK >= (N-1)*NB, where NB is -*> the optimal blocksize. -*> -*> 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 -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, UPPER - INTEGER I, IINFO, J, LWKOPT, NB -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DORGQL, DORGQR, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN - INFO = -7 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( UPPER ) THEN - NB = ILAENV( 1, 'DORGQL', ' ', N-1, N-1, N-1, -1 ) - ELSE - NB = ILAENV( 1, 'DORGQR', ' ', N-1, N-1, N-1, -1 ) - END IF - LWKOPT = MAX( 1, N-1 )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGTR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( UPPER ) THEN -* -* Q was determined by a call to DSYTRD with UPLO = 'U' -* -* Shift the vectors which define the elementary reflectors one -* column to the left, and set the last row and column of Q to -* those of the unit matrix -* - DO 20 J = 1, N - 1 - DO 10 I = 1, J - 1 - A( I, J ) = A( I, J+1 ) - 10 CONTINUE - A( N, J ) = ZERO - 20 CONTINUE - DO 30 I = 1, N - 1 - A( I, N ) = ZERO - 30 CONTINUE - A( N, N ) = ONE -* -* Generate Q(1:n-1,1:n-1) -* - CALL DORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO ) -* - ELSE -* -* Q was determined by a call to DSYTRD with UPLO = 'L'. -* -* Shift the vectors which define the elementary reflectors one -* column to the right, and set the first row and column of Q to -* those of the unit matrix -* - DO 50 J = N, 2, -1 - A( 1, J ) = ZERO - DO 40 I = J + 1, N - A( I, J ) = A( I, J-1 ) - 40 CONTINUE - 50 CONTINUE - A( 1, 1 ) = ONE - DO 60 I = 2, N - A( I, 1 ) = ZERO - 60 CONTINUE - IF( N.GT.1 ) THEN -* -* Generate Q(2:n,2:n) -* - CALL DORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, - $ LWORK, IINFO ) - END IF - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORGTR -* - END diff --git a/lib/linalg/fortran/dorm2l.f b/lib/linalg/fortran/dorm2l.f deleted file mode 100644 index c99039c541..0000000000 --- a/lib/linalg/fortran/dorm2l.f +++ /dev/null @@ -1,275 +0,0 @@ -*> \brief \b DORM2L multiplies a general matrix by the orthogonal matrix from a QL factorization determined by sgeqlf (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORM2L + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORM2L overwrites the general real m by n matrix C with -*> -*> Q * C if SIDE = 'L' and TRANS = 'N', or -*> -*> Q**T * C if SIDE = 'L' and TRANS = 'T', or -*> -*> C * Q if SIDE = 'R' and TRANS = 'N', or -*> -*> C * Q**T if SIDE = 'R' and TRANS = 'T', -*> -*> where Q is a real orthogonal matrix defined as the product of k -*> elementary reflectors -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n -*> if SIDE = 'R'. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**T from the Left -*> = 'R': apply Q or Q**T from the Right -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': apply Q (No transpose) -*> = 'T': apply Q**T (Transpose) -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines -*> the matrix Q. -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,K) -*> The i-th column must contain the vector which defines the -*> elementary reflector H(i), for i = 1,2,...,k, as returned by -*> DGEQLF in the last k columns of its array argument A. -*> A is modified by the routine but restored on exit. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> If SIDE = 'L', LDA >= max(1,M); -*> if SIDE = 'R', LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGEQLF. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) -*> On entry, the m by n matrix C. -*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension -*> (N) if SIDE = 'L', -*> (M) if SIDE = 'R' -*> \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. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, MI, NI, NQ - DOUBLE PRECISION AII -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLARF, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORM2L', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) - $ THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - ELSE - MI = M - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) is applied to C(1:m-k+i,1:n) -* - MI = M - K + I - ELSE -* -* H(i) is applied to C(1:m,1:n-k+i) -* - NI = N - K + I - END IF -* -* Apply H(i) -* - AII = A( NQ-K+I, I ) - A( NQ-K+I, I ) = ONE - CALL DLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC, - $ WORK ) - A( NQ-K+I, I ) = AII - 10 CONTINUE - RETURN -* -* End of DORM2L -* - END diff --git a/lib/linalg/fortran/dorm2r.f b/lib/linalg/fortran/dorm2r.f deleted file mode 100644 index ac88eec8dc..0000000000 --- a/lib/linalg/fortran/dorm2r.f +++ /dev/null @@ -1,279 +0,0 @@ -*> \brief \b DORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sgeqrf (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORM2R + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORM2R overwrites the general real m by n matrix C with -*> -*> Q * C if SIDE = 'L' and TRANS = 'N', or -*> -*> Q**T* C if SIDE = 'L' and TRANS = 'T', or -*> -*> C * Q if SIDE = 'R' and TRANS = 'N', or -*> -*> C * Q**T if SIDE = 'R' and TRANS = 'T', -*> -*> where Q is a real orthogonal matrix defined as the product of k -*> elementary reflectors -*> -*> Q = H(1) H(2) . . . H(k) -*> -*> as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n -*> if SIDE = 'R'. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**T from the Left -*> = 'R': apply Q or Q**T from the Right -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': apply Q (No transpose) -*> = 'T': apply Q**T (Transpose) -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines -*> the matrix Q. -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,K) -*> The i-th column must contain the vector which defines the -*> elementary reflector H(i), for i = 1,2,...,k, as returned by -*> DGEQRF in the first k columns of its array argument A. -*> A is modified by the routine but restored on exit. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> If SIDE = 'L', LDA >= max(1,M); -*> if SIDE = 'R', LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGEQRF. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) -*> On entry, the m by n matrix C. -*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension -*> (N) if SIDE = 'L', -*> (M) if SIDE = 'R' -*> \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. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - DOUBLE PRECISION AII -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLARF, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORM2R', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) - $ THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H(i) is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H(i) -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), - $ LDC, WORK ) - A( I, I ) = AII - 10 CONTINUE - RETURN -* -* End of DORM2R -* - END diff --git a/lib/linalg/fortran/dormbr.f b/lib/linalg/fortran/dormbr.f deleted file mode 100644 index 86abb10072..0000000000 --- a/lib/linalg/fortran/dormbr.f +++ /dev/null @@ -1,369 +0,0 @@ -*> \brief \b DORMBR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORMBR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C -*> with -*> SIDE = 'L' SIDE = 'R' -*> TRANS = 'N': Q * C C * Q -*> TRANS = 'T': Q**T * C C * Q**T -*> -*> If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C -*> with -*> SIDE = 'L' SIDE = 'R' -*> TRANS = 'N': P * C C * P -*> TRANS = 'T': P**T * C C * P**T -*> -*> Here Q and P**T are the orthogonal matrices determined by DGEBRD when -*> reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and -*> P**T are defined as products of elementary reflectors H(i) and G(i) -*> respectively. -*> -*> Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the -*> order of the orthogonal matrix Q or P**T that is applied. -*> -*> If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: -*> if nq >= k, Q = H(1) H(2) . . . H(k); -*> if nq < k, Q = H(1) H(2) . . . H(nq-1). -*> -*> If VECT = 'P', A is assumed to have been a K-by-NQ matrix: -*> if k < nq, P = G(1) G(2) . . . G(k); -*> if k >= nq, P = G(1) G(2) . . . G(nq-1). -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] VECT -*> \verbatim -*> VECT is CHARACTER*1 -*> = 'Q': apply Q or Q**T; -*> = 'P': apply P or P**T. -*> \endverbatim -*> -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q, Q**T, P or P**T from the Left; -*> = 'R': apply Q, Q**T, P or P**T from the Right. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': No transpose, apply Q or P; -*> = 'T': Transpose, apply Q**T or P**T. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> If VECT = 'Q', the number of columns in the original -*> matrix reduced by DGEBRD. -*> If VECT = 'P', the number of rows in the original -*> matrix reduced by DGEBRD. -*> K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension -*> (LDA,min(nq,K)) if VECT = 'Q' -*> (LDA,nq) if VECT = 'P' -*> The vectors which define the elementary reflectors H(i) and -*> G(i), whose products determine the matrices Q and P, as -*> returned by DGEBRD. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> If VECT = 'Q', LDA >= max(1,nq); -*> if VECT = 'P', LDA >= max(1,min(nq,K)). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (min(nq,K)) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i) or G(i) which determines Q or P, as returned -*> by DGEBRD in the array argument TAUQ or TAUP. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) -*> On entry, the M-by-N matrix C. -*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q -*> or P*C or P**T*C or C*P or C*P**T. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (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. -*> 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. -*> -*> 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 -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, - $ LDC, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS, VECT - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN - CHARACTER TRANST - INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DORMLQ, DORMQR, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - APPLYQ = LSAME( VECT, 'Q' ) - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q or P and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = MAX( 1, N ) - ELSE - NQ = N - NW = MAX( 1, M ) - END IF - IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -2 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( K.LT.0 ) THEN - INFO = -6 - ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR. - $ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) ) - $ THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -11 - ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( APPLYQ ) THEN - IF( LEFT ) THEN - NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1, - $ -1 ) - ELSE - NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1, - $ -1 ) - END IF - ELSE - IF( LEFT ) THEN - NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M-1, N, M-1, - $ -1 ) - ELSE - NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N-1, N-1, - $ -1 ) - END IF - END IF - LWKOPT = NW*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMBR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - WORK( 1 ) = 1 - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* - IF( APPLYQ ) THEN -* -* Apply Q -* - IF( NQ.GE.K ) THEN -* -* Q was determined by a call to DGEBRD with nq >= k -* - CALL DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, IINFO ) - ELSE IF( NQ.GT.1 ) THEN -* -* Q was determined by a call to DGEBRD with nq < k -* - IF( LEFT ) THEN - MI = M - 1 - NI = N - I1 = 2 - I2 = 1 - ELSE - MI = M - NI = N - 1 - I1 = 1 - I2 = 2 - END IF - CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, - $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) - END IF - ELSE -* -* Apply P -* - IF( NOTRAN ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF - IF( NQ.GT.K ) THEN -* -* P was determined by a call to DGEBRD with nq > k -* - CALL DORMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, IINFO ) - ELSE IF( NQ.GT.1 ) THEN -* -* P was determined by a call to DGEBRD with nq <= k -* - IF( LEFT ) THEN - MI = M - 1 - NI = N - I1 = 2 - I2 = 1 - ELSE - MI = M - NI = N - 1 - I1 = 1 - I2 = 2 - END IF - CALL DORMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA, - $ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO ) - END IF - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMBR -* - END diff --git a/lib/linalg/fortran/dorml2.f b/lib/linalg/fortran/dorml2.f deleted file mode 100644 index a9ddd460d8..0000000000 --- a/lib/linalg/fortran/dorml2.f +++ /dev/null @@ -1,279 +0,0 @@ -*> \brief \b DORML2 multiplies a general matrix by the orthogonal matrix from a LQ factorization determined by sgelqf (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORML2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORML2 overwrites the general real m by n matrix C with -*> -*> Q * C if SIDE = 'L' and TRANS = 'N', or -*> -*> Q**T* C if SIDE = 'L' and TRANS = 'T', or -*> -*> C * Q if SIDE = 'R' and TRANS = 'N', or -*> -*> C * Q**T if SIDE = 'R' and TRANS = 'T', -*> -*> where Q is a real orthogonal matrix defined as the product of k -*> elementary reflectors -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n -*> if SIDE = 'R'. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**T from the Left -*> = 'R': apply Q or Q**T from the Right -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': apply Q (No transpose) -*> = 'T': apply Q**T (Transpose) -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines -*> the matrix Q. -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension -*> (LDA,M) if SIDE = 'L', -*> (LDA,N) if SIDE = 'R' -*> The i-th row must contain the vector which defines the -*> elementary reflector H(i), for i = 1,2,...,k, as returned by -*> DGELQF in the first k rows of its array argument A. -*> A is modified by the routine but restored on exit. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,K). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGELQF. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) -*> On entry, the m by n matrix C. -*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension -*> (N) if SIDE = 'L', -*> (M) if SIDE = 'R' -*> \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. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - DOUBLE PRECISION AII -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLARF, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, K ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORML2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) - $ THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H(i) is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H(i) -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, MI, NI, A( I, I ), LDA, TAU( I ), - $ C( IC, JC ), LDC, WORK ) - A( I, I ) = AII - 10 CONTINUE - RETURN -* -* End of DORML2 -* - END diff --git a/lib/linalg/fortran/dormlq.f b/lib/linalg/fortran/dormlq.f deleted file mode 100644 index ef039285ab..0000000000 --- a/lib/linalg/fortran/dormlq.f +++ /dev/null @@ -1,344 +0,0 @@ -*> \brief \b DORMLQ -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORMLQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORMLQ overwrites the general real M-by-N matrix C with -*> -*> SIDE = 'L' SIDE = 'R' -*> TRANS = 'N': Q * C C * Q -*> TRANS = 'T': Q**T * C C * Q**T -*> -*> where Q is a real orthogonal matrix defined as the product of k -*> elementary reflectors -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N -*> if SIDE = 'R'. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**T from the Left; -*> = 'R': apply Q or Q**T from the Right. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': No transpose, apply Q; -*> = 'T': Transpose, apply Q**T. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines -*> the matrix Q. -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension -*> (LDA,M) if SIDE = 'L', -*> (LDA,N) if SIDE = 'R' -*> The i-th row must contain the vector which defines the -*> elementary reflector H(i), for i = 1,2,...,k, as returned by -*> DGELQF in the first k rows of its array argument A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,K). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGELQF. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) -*> On entry, the M-by-N matrix C. -*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (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. -*> If SIDE = 'L', LWORK >= max(1,N); -*> if SIDE = 'R', LWORK >= max(1,M). -*> 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 -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - 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, IWT, JC, LDWORK, - $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORML2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = MAX( 1, N ) - ELSE - NQ = N - NW = MAX( 1, M ) - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, K ) ) THEN - 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 -* - NB = MIN( NBMAX, ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N, K, - $ -1 ) ) - LWKOPT = NW*NB + TSIZE - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMLQ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IF( LWORK.LT.LWKOPT ) THEN - NB = (LWORK-TSIZE) / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORMLQ', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IWT = 1 + NW*NB - IF( ( LEFT .AND. NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - IF( NOTRAN ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ), - $ LDA, TAU( I ), WORK( IWT ), LDT ) - IF( LEFT ) THEN -* -* H or H**T is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H or H**T is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H or H**T -* - CALL DLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB, - $ A( I, I ), LDA, WORK( IWT ), LDT, - $ C( IC, JC ), LDC, WORK, LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMLQ -* - END diff --git a/lib/linalg/fortran/dormql.f b/lib/linalg/fortran/dormql.f deleted file mode 100644 index 7c9f189e0d..0000000000 --- a/lib/linalg/fortran/dormql.f +++ /dev/null @@ -1,336 +0,0 @@ -*> \brief \b DORMQL -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORMQL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORMQL overwrites the general real M-by-N matrix C with -*> -*> SIDE = 'L' SIDE = 'R' -*> TRANS = 'N': Q * C C * Q -*> TRANS = 'T': Q**T * C C * Q**T -*> -*> where Q is a real orthogonal matrix defined as the product of k -*> elementary reflectors -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by DGEQLF. Q is of order M if SIDE = 'L' and of order N -*> if SIDE = 'R'. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**T from the Left; -*> = 'R': apply Q or Q**T from the Right. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': No transpose, apply Q; -*> = 'T': Transpose, apply Q**T. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines -*> the matrix Q. -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,K) -*> The i-th column must contain the vector which defines the -*> elementary reflector H(i), for i = 1,2,...,k, as returned by -*> DGEQLF in the last k columns of its array argument A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> If SIDE = 'L', LDA >= max(1,M); -*> if SIDE = 'R', LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGEQLF. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) -*> On entry, the M-by-N matrix C. -*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (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. -*> If SIDE = 'L', LWORK >= max(1,N); -*> if SIDE = 'R', LWORK >= max(1,M). -*> 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 -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - 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, IWT, LDWORK, LWKOPT, - $ MI, NB, NBMIN, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORM2L, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = MAX( 1, N ) - ELSE - NQ = N - NW = MAX( 1, M ) - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - 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 - NB = MIN( NBMAX, ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N, - $ K, -1 ) ) - LWKOPT = NW*NB + TSIZE - END IF - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMQL', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - RETURN - END IF -* - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IF( LWORK.LT.LWKOPT ) THEN - NB = (LWORK-TSIZE) / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORMQL', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IWT = 1 + NW*NB - IF( ( LEFT .AND. NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - ELSE - MI = M - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* 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 ), WORK( IWT ), LDT ) - IF( LEFT ) THEN -* -* H or H**T is applied to C(1:m-k+i+ib-1,1:n) -* - MI = M - K + I + IB - 1 - ELSE -* -* H or H**T is applied to C(1:m,1:n-k+i+ib-1) -* - NI = N - K + I + IB - 1 - END IF -* -* Apply H or H**T -* - CALL DLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI, - $ IB, A( 1, I ), LDA, WORK( IWT ), LDT, C, LDC, - $ WORK, LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMQL -* - END diff --git a/lib/linalg/fortran/dormqr.f b/lib/linalg/fortran/dormqr.f deleted file mode 100644 index 4d0bae3a5f..0000000000 --- a/lib/linalg/fortran/dormqr.f +++ /dev/null @@ -1,337 +0,0 @@ -*> \brief \b DORMQR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORMQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORMQR overwrites the general real M-by-N matrix C with -*> -*> SIDE = 'L' SIDE = 'R' -*> TRANS = 'N': Q * C C * Q -*> TRANS = 'T': Q**T * C C * Q**T -*> -*> where Q is a real orthogonal matrix defined as the product of k -*> elementary reflectors -*> -*> Q = H(1) H(2) . . . H(k) -*> -*> as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N -*> if SIDE = 'R'. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**T from the Left; -*> = 'R': apply Q or Q**T from the Right. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': No transpose, apply Q; -*> = 'T': Transpose, apply Q**T. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines -*> the matrix Q. -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,K) -*> The i-th column must contain the vector which defines the -*> elementary reflector H(i), for i = 1,2,...,k, as returned by -*> DGEQRF in the first k columns of its array argument A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> If SIDE = 'L', LDA >= max(1,M); -*> if SIDE = 'R', LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGEQRF. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) -*> On entry, the M-by-N matrix C. -*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (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. -*> If SIDE = 'L', LWORK >= max(1,N); -*> if SIDE = 'R', LWORK >= max(1,M). -*> 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 -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - 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, IWT, JC, LDWORK, - $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = MAX( 1, N ) - ELSE - NQ = N - NW = MAX( 1, M ) - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - 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 -* - NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - LWKOPT = NW*NB + TSIZE - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMQR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IF( LWORK.LT.LWKOPT ) THEN - NB = (LWORK-TSIZE) / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IWT = 1 + NW*NB - IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), - $ LDA, TAU( I ), WORK( IWT ), LDT ) - IF( LEFT ) THEN -* -* H or H**T is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H or H**T is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H or H**T -* - CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, - $ IB, A( I, I ), LDA, WORK( IWT ), LDT, - $ C( IC, JC ), LDC, WORK, LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMQR -* - END diff --git a/lib/linalg/fortran/dormtr.f b/lib/linalg/fortran/dormtr.f deleted file mode 100644 index 1f664d63cc..0000000000 --- a/lib/linalg/fortran/dormtr.f +++ /dev/null @@ -1,307 +0,0 @@ -*> \brief \b DORMTR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORMTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORMTR overwrites the general real M-by-N matrix C with -*> -*> SIDE = 'L' SIDE = 'R' -*> TRANS = 'N': Q * C C * Q -*> TRANS = 'T': Q**T * C C * Q**T -*> -*> where Q is a real orthogonal matrix of order nq, with nq = m if -*> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of -*> nq-1 elementary reflectors, as returned by DSYTRD: -*> -*> if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); -*> -*> if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**T from the Left; -*> = 'R': apply Q or Q**T from the Right. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A contains elementary reflectors -*> from DSYTRD; -*> = 'L': Lower triangle of A contains elementary reflectors -*> from DSYTRD. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': No transpose, apply Q; -*> = 'T': Transpose, apply Q**T. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension -*> (LDA,M) if SIDE = 'L' -*> (LDA,N) if SIDE = 'R' -*> The vectors which define the elementary reflectors, as -*> returned by DSYTRD. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension -*> (M-1) if SIDE = 'L' -*> (N-1) if SIDE = 'R' -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DSYTRD. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) -*> On entry, the M-by-N matrix C. -*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (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. -*> 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. -*> -*> 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 -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS, UPLO - INTEGER INFO, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, UPPER - INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DORMQL, DORMQR, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - UPPER = LSAME( UPLO, 'U' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = MAX( 1, N ) - ELSE - NQ = N - NW = MAX( 1, M ) - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) - $ THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - 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 - IF( UPPER ) THEN - IF( LEFT ) THEN - NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M-1, N, M-1, - $ -1 ) - ELSE - NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N-1, N-1, - $ -1 ) - END IF - ELSE - IF( LEFT ) THEN - NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1, - $ -1 ) - ELSE - NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1, - $ -1 ) - END IF - END IF - LWKOPT = NW*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMTR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( LEFT ) THEN - MI = M - 1 - NI = N - ELSE - MI = M - NI = N - 1 - END IF -* - IF( UPPER ) THEN -* -* Q was determined by a call to DSYTRD with UPLO = 'U' -* - CALL DORMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C, - $ LDC, WORK, LWORK, IINFO ) - ELSE -* -* Q was determined by a call to DSYTRD with UPLO = 'L' -* - IF( LEFT ) THEN - I1 = 2 - I2 = 1 - ELSE - I1 = 1 - I2 = 2 - END IF - CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, - $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMTR -* - END diff --git a/lib/linalg/fortran/dposv.f b/lib/linalg/fortran/dposv.f deleted file mode 100644 index ee2988e6fd..0000000000 --- a/lib/linalg/fortran/dposv.f +++ /dev/null @@ -1,190 +0,0 @@ -*> \brief DPOSV computes the solution to system of linear equations A * X = B for PO matrices -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DPOSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DPOSV computes the solution to a real system of linear equations -*> A * X = B, -*> where A is an N-by-N symmetric positive definite matrix and X and B -*> are N-by-NRHS matrices. -*> -*> The Cholesky decomposition is used to factor A as -*> A = U**T* U, if UPLO = 'U', or -*> A = L * L**T, if UPLO = 'L', -*> where U is an upper triangular matrix and L is a lower triangular -*> matrix. The factored form of A is then used to solve the system of -*> equations A * X = B. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of linear equations, i.e., the order 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 matrix B. NRHS >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the leading -*> N-by-N upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading N-by-N lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> -*> On exit, if INFO = 0, the factor U or L from the Cholesky -*> factorization A = U**T*U or A = L*L**T. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) -*> On entry, the N-by-NRHS right hand side matrix B. -*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,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 = i, the leading minor of order i of A is not -*> positive definite, so the factorization could not be -*> completed, and the solution has not been computed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doublePOsolve -* -* ===================================================================== - SUBROUTINE DPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) -* -* -- LAPACK driver routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DPOTRF, DPOTRS, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOSV ', -INFO ) - RETURN - END IF -* -* Compute the Cholesky factorization A = U**T*U or A = L*L**T. -* - CALL DPOTRF( UPLO, N, A, LDA, INFO ) - IF( INFO.EQ.0 ) THEN -* -* Solve the system A*X = B, overwriting B with X. -* - CALL DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) -* - END IF - RETURN -* -* End of DPOSV -* - END diff --git a/lib/linalg/fortran/dpotf2.f b/lib/linalg/fortran/dpotf2.f deleted file mode 100644 index 08fa4957fd..0000000000 --- a/lib/linalg/fortran/dpotf2.f +++ /dev/null @@ -1,227 +0,0 @@ -*> \brief \b DPOTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite matrix (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DPOTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DPOTF2 computes the Cholesky factorization of a real symmetric -*> positive definite matrix A. -*> -*> The factorization has the form -*> A = U**T * U , if UPLO = 'U', or -*> A = L * L**T, if UPLO = 'L', -*> where U is an upper triangular matrix and L is lower triangular. -*> -*> This is the unblocked version of the algorithm, calling Level 2 BLAS. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies whether the upper or lower triangular part of the -*> symmetric matrix A is stored. -*> = 'U': Upper triangular -*> = 'L': Lower triangular -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the leading -*> n by n upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading n by n lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> -*> On exit, if INFO = 0, the factor U or L from the Cholesky -*> factorization A = U**T *U or A = L*L**T. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -k, the k-th argument had an illegal value -*> > 0: if INFO = k, the leading minor of order k is not -*> positive definite, and the factorization could not be -*> completed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doublePOcomputational -* -* ===================================================================== - SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J - DOUBLE PRECISION AJJ -* .. -* .. External Functions .. - LOGICAL LSAME, DISNAN - DOUBLE PRECISION DDOT - EXTERNAL LSAME, DDOT, DISNAN -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U**T *U. -* - DO 10 J = 1, N -* -* Compute U(J,J) and test for non-positive-definiteness. -* - AJJ = A( J, J ) - DDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 ) - IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of row J. -* - IF( J.LT.N ) THEN - CALL DGEMV( 'Transpose', J-1, N-J, -ONE, A( 1, J+1 ), - $ LDA, A( 1, J ), 1, ONE, A( J, J+1 ), LDA ) - CALL DSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute the Cholesky factorization A = L*L**T. -* - DO 20 J = 1, N -* -* Compute L(J,J) and test for non-positive-definiteness. -* - AJJ = A( J, J ) - DDOT( J-1, A( J, 1 ), LDA, A( J, 1 ), - $ LDA ) - IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of column J. -* - IF( J.LT.N ) THEN - CALL DGEMV( 'No transpose', N-J, J-1, -ONE, A( J+1, 1 ), - $ LDA, A( J, 1 ), LDA, ONE, A( J+1, J ), 1 ) - CALL DSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF - GO TO 40 -* - 30 CONTINUE - INFO = J -* - 40 CONTINUE - RETURN -* -* End of DPOTF2 -* - END diff --git a/lib/linalg/fortran/dpotrf.f b/lib/linalg/fortran/dpotrf.f deleted file mode 100644 index 1679fc3cd8..0000000000 --- a/lib/linalg/fortran/dpotrf.f +++ /dev/null @@ -1,243 +0,0 @@ -*> \brief \b DPOTRF -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DPOTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DPOTRF computes the Cholesky factorization of a real symmetric -*> positive definite matrix A. -*> -*> The factorization has the form -*> A = U**T * U, if UPLO = 'U', or -*> A = L * L**T, if UPLO = 'L', -*> where U is an upper triangular matrix and L is lower triangular. -*> -*> This is the block version of the algorithm, calling Level 3 BLAS. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the leading -*> N-by-N upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading N-by-N lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> -*> On exit, if INFO = 0, the factor U or L from the Cholesky -*> factorization A = U**T*U or A = L*L**T. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,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 = i, the leading minor of order i is not -*> positive definite, and the factorization could not be -*> completed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doublePOcomputational -* -* ===================================================================== - SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J, JB, NB -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DPOTRF2, DSYRK, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DPOTRF', UPLO, N, -1, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code. -* - CALL DPOTRF2( UPLO, N, A, LDA, INFO ) - ELSE -* -* Use blocked code. -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U**T*U. -* - DO 10 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - JB = MIN( NB, N-J+1 ) - CALL DSYRK( 'Upper', 'Transpose', JB, J-1, -ONE, - $ A( 1, J ), LDA, ONE, A( J, J ), LDA ) - CALL DPOTRF2( 'Upper', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block row. -* - CALL DGEMM( 'Transpose', 'No transpose', JB, N-J-JB+1, - $ J-1, -ONE, A( 1, J ), LDA, A( 1, J+JB ), - $ LDA, ONE, A( J, J+JB ), LDA ) - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', - $ JB, N-J-JB+1, ONE, A( J, J ), LDA, - $ A( J, J+JB ), LDA ) - END IF - 10 CONTINUE -* - ELSE -* -* Compute the Cholesky factorization A = L*L**T. -* - DO 20 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - 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 DPOTRF2( 'Lower', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block column. -* - CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, - $ J-1, -ONE, A( J+JB, 1 ), LDA, A( J, 1 ), - $ LDA, ONE, A( J+JB, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Non-unit', - $ N-J-JB+1, JB, ONE, A( J, J ), LDA, - $ A( J+JB, J ), LDA ) - END IF - 20 CONTINUE - END IF - END IF - GO TO 40 -* - 30 CONTINUE - INFO = INFO + J - 1 -* - 40 CONTINUE - RETURN -* -* End of DPOTRF -* - END diff --git a/lib/linalg/fortran/dpotrf2.f b/lib/linalg/fortran/dpotrf2.f deleted file mode 100644 index 6c28ce6d67..0000000000 --- a/lib/linalg/fortran/dpotrf2.f +++ /dev/null @@ -1,234 +0,0 @@ -*> \brief \b DPOTRF2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* RECURSIVE SUBROUTINE DPOTRF2( UPLO, N, A, LDA, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. -* REAL A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DPOTRF2 computes the Cholesky factorization of a real symmetric -*> positive definite matrix A using the recursive algorithm. -*> -*> The factorization has the form -*> A = U**T * U, if UPLO = 'U', or -*> A = L * L**T, if UPLO = 'L', -*> where U is an upper triangular matrix and L is lower triangular. -*> -*> 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 = n/2 -*> [ A21 | A22 ] n2 = n-n1 -*> -*> The subroutine calls itself to factor A11. Update and scale A21 -*> or A12, update A22 then calls itself to factor A22. -*> -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the leading -*> N-by-N upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading N-by-N lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> -*> On exit, if INFO = 0, the factor U or L from the Cholesky -*> factorization A = U**T*U or A = L*L**T. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,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 = i, the leading minor of order i is not -*> positive definite, and the factorization could not be -*> completed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doublePOcomputational -* -* ===================================================================== - RECURSIVE SUBROUTINE DPOTRF2( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER N1, N2, IINFO -* .. -* .. External Functions .. - LOGICAL LSAME, DISNAN - EXTERNAL LSAME, DISNAN -* .. -* .. External Subroutines .. - EXTERNAL DSYRK, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTRF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* N=1 case -* - IF( N.EQ.1 ) THEN -* -* Test for non-positive-definiteness -* - IF( A( 1, 1 ).LE.ZERO.OR.DISNAN( A( 1, 1 ) ) ) THEN - INFO = 1 - RETURN - END IF -* -* Factor -* - A( 1, 1 ) = SQRT( A( 1, 1 ) ) -* -* Use recursive code -* - ELSE - N1 = N/2 - N2 = N-N1 -* -* Factor A11 -* - CALL DPOTRF2( UPLO, N1, A( 1, 1 ), LDA, IINFO ) - IF ( IINFO.NE.0 ) THEN - INFO = IINFO - RETURN - END IF -* -* Compute the Cholesky factorization A = U**T*U -* - IF( UPPER ) THEN -* -* Update and scale A12 -* - CALL DTRSM( 'L', 'U', 'T', 'N', N1, N2, ONE, - $ A( 1, 1 ), LDA, A( 1, N1+1 ), LDA ) -* -* Update and factor A22 -* - CALL DSYRK( UPLO, 'T', N2, N1, -ONE, A( 1, N1+1 ), LDA, - $ ONE, A( N1+1, N1+1 ), LDA ) - CALL DPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO ) - IF ( IINFO.NE.0 ) THEN - INFO = IINFO + N1 - RETURN - END IF -* -* Compute the Cholesky factorization A = L*L**T -* - ELSE -* -* Update and scale A21 -* - CALL DTRSM( 'R', 'L', 'T', 'N', N2, N1, ONE, - $ A( 1, 1 ), LDA, A( N1+1, 1 ), LDA ) -* -* Update and factor A22 -* - CALL DSYRK( UPLO, 'N', N2, N1, -ONE, A( N1+1, 1 ), LDA, - $ ONE, A( N1+1, N1+1 ), LDA ) - CALL DPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO ) - IF ( IINFO.NE.0 ) THEN - INFO = IINFO + N1 - RETURN - END IF - END IF - END IF - RETURN -* -* End of DPOTRF2 -* - END diff --git a/lib/linalg/fortran/dpotrs.f b/lib/linalg/fortran/dpotrs.f deleted file mode 100644 index 862ee078fd..0000000000 --- a/lib/linalg/fortran/dpotrs.f +++ /dev/null @@ -1,201 +0,0 @@ -*> \brief \b DPOTRS -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DPOTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DPOTRS solves a system of linear equations A*X = B with a symmetric -*> positive definite matrix A using the Cholesky factorization -*> A = U**T*U or A = L*L**T computed by DPOTRF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order 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 matrix B. NRHS >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The triangular factor U or L from the Cholesky factorization -*> A = U**T*U or A = L*L**T, as computed by DPOTRF. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) -*> On entry, the right hand side matrix B. -*> On exit, the solution matrix X. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,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. -* -*> \ingroup doublePOcomputational -* -* ===================================================================== - SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) 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, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Solve A*X = B where A = U**T *U. -* -* Solve U**T *X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A*X = B where A = L*L**T. -* -* Solve L*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) -* -* Solve L**T *X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) - END IF -* - RETURN -* -* End of DPOTRS -* - END diff --git a/lib/linalg/fortran/drot.f b/lib/linalg/fortran/drot.f deleted file mode 100644 index 0386626c8f..0000000000 --- a/lib/linalg/fortran/drot.f +++ /dev/null @@ -1,142 +0,0 @@ -*> \brief \b DROT -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION C,S -* INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION DX(*),DY(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DROT applies a plane rotation. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in,out] DX -*> \verbatim -*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of DX -*> \endverbatim -*> -*> \param[in,out] DY -*> \verbatim -*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> storage spacing between elements of DY -*> \endverbatim -*> -*> \param[in] C -*> \verbatim -*> C is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] S -*> \verbatim -*> S is DOUBLE PRECISION -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, linpack, 3/11/78. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION C,S - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I,IX,IY -* .. - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* - DO I = 1,N - DTEMP = C*DX(I) + S*DY(I) - DY(I) = C*DY(I) - S*DX(I) - DX(I) = DTEMP - END DO - ELSE -* -* code for unequal increments or equal increments not equal -* to 1 -* - IX = 1 - IY = 1 - IF (INCX.LT.0) IX = (-N+1)*INCX + 1 - IF (INCY.LT.0) IY = (-N+1)*INCY + 1 - DO I = 1,N - DTEMP = C*DX(IX) + S*DY(IY) - DY(IY) = C*DY(IY) - S*DX(IX) - DX(IX) = DTEMP - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN -* -* End of DROT -* - END diff --git a/lib/linalg/fortran/drscl.f b/lib/linalg/fortran/drscl.f deleted file mode 100644 index fcd8569650..0000000000 --- a/lib/linalg/fortran/drscl.f +++ /dev/null @@ -1,171 +0,0 @@ -*> \brief \b DRSCL multiplies a vector by the reciprocal of a real scalar. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DRSCL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DRSCL( N, SA, SX, INCX ) -* -* .. Scalar Arguments .. -* INTEGER INCX, N -* DOUBLE PRECISION SA -* .. -* .. Array Arguments .. -* DOUBLE PRECISION SX( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DRSCL multiplies an n-element real vector x by the real scalar 1/a. -*> This is done without overflow or underflow as long as -*> the final result x/a does not overflow or underflow. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of components of the vector x. -*> \endverbatim -*> -*> \param[in] SA -*> \verbatim -*> SA is DOUBLE PRECISION -*> The scalar a which is used to divide each component of x. -*> SA must be >= 0, or the subroutine will divide by zero. -*> \endverbatim -*> -*> \param[in,out] SX -*> \verbatim -*> SX is DOUBLE PRECISION array, dimension -*> (1+(N-1)*abs(INCX)) -*> The n-element vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> The increment between successive values of the vector SX. -*> > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DRSCL( N, SA, SX, INCX ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX, N - DOUBLE PRECISION SA -* .. -* .. Array Arguments .. - DOUBLE PRECISION SX( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL DONE - DOUBLE PRECISION BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DSCAL, DLABAD -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* -* Get machine parameters -* - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -* -* Initialize the denominator to SA and the numerator to 1. -* - CDEN = SA - CNUM = ONE -* - 10 CONTINUE - CDEN1 = CDEN*SMLNUM - CNUM1 = CNUM / BIGNUM - IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN -* -* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. -* - MUL = SMLNUM - DONE = .FALSE. - CDEN = CDEN1 - ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN -* -* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. -* - MUL = BIGNUM - DONE = .FALSE. - CNUM = CNUM1 - ELSE -* -* Multiply X by CNUM / CDEN and return. -* - MUL = CNUM / CDEN - DONE = .TRUE. - END IF -* -* Scale the vector X by MUL -* - CALL DSCAL( N, MUL, SX, INCX ) -* - IF( .NOT.DONE ) - $ GO TO 10 -* - RETURN -* -* End of DRSCL -* - END diff --git a/lib/linalg/fortran/dscal.f b/lib/linalg/fortran/dscal.f deleted file mode 100644 index e055d198af..0000000000 --- a/lib/linalg/fortran/dscal.f +++ /dev/null @@ -1,139 +0,0 @@ -*> \brief \b DSCAL -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DSCAL(N,DA,DX,INCX) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION DA -* INTEGER INCX,N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION DX(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSCAL scales a vector by a constant. -*> uses unrolled loops for increment equal to 1. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in] DA -*> \verbatim -*> DA is DOUBLE PRECISION -*> On entry, DA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in,out] DX -*> \verbatim -*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of DX -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, linpack, 3/11/78. -*> modified 3/93 to return if incx .le. 0. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DSCAL(N,DA,DX,INCX) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION DA - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,M,MP1,NINCX -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER (ONE=1.0D+0) -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0 .OR. INCX.LE.0 .OR. DA.EQ.ONE) RETURN - IF (INCX.EQ.1) THEN -* -* code for increment equal to 1 -* -* -* clean-up loop -* - M = MOD(N,5) - IF (M.NE.0) THEN - DO I = 1,M - DX(I) = DA*DX(I) - END DO - IF (N.LT.5) RETURN - END IF - MP1 = M + 1 - DO I = MP1,N,5 - DX(I) = DA*DX(I) - DX(I+1) = DA*DX(I+1) - DX(I+2) = DA*DX(I+2) - DX(I+3) = DA*DX(I+3) - DX(I+4) = DA*DX(I+4) - END DO - ELSE -* -* code for increment not equal to 1 -* - NINCX = N*INCX - DO I = 1,NINCX,INCX - DX(I) = DA*DX(I) - END DO - END IF - RETURN -* -* End of DSCAL -* - END diff --git a/lib/linalg/fortran/dstedc.f b/lib/linalg/fortran/dstedc.f deleted file mode 100644 index 2ed84afaac..0000000000 --- a/lib/linalg/fortran/dstedc.f +++ /dev/null @@ -1,479 +0,0 @@ -*> \brief \b DSTEDC -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSTEDC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* INTEGER IWORK( * ) -* DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSTEDC computes all eigenvalues and, optionally, eigenvectors of a -*> symmetric tridiagonal matrix using the divide and conquer method. -*> The eigenvectors of a full or band real symmetric matrix can also be -*> found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this -*> matrix to tridiagonal form. -*> -*> 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 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. See DLAED3 for details. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] COMPZ -*> \verbatim -*> COMPZ is CHARACTER*1 -*> = 'N': Compute eigenvalues only. -*> = 'I': Compute eigenvectors of tridiagonal matrix also. -*> = 'V': Compute eigenvectors of original dense symmetric -*> matrix also. On entry, Z contains the orthogonal -*> matrix used to reduce the original matrix to -*> tridiagonal form. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the diagonal elements of the tridiagonal matrix. -*> On exit, if INFO = 0, the eigenvalues in ascending order. -*> \endverbatim -*> -*> \param[in,out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> On entry, the subdiagonal elements of the tridiagonal matrix. -*> On exit, E has been destroyed. -*> \endverbatim -*> -*> \param[in,out] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (LDZ,N) -*> On entry, if COMPZ = 'V', then Z contains the orthogonal -*> matrix used in the reduction to tridiagonal form. -*> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the -*> orthonormal eigenvectors of the original symmetric matrix, -*> and if COMPZ = 'I', Z contains the orthonormal eigenvectors -*> of the symmetric tridiagonal matrix. -*> If COMPZ = 'N', then Z is not referenced. -*> \endverbatim -*> -*> \param[in] LDZ -*> \verbatim -*> LDZ is INTEGER -*> The leading dimension of the array Z. LDZ >= 1. -*> If eigenvectors are desired, then LDZ >= max(1,N). -*> \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. -*> If COMPZ = 'N' or N <= 1 then LWORK must be at least 1. -*> If COMPZ = 'V' and N > 1 then LWORK must be at least -*> ( 1 + 3*N + 2*N*lg N + 4*N**2 ), -*> where lg( N ) = smallest integer k such -*> that 2**k >= N. -*> If COMPZ = 'I' and N > 1 then LWORK must be at least -*> ( 1 + 4*N + N**2 ). -*> Note that for COMPZ = 'I' or 'V', then if N is less than or -*> equal to the minimum divide size, usually 25, then LWORK need -*> only be max(1,2*(N-1)). -*> -*> 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)) -*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. -*> \endverbatim -*> -*> \param[in] LIWORK -*> \verbatim -*> LIWORK is INTEGER -*> The dimension of the array IWORK. -*> If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1. -*> If COMPZ = 'V' and N > 1 then LIWORK must be at least -*> ( 6 + 6*N + 5*N*lg N ). -*> If COMPZ = 'I' and N > 1 then LIWORK must be at least -*> ( 3 + 5*N ). -*> Note that for COMPZ = 'I' or 'V', then if N is less than or -*> equal to the minimum divide size, usually 25, then LIWORK -*> need only be 1. -*> -*> If LIWORK = -1, then a workspace query is assumed; the -*> routine only calculates the optimal size of the IWORK array, -*> returns this value as the first entry of the IWORK array, and -*> no error message related to LIWORK 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 failed to compute an eigenvalue 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. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA \n -*> Modified by Francoise Tisseur, University of Tennessee -*> -* ===================================================================== - SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, - $ LIWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER COMPZ - INTEGER INFO, LDZ, LIWORK, LWORK, N -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN, - $ LWMIN, M, SMLSIZ, START, STOREZ, STRTRW - DOUBLE PRECISION EPS, ORGNRM, P, TINY -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANST - EXTERNAL LSAME, ILAENV, DLAMCH, DLANST -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLAED0, DLASCL, DLASET, DLASRT, - $ DSTEQR, DSTERF, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, LOG, MAX, MOD, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) -* - IF( LSAME( COMPZ, 'N' ) ) THEN - ICOMPZ = 0 - ELSE IF( LSAME( COMPZ, 'V' ) ) THEN - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ICOMPZ = 2 - ELSE - ICOMPZ = -1 - END IF - IF( ICOMPZ.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( ( LDZ.LT.1 ) .OR. - $ ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, N ) ) ) THEN - INFO = -6 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Compute the workspace requirements -* - SMLSIZ = ILAENV( 9, 'DSTEDC', ' ', 0, 0, 0, 0 ) - IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN - LIWMIN = 1 - LWMIN = 1 - ELSE IF( N.LE.SMLSIZ ) THEN - LIWMIN = 1 - LWMIN = 2*( N - 1 ) - ELSE - LGN = INT( LOG( DBLE( N ) )/LOG( TWO ) ) - IF( 2**LGN.LT.N ) - $ LGN = LGN + 1 - IF( 2**LGN.LT.N ) - $ LGN = LGN + 1 - IF( ICOMPZ.EQ.1 ) THEN - LWMIN = 1 + 3*N + 2*N*LGN + 4*N**2 - LIWMIN = 6 + 6*N + 5*N*LGN - ELSE IF( ICOMPZ.EQ.2 ) THEN - LWMIN = 1 + 4*N + N**2 - LIWMIN = 3 + 5*N - END IF - END IF - WORK( 1 ) = LWMIN - IWORK( 1 ) = LIWMIN -* - IF( LWORK.LT.LWMIN .AND. .NOT. LQUERY ) THEN - INFO = -8 - ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT. LQUERY ) THEN - INFO = -10 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSTEDC', -INFO ) - RETURN - ELSE IF (LQUERY) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN - IF( N.EQ.1 ) THEN - IF( ICOMPZ.NE.0 ) - $ Z( 1, 1 ) = ONE - RETURN - END IF -* -* If the following conditional clause is removed, then the routine -* will use the Divide and Conquer routine to compute only the -* eigenvalues, which requires (3N + 3N**2) real workspace and -* (2 + 5N + 2N lg(N)) integer workspace. -* Since on many architectures DSTERF is much faster than any other -* algorithm for finding eigenvalues only, it is used here -* as the default. If the conditional clause is removed, then -* information on the size of workspace needs to be changed. -* -* If COMPZ = 'N', use DSTERF to compute the eigenvalues. -* - IF( ICOMPZ.EQ.0 ) THEN - CALL DSTERF( N, D, E, INFO ) - GO TO 50 - END IF -* -* If N is smaller than the minimum divide size (SMLSIZ+1), then -* solve the problem with another solver. -* - IF( N.LE.SMLSIZ ) THEN -* - CALL DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* - ELSE -* -* If COMPZ = 'V', the Z matrix must be stored elsewhere for later -* use. -* - IF( ICOMPZ.EQ.1 ) THEN - STOREZ = 1 + N*N - ELSE - STOREZ = 1 - END IF -* - IF( ICOMPZ.EQ.2 ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) - END IF -* -* Scale. -* - ORGNRM = DLANST( 'M', N, D, E ) - IF( ORGNRM.EQ.ZERO ) - $ GO TO 50 -* - EPS = DLAMCH( 'Epsilon' ) -* - START = 1 -* -* while ( START <= N ) -* - 10 CONTINUE - IF( START.LE.N ) THEN -* -* Let FINISH be the position of the next subdiagonal entry -* such that E( FINISH ) <= TINY or FINISH = N if no such -* subdiagonal exists. The matrix identified by the elements -* between START and FINISH constitutes an independent -* sub-problem. -* - FINISH = START - 20 CONTINUE - IF( FINISH.LT.N ) THEN - TINY = EPS*SQRT( ABS( D( FINISH ) ) )* - $ SQRT( ABS( D( FINISH+1 ) ) ) - IF( ABS( E( FINISH ) ).GT.TINY ) THEN - FINISH = FINISH + 1 - GO TO 20 - END IF - END IF -* -* (Sub) Problem determined. Compute its size and solve it. -* - M = FINISH - START + 1 - IF( M.EQ.1 ) THEN - START = FINISH + 1 - GO TO 10 - END IF - IF( M.GT.SMLSIZ ) THEN -* -* Scale. -* - ORGNRM = DLANST( 'M', M, D( START ), E( START ) ) - CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ), - $ M-1, INFO ) -* - IF( ICOMPZ.EQ.1 ) THEN - STRTRW = 1 - ELSE - STRTRW = START - END IF - CALL DLAED0( ICOMPZ, N, M, D( START ), E( START ), - $ Z( STRTRW, START ), LDZ, WORK( 1 ), N, - $ WORK( STOREZ ), IWORK, INFO ) - IF( INFO.NE.0 ) THEN - INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) + - $ MOD( INFO, ( M+1 ) ) + START - 1 - GO TO 50 - END IF -* -* Scale back. -* - CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M, - $ INFO ) -* - ELSE - IF( ICOMPZ.EQ.1 ) THEN -* -* Since QR won't update a Z matrix which is larger than -* the length of D, we must solve the sub-problem in a -* workspace and then multiply back into Z. -* - CALL DSTEQR( 'I', M, D( START ), E( START ), WORK, M, - $ WORK( M*M+1 ), INFO ) - CALL DLACPY( 'A', N, M, Z( 1, START ), LDZ, - $ WORK( STOREZ ), N ) - CALL DGEMM( 'N', 'N', N, M, M, ONE, - $ WORK( STOREZ ), N, WORK, M, ZERO, - $ Z( 1, START ), LDZ ) - ELSE IF( ICOMPZ.EQ.2 ) THEN - CALL DSTEQR( 'I', M, D( START ), E( START ), - $ Z( START, START ), LDZ, WORK, INFO ) - ELSE - CALL DSTERF( M, D( START ), E( START ), INFO ) - END IF - IF( INFO.NE.0 ) THEN - INFO = START*( N+1 ) + FINISH - GO TO 50 - END IF - END IF -* - START = FINISH + 1 - GO TO 10 - END IF -* -* endwhile -* - IF( ICOMPZ.EQ.0 ) THEN -* -* Use Quick Sort -* - CALL DLASRT( 'I', N, D, INFO ) -* - ELSE -* -* 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 - END IF -* - 50 CONTINUE - WORK( 1 ) = LWMIN - IWORK( 1 ) = LIWMIN -* - RETURN -* -* End of DSTEDC -* - END diff --git a/lib/linalg/fortran/dsteqr.f b/lib/linalg/fortran/dsteqr.f deleted file mode 100644 index 50a9188c7c..0000000000 --- a/lib/linalg/fortran/dsteqr.f +++ /dev/null @@ -1,569 +0,0 @@ -*> \brief \b DSTEQR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSTEQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER COMPZ -* INTEGER INFO, LDZ, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSTEQR computes all eigenvalues and, optionally, eigenvectors of a -*> symmetric tridiagonal matrix using the implicit QL or QR method. -*> The eigenvectors of a full or band symmetric matrix can also be found -*> if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to -*> tridiagonal form. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] COMPZ -*> \verbatim -*> COMPZ is CHARACTER*1 -*> = 'N': Compute eigenvalues only. -*> = 'V': Compute eigenvalues and eigenvectors of the original -*> symmetric matrix. On entry, Z must contain the -*> orthogonal matrix used to reduce the original matrix -*> to tridiagonal form. -*> = 'I': Compute eigenvalues and eigenvectors of the -*> tridiagonal matrix. Z is initialized to the identity -*> matrix. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix. N >= 0. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the diagonal elements of the tridiagonal matrix. -*> On exit, if INFO = 0, the eigenvalues in ascending order. -*> \endverbatim -*> -*> \param[in,out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> On entry, the (n-1) subdiagonal elements of the tridiagonal -*> matrix. -*> On exit, E has been destroyed. -*> \endverbatim -*> -*> \param[in,out] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (LDZ, N) -*> On entry, if COMPZ = 'V', then Z contains the orthogonal -*> matrix used in the reduction to tridiagonal form. -*> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the -*> orthonormal eigenvectors of the original symmetric matrix, -*> and if COMPZ = 'I', Z contains the orthonormal eigenvectors -*> of the symmetric tridiagonal matrix. -*> If COMPZ = 'N', then Z is not referenced. -*> \endverbatim -*> -*> \param[in] LDZ -*> \verbatim -*> LDZ is INTEGER -*> The leading dimension of the array Z. LDZ >= 1, and if -*> eigenvectors are desired, then LDZ >= max(1,N). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (max(1,2*N-2)) -*> If COMPZ = 'N', then WORK is not referenced. -*> \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 has failed to find all the eigenvalues in -*> a total of 30*N iterations; if INFO = i, then i -*> elements of E have not converged to zero; on exit, D -*> and E contain the elements of a symmetric tridiagonal -*> matrix which is orthogonally similar to the original -*> matrix. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER COMPZ - INTEGER INFO, LDZ, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) - INTEGER MAXIT - PARAMETER ( MAXIT = 30 ) -* .. -* .. Local Scalars .. - INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, - $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, - $ NM1, NMAXIT - DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, - $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 - EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 -* .. -* .. External Subroutines .. - EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASET, DLASR, - $ DLASRT, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( LSAME( COMPZ, 'N' ) ) THEN - ICOMPZ = 0 - ELSE IF( LSAME( COMPZ, 'V' ) ) THEN - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ICOMPZ = 2 - ELSE - ICOMPZ = -1 - END IF - IF( ICOMPZ.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, - $ N ) ) ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSTEQR', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( N.EQ.1 ) THEN - IF( ICOMPZ.EQ.2 ) - $ Z( 1, 1 ) = ONE - RETURN - END IF -* -* Determine the unit roundoff and over/underflow thresholds. -* - EPS = DLAMCH( 'E' ) - EPS2 = EPS**2 - SAFMIN = DLAMCH( 'S' ) - SAFMAX = ONE / SAFMIN - SSFMAX = SQRT( SAFMAX ) / THREE - SSFMIN = SQRT( SAFMIN ) / EPS2 -* -* Compute the eigenvalues and eigenvectors of the tridiagonal -* matrix. -* - IF( ICOMPZ.EQ.2 ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) -* - NMAXIT = N*MAXIT - JTOT = 0 -* -* Determine where the matrix splits and choose QL or QR iteration -* for each block, according to whether top or bottom diagonal -* element is smaller. -* - L1 = 1 - NM1 = N - 1 -* - 10 CONTINUE - IF( L1.GT.N ) - $ GO TO 160 - IF( L1.GT.1 ) - $ E( L1-1 ) = ZERO - IF( L1.LE.NM1 ) THEN - DO 20 M = L1, NM1 - TST = ABS( E( M ) ) - IF( TST.EQ.ZERO ) - $ GO TO 30 - IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ - $ 1 ) ) ) )*EPS ) THEN - E( M ) = ZERO - GO TO 30 - END IF - 20 CONTINUE - END IF - M = N -* - 30 CONTINUE - L = L1 - LSV = L - LEND = M - LENDSV = LEND - L1 = M + 1 - IF( LEND.EQ.L ) - $ GO TO 10 -* -* Scale submatrix in rows and columns L to LEND -* - ANORM = DLANST( 'M', LEND-L+1, D( L ), E( L ) ) - ISCALE = 0 - IF( ANORM.EQ.ZERO ) - $ GO TO 10 - IF( ANORM.GT.SSFMAX ) THEN - ISCALE = 1 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, - $ INFO ) - ELSE IF( ANORM.LT.SSFMIN ) THEN - ISCALE = 2 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, - $ INFO ) - END IF -* -* Choose between QL and QR iteration -* - IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN - LEND = LSV - L = LENDSV - END IF -* - IF( LEND.GT.L ) THEN -* -* QL Iteration -* -* Look for small subdiagonal element. -* - 40 CONTINUE - IF( L.NE.LEND ) THEN - LENDM1 = LEND - 1 - DO 50 M = L, LENDM1 - TST = ABS( E( M ) )**2 - IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ - $ SAFMIN )GO TO 60 - 50 CONTINUE - END IF -* - M = LEND -* - 60 CONTINUE - IF( M.LT.LEND ) - $ E( M ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 80 -* -* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 -* to compute its eigensystem. -* - IF( M.EQ.L+1 ) THEN - IF( ICOMPZ.GT.0 ) THEN - CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) - WORK( L ) = C - WORK( N-1+L ) = S - CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ), - $ WORK( N-1+L ), Z( 1, L ), LDZ ) - ELSE - CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) - END IF - D( L ) = RT1 - D( L+1 ) = RT2 - E( L ) = ZERO - L = L + 2 - IF( L.LE.LEND ) - $ GO TO 40 - GO TO 140 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 140 - JTOT = JTOT + 1 -* -* Form shift. -* - G = ( D( L+1 )-P ) / ( TWO*E( L ) ) - R = DLAPY2( G, ONE ) - G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) -* - S = ONE - C = ONE - P = ZERO -* -* Inner loop -* - MM1 = M - 1 - DO 70 I = MM1, L, -1 - F = S*E( I ) - B = C*E( I ) - CALL DLARTG( G, F, C, S, R ) - IF( I.NE.M-1 ) - $ E( I+1 ) = R - G = D( I+1 ) - P - R = ( D( I )-G )*S + TWO*C*B - P = S*R - D( I+1 ) = G + P - G = C*R - B -* -* If eigenvectors are desired, then save rotations. -* - IF( ICOMPZ.GT.0 ) THEN - WORK( I ) = C - WORK( N-1+I ) = -S - END IF -* - 70 CONTINUE -* -* If eigenvectors are desired, then apply saved rotations. -* - IF( ICOMPZ.GT.0 ) THEN - MM = M - L + 1 - CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), - $ Z( 1, L ), LDZ ) - END IF -* - D( L ) = D( L ) - P - E( L ) = G - GO TO 40 -* -* Eigenvalue found. -* - 80 CONTINUE - D( L ) = P -* - L = L + 1 - IF( L.LE.LEND ) - $ GO TO 40 - GO TO 140 -* - ELSE -* -* QR Iteration -* -* Look for small superdiagonal element. -* - 90 CONTINUE - IF( L.NE.LEND ) THEN - LENDP1 = LEND + 1 - DO 100 M = L, LENDP1, -1 - TST = ABS( E( M-1 ) )**2 - IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ - $ SAFMIN )GO TO 110 - 100 CONTINUE - END IF -* - M = LEND -* - 110 CONTINUE - IF( M.GT.LEND ) - $ E( M-1 ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 130 -* -* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 -* to compute its eigensystem. -* - IF( M.EQ.L-1 ) THEN - IF( ICOMPZ.GT.0 ) THEN - CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) - WORK( M ) = C - WORK( N-1+M ) = S - CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ), - $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) - ELSE - CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) - END IF - D( L-1 ) = RT1 - D( L ) = RT2 - E( L-1 ) = ZERO - L = L - 2 - IF( L.GE.LEND ) - $ GO TO 90 - GO TO 140 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 140 - JTOT = JTOT + 1 -* -* Form shift. -* - G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) - R = DLAPY2( G, ONE ) - G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) -* - S = ONE - C = ONE - P = ZERO -* -* Inner loop -* - LM1 = L - 1 - DO 120 I = M, LM1 - F = S*E( I ) - B = C*E( I ) - CALL DLARTG( G, F, C, S, R ) - IF( I.NE.M ) - $ E( I-1 ) = R - G = D( I ) - P - R = ( D( I+1 )-G )*S + TWO*C*B - P = S*R - D( I ) = G + P - G = C*R - B -* -* If eigenvectors are desired, then save rotations. -* - IF( ICOMPZ.GT.0 ) THEN - WORK( I ) = C - WORK( N-1+I ) = S - END IF -* - 120 CONTINUE -* -* If eigenvectors are desired, then apply saved rotations. -* - IF( ICOMPZ.GT.0 ) THEN - MM = L - M + 1 - CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), - $ Z( 1, M ), LDZ ) - END IF -* - D( L ) = D( L ) - P - E( LM1 ) = G - GO TO 90 -* -* Eigenvalue found. -* - 130 CONTINUE - D( L ) = P -* - L = L - 1 - IF( L.GE.LEND ) - $ GO TO 90 - GO TO 140 -* - END IF -* -* Undo scaling if necessary -* - 140 CONTINUE - IF( ISCALE.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) - CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), - $ N, INFO ) - ELSE IF( ISCALE.EQ.2 ) THEN - CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) - CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), - $ N, INFO ) - END IF -* -* Check for no convergence to an eigenvalue after a total -* of N*MAXIT iterations. -* - IF( JTOT.LT.NMAXIT ) - $ GO TO 10 - DO 150 I = 1, N - 1 - IF( E( I ).NE.ZERO ) - $ INFO = INFO + 1 - 150 CONTINUE - GO TO 190 -* -* Order eigenvalues and eigenvectors. -* - 160 CONTINUE - IF( ICOMPZ.EQ.0 ) THEN -* -* Use Quick Sort -* - CALL DLASRT( 'I', N, D, INFO ) -* - ELSE -* -* Use Selection Sort to minimize swaps of eigenvectors -* - DO 180 II = 2, N - I = II - 1 - K = I - P = D( I ) - DO 170 J = II, N - IF( D( J ).LT.P ) THEN - K = J - P = D( J ) - END IF - 170 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 - 180 CONTINUE - END IF -* - 190 CONTINUE - RETURN -* -* End of DSTEQR -* - END diff --git a/lib/linalg/fortran/dsterf.f b/lib/linalg/fortran/dsterf.f deleted file mode 100644 index b0f8d36084..0000000000 --- a/lib/linalg/fortran/dsterf.f +++ /dev/null @@ -1,423 +0,0 @@ -*> \brief \b DSTERF -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSTERF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DSTERF( N, D, E, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ), E( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSTERF computes all eigenvalues of a symmetric tridiagonal matrix -*> using the Pal-Walker-Kahan variant of the QL or QR algorithm. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix. N >= 0. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the n diagonal elements of the tridiagonal matrix. -*> On exit, if INFO = 0, the eigenvalues in ascending order. -*> \endverbatim -*> -*> \param[in,out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> On entry, the (n-1) subdiagonal elements of the tridiagonal -*> matrix. -*> On exit, E has been destroyed. -*> \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 find all of the eigenvalues in -*> a total of 30*N iterations; if INFO = i, then i -*> elements of E have not converged to zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DSTERF( N, D, E, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) - INTEGER MAXIT - PARAMETER ( MAXIT = 30 ) -* .. -* .. Local Scalars .. - INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M, - $ NMAXIT - DOUBLE PRECISION ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC, - $ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN, - $ SIGMA, SSFMAX, SSFMIN, RMAX -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 - EXTERNAL DLAMCH, DLANST, DLAPY2 -* .. -* .. External Subroutines .. - EXTERNAL DLAE2, DLASCL, DLASRT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* -* Quick return if possible -* - IF( N.LT.0 ) THEN - INFO = -1 - CALL XERBLA( 'DSTERF', -INFO ) - RETURN - END IF - IF( N.LE.1 ) - $ RETURN -* -* Determine the unit roundoff for this environment. -* - EPS = DLAMCH( 'E' ) - EPS2 = EPS**2 - SAFMIN = DLAMCH( 'S' ) - SAFMAX = ONE / SAFMIN - SSFMAX = SQRT( SAFMAX ) / THREE - SSFMIN = SQRT( SAFMIN ) / EPS2 - RMAX = DLAMCH( 'O' ) -* -* Compute the eigenvalues of the tridiagonal matrix. -* - NMAXIT = N*MAXIT - SIGMA = ZERO - JTOT = 0 -* -* Determine where the matrix splits and choose QL or QR iteration -* for each block, according to whether top or bottom diagonal -* element is smaller. -* - L1 = 1 -* - 10 CONTINUE - IF( L1.GT.N ) - $ GO TO 170 - IF( L1.GT.1 ) - $ E( L1-1 ) = ZERO - DO 20 M = L1, N - 1 - IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ - $ 1 ) ) ) )*EPS ) THEN - E( M ) = ZERO - GO TO 30 - END IF - 20 CONTINUE - M = N -* - 30 CONTINUE - L = L1 - LSV = L - LEND = M - LENDSV = LEND - L1 = M + 1 - IF( LEND.EQ.L ) - $ GO TO 10 -* -* Scale submatrix in rows and columns L to LEND -* - ANORM = DLANST( 'M', LEND-L+1, D( L ), E( L ) ) - ISCALE = 0 - IF( ANORM.EQ.ZERO ) - $ GO TO 10 - IF( (ANORM.GT.SSFMAX) ) THEN - ISCALE = 1 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, - $ INFO ) - ELSE IF( ANORM.LT.SSFMIN ) THEN - ISCALE = 2 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, - $ INFO ) - END IF -* - DO 40 I = L, LEND - 1 - E( I ) = E( I )**2 - 40 CONTINUE -* -* Choose between QL and QR iteration -* - IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN - LEND = LSV - L = LENDSV - END IF -* - IF( LEND.GE.L ) THEN -* -* QL Iteration -* -* Look for small subdiagonal element. -* - 50 CONTINUE - IF( L.NE.LEND ) THEN - DO 60 M = L, LEND - 1 - IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*D( M+1 ) ) ) - $ GO TO 70 - 60 CONTINUE - END IF - M = LEND -* - 70 CONTINUE - IF( M.LT.LEND ) - $ E( M ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 90 -* -* If remaining matrix is 2 by 2, use DLAE2 to compute its -* eigenvalues. -* - IF( M.EQ.L+1 ) THEN - RTE = SQRT( E( L ) ) - CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 ) - D( L ) = RT1 - D( L+1 ) = RT2 - E( L ) = ZERO - L = L + 2 - IF( L.LE.LEND ) - $ GO TO 50 - GO TO 150 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 150 - JTOT = JTOT + 1 -* -* Form shift. -* - RTE = SQRT( E( L ) ) - SIGMA = ( D( L+1 )-P ) / ( TWO*RTE ) - R = DLAPY2( SIGMA, ONE ) - SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) -* - C = ONE - S = ZERO - GAMMA = D( M ) - SIGMA - P = GAMMA*GAMMA -* -* Inner loop -* - DO 80 I = M - 1, L, -1 - BB = E( I ) - R = P + BB - IF( I.NE.M-1 ) - $ E( I+1 ) = S*R - OLDC = C - C = P / R - S = BB / R - OLDGAM = GAMMA - ALPHA = D( I ) - GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM - D( I+1 ) = OLDGAM + ( ALPHA-GAMMA ) - IF( C.NE.ZERO ) THEN - P = ( GAMMA*GAMMA ) / C - ELSE - P = OLDC*BB - END IF - 80 CONTINUE -* - E( L ) = S*P - D( L ) = SIGMA + GAMMA - GO TO 50 -* -* Eigenvalue found. -* - 90 CONTINUE - D( L ) = P -* - L = L + 1 - IF( L.LE.LEND ) - $ GO TO 50 - GO TO 150 -* - ELSE -* -* QR Iteration -* -* Look for small superdiagonal element. -* - 100 CONTINUE - DO 110 M = L, LEND + 1, -1 - IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) ) - $ GO TO 120 - 110 CONTINUE - M = LEND -* - 120 CONTINUE - IF( M.GT.LEND ) - $ E( M-1 ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 140 -* -* If remaining matrix is 2 by 2, use DLAE2 to compute its -* eigenvalues. -* - IF( M.EQ.L-1 ) THEN - RTE = SQRT( E( L-1 ) ) - CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 ) - D( L ) = RT1 - D( L-1 ) = RT2 - E( L-1 ) = ZERO - L = L - 2 - IF( L.GE.LEND ) - $ GO TO 100 - GO TO 150 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 150 - JTOT = JTOT + 1 -* -* Form shift. -* - RTE = SQRT( E( L-1 ) ) - SIGMA = ( D( L-1 )-P ) / ( TWO*RTE ) - R = DLAPY2( SIGMA, ONE ) - SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) -* - C = ONE - S = ZERO - GAMMA = D( M ) - SIGMA - P = GAMMA*GAMMA -* -* Inner loop -* - DO 130 I = M, L - 1 - BB = E( I ) - R = P + BB - IF( I.NE.M ) - $ E( I-1 ) = S*R - OLDC = C - C = P / R - S = BB / R - OLDGAM = GAMMA - ALPHA = D( I+1 ) - GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM - D( I ) = OLDGAM + ( ALPHA-GAMMA ) - IF( C.NE.ZERO ) THEN - P = ( GAMMA*GAMMA ) / C - ELSE - P = OLDC*BB - END IF - 130 CONTINUE -* - E( L-1 ) = S*P - D( L ) = SIGMA + GAMMA - GO TO 100 -* -* Eigenvalue found. -* - 140 CONTINUE - D( L ) = P -* - L = L - 1 - IF( L.GE.LEND ) - $ GO TO 100 - GO TO 150 -* - END IF -* -* Undo scaling if necessary -* - 150 CONTINUE - IF( ISCALE.EQ.1 ) - $ CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) - IF( ISCALE.EQ.2 ) - $ CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) -* -* Check for no convergence to an eigenvalue after a total -* of N*MAXIT iterations. -* - IF( JTOT.LT.NMAXIT ) - $ GO TO 10 - DO 160 I = 1, N - 1 - IF( E( I ).NE.ZERO ) - $ INFO = INFO + 1 - 160 CONTINUE - GO TO 180 -* -* Sort eigenvalues in increasing order. -* - 170 CONTINUE - CALL DLASRT( 'I', N, D, INFO ) -* - 180 CONTINUE - RETURN -* -* End of DSTERF -* - END diff --git a/lib/linalg/fortran/dswap.f b/lib/linalg/fortran/dswap.f deleted file mode 100644 index b7600aa2d4..0000000000 --- a/lib/linalg/fortran/dswap.f +++ /dev/null @@ -1,153 +0,0 @@ -*> \brief \b DSWAP -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) -* -* .. Scalar Arguments .. -* INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION DX(*),DY(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSWAP interchanges two vectors. -*> uses unrolled loops for increments equal to 1. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in,out] DX -*> \verbatim -*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of DX -*> \endverbatim -*> -*> \param[in,out] DY -*> \verbatim -*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> storage spacing between elements of DY -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, linpack, 3/11/78. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,3) - IF (M.NE.0) THEN - DO I = 1,M - DTEMP = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP - END DO - IF (N.LT.3) RETURN - END IF - MP1 = M + 1 - DO I = MP1,N,3 - DTEMP = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP - DTEMP = DX(I+1) - DX(I+1) = DY(I+1) - DY(I+1) = DTEMP - DTEMP = DX(I+2) - DX(I+2) = DY(I+2) - DY(I+2) = DTEMP - END DO - ELSE -* -* code for unequal increments or equal increments not equal -* to 1 -* - IX = 1 - IY = 1 - IF (INCX.LT.0) IX = (-N+1)*INCX + 1 - IF (INCY.LT.0) IY = (-N+1)*INCY + 1 - DO I = 1,N - DTEMP = DX(IX) - DX(IX) = DY(IY) - DY(IY) = DTEMP - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN -* -* End of DSWAP -* - END diff --git a/lib/linalg/fortran/dsyev.f b/lib/linalg/fortran/dsyev.f deleted file mode 100644 index da7557ee02..0000000000 --- a/lib/linalg/fortran/dsyev.f +++ /dev/null @@ -1,283 +0,0 @@ -*> \brief DSYEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSYEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER JOBZ, UPLO -* INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYEV computes all eigenvalues and, optionally, eigenvectors of a -*> real symmetric matrix A. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] JOBZ -*> \verbatim -*> JOBZ is CHARACTER*1 -*> = 'N': Compute eigenvalues only; -*> = 'V': Compute eigenvalues and eigenvectors. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA, N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the -*> leading N-by-N upper triangular part of A contains the -*> upper triangular part of the matrix A. If UPLO = 'L', -*> the leading N-by-N lower triangular part of A contains -*> the lower triangular part of the matrix A. -*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the -*> orthonormal eigenvectors of the matrix A. -*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') -*> or the upper triangle (if UPLO='U') of A, including the -*> diagonal, is destroyed. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (N) -*> If INFO = 0, the eigenvalues in ascending order. -*> \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 length of the array WORK. LWORK >= max(1,3*N-1). -*> For optimal efficiency, LWORK >= (NB+2)*N, -*> where NB is the blocksize for DSYTRD returned by ILAENV. -*> -*> 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: if INFO = i, the algorithm failed to converge; i -*> off-diagonal elements of an intermediate tridiagonal -*> 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. -* -*> \ingroup doubleSYeigen -* -* ===================================================================== - SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) -* -* -- LAPACK driver routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER JOBZ, UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL LOWER, LQUERY, WANTZ - INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, - $ LLWORK, LWKOPT, NB - DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, - $ SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY -* .. -* .. External Subroutines .. - EXTERNAL DLASCL, DORGTR, DSCAL, DSTEQR, DSTERF, DSYTRD, - $ XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) - LOWER = LSAME( UPLO, 'L' ) - LQUERY = ( LWORK.EQ.-1 ) -* - INFO = 0 - IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF -* - IF( INFO.EQ.0 ) THEN - NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) - LWKOPT = MAX( 1, ( NB+2 )*N ) - WORK( 1 ) = LWKOPT -* - IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY ) - $ INFO = -8 - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYEV ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - RETURN - END IF -* - IF( N.EQ.1 ) THEN - W( 1 ) = A( 1, 1 ) - WORK( 1 ) = 2 - IF( WANTZ ) - $ A( 1, 1 ) = ONE - RETURN - END IF -* -* Get machine constants. -* - SAFMIN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Precision' ) - SMLNUM = SAFMIN / EPS - BIGNUM = ONE / SMLNUM - RMIN = SQRT( SMLNUM ) - RMAX = SQRT( BIGNUM ) -* -* Scale matrix to allowable range, if necessary. -* - ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) - ISCALE = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN - ISCALE = 1 - SIGMA = RMIN / ANRM - ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 - SIGMA = RMAX / ANRM - END IF - IF( ISCALE.EQ.1 ) - $ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) -* -* Call DSYTRD to reduce symmetric matrix to tridiagonal form. -* - INDE = 1 - INDTAU = INDE + N - INDWRK = INDTAU + N - LLWORK = LWORK - INDWRK + 1 - CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ), - $ WORK( INDWRK ), LLWORK, IINFO ) -* -* For eigenvalues only, call DSTERF. For eigenvectors, first call -* DORGTR to generate the orthogonal matrix, then call DSTEQR. -* - IF( .NOT.WANTZ ) THEN - CALL DSTERF( N, W, WORK( INDE ), INFO ) - ELSE - CALL DORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), - $ LLWORK, IINFO ) - CALL DSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ), - $ INFO ) - END IF -* -* If matrix was scaled, then rescale eigenvalues appropriately. -* - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = N - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF -* -* Set WORK(1) to optimal workspace size. -* - WORK( 1 ) = LWKOPT -* - RETURN -* -* End of DSYEV -* - END diff --git a/lib/linalg/fortran/dsyevd.f b/lib/linalg/fortran/dsyevd.f deleted file mode 100644 index eaaecd8d98..0000000000 --- a/lib/linalg/fortran/dsyevd.f +++ /dev/null @@ -1,354 +0,0 @@ -*> \brief DSYEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSYEVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* INTEGER IWORK( * ) -* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYEVD computes all eigenvalues and, optionally, eigenvectors of a -*> real symmetric matrix A. If eigenvectors are desired, it uses a -*> divide and conquer algorithm. -*> -*> 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. -*> -*> Because of large use of BLAS of level 3, DSYEVD needs N**2 more -*> workspace than DSYEVX. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] JOBZ -*> \verbatim -*> JOBZ is CHARACTER*1 -*> = 'N': Compute eigenvalues only; -*> = 'V': Compute eigenvalues and eigenvectors. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA, N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the -*> leading N-by-N upper triangular part of A contains the -*> upper triangular part of the matrix A. If UPLO = 'L', -*> the leading N-by-N lower triangular part of A contains -*> the lower triangular part of the matrix A. -*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the -*> orthonormal eigenvectors of the matrix A. -*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') -*> or the upper triangle (if UPLO='U') of A, including the -*> diagonal, is destroyed. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (N) -*> If INFO = 0, the eigenvalues in ascending order. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, -*> dimension (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. -*> If N <= 1, LWORK must be at least 1. -*> If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1. -*> If JOBZ = 'V' and N > 1, LWORK must be at least -*> 1 + 6*N + 2*N**2. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal sizes of the WORK and IWORK -*> arrays, returns these values as the first entries of the WORK -*> and IWORK arrays, and no error message related to LWORK or -*> LIWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) -*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. -*> \endverbatim -*> -*> \param[in] LIWORK -*> \verbatim -*> LIWORK is INTEGER -*> The dimension of the array IWORK. -*> If N <= 1, LIWORK must be at least 1. -*> If JOBZ = 'N' and N > 1, LIWORK must be at least 1. -*> If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. -*> -*> If LIWORK = -1, then a workspace query is assumed; the -*> routine only calculates the optimal sizes of the WORK and -*> IWORK arrays, returns these values as the first entries of -*> the WORK and IWORK arrays, and no error message related to -*> LWORK or LIWORK 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: if INFO = i and JOBZ = 'N', then the algorithm failed -*> to converge; i off-diagonal elements of an intermediate -*> tridiagonal form did not converge to zero; -*> if INFO = i and JOBZ = 'V', then the algorithm failed -*> to compute an eigenvalue 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. -* -*> \ingroup doubleSYeigen -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA \n -*> Modified by Francoise Tisseur, University of Tennessee \n -*> Modified description of INFO. Sven, 16 Feb 05. \n - - -*> -* ===================================================================== - SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, - $ LIWORK, INFO ) -* -* -- LAPACK driver routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER JOBZ, UPLO - INTEGER INFO, LDA, LIWORK, LWORK, N -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. -* - LOGICAL LOWER, LQUERY, WANTZ - INTEGER IINFO, INDE, INDTAU, INDWK2, INDWRK, ISCALE, - $ LIOPT, LIWMIN, LLWORK, LLWRK2, LOPT, LWMIN - DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, - $ SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL LSAME, DLAMCH, DLANSY, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DLACPY, DLASCL, DORMTR, DSCAL, DSTEDC, DSTERF, - $ DSYTRD, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) - LOWER = LSAME( UPLO, 'L' ) - LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) -* - INFO = 0 - IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( N.LE.1 ) THEN - LIWMIN = 1 - LWMIN = 1 - LOPT = LWMIN - LIOPT = LIWMIN - ELSE - IF( WANTZ ) THEN - LIWMIN = 3 + 5*N - LWMIN = 1 + 6*N + 2*N**2 - ELSE - LIWMIN = 1 - LWMIN = 2*N + 1 - END IF - LOPT = MAX( LWMIN, 2*N + - $ N*ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) ) - LIOPT = LIWMIN - END IF - WORK( 1 ) = LOPT - IWORK( 1 ) = LIOPT -* - IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN - INFO = -8 - ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN - INFO = -10 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYEVD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( N.EQ.1 ) THEN - W( 1 ) = A( 1, 1 ) - IF( WANTZ ) - $ A( 1, 1 ) = ONE - RETURN - END IF -* -* Get machine constants. -* - SAFMIN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Precision' ) - SMLNUM = SAFMIN / EPS - BIGNUM = ONE / SMLNUM - RMIN = SQRT( SMLNUM ) - RMAX = SQRT( BIGNUM ) -* -* Scale matrix to allowable range, if necessary. -* - ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) - ISCALE = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN - ISCALE = 1 - SIGMA = RMIN / ANRM - ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 - SIGMA = RMAX / ANRM - END IF - IF( ISCALE.EQ.1 ) - $ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) -* -* Call DSYTRD to reduce symmetric matrix to tridiagonal form. -* - INDE = 1 - INDTAU = INDE + N - INDWRK = INDTAU + N - LLWORK = LWORK - INDWRK + 1 - INDWK2 = INDWRK + N*N - LLWRK2 = LWORK - INDWK2 + 1 -* - CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ), - $ WORK( INDWRK ), LLWORK, IINFO ) -* -* For eigenvalues only, call DSTERF. For eigenvectors, first call -* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the -* tridiagonal matrix, then call DORMTR to multiply it by the -* Householder transformations stored in A. -* - IF( .NOT.WANTZ ) THEN - CALL DSTERF( N, W, WORK( INDE ), INFO ) - ELSE - CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N, - $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO ) - CALL DORMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ), - $ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO ) - CALL DLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA ) - END IF -* -* If matrix was scaled, then rescale eigenvalues appropriately. -* - IF( ISCALE.EQ.1 ) - $ CALL DSCAL( N, ONE / SIGMA, W, 1 ) -* - WORK( 1 ) = LOPT - IWORK( 1 ) = LIOPT -* - RETURN -* -* End of DSYEVD -* - END diff --git a/lib/linalg/fortran/dsygs2.f b/lib/linalg/fortran/dsygs2.f deleted file mode 100644 index 8a39bea77e..0000000000 --- a/lib/linalg/fortran/dsygs2.f +++ /dev/null @@ -1,280 +0,0 @@ -*> \brief \b DSYGS2 reduces a symmetric definite generalized eigenproblem to standard form, using the factorization results obtained from spotrf (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSYGS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, ITYPE, LDA, LDB, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYGS2 reduces a real symmetric-definite generalized eigenproblem -*> to standard form. -*> -*> If ITYPE = 1, the problem is A*x = lambda*B*x, -*> and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) -*> -*> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or -*> B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T *A*L. -*> -*> B must have been previously factorized as U**T *U or L*L**T by DPOTRF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ITYPE -*> \verbatim -*> ITYPE is INTEGER -*> = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); -*> = 2 or 3: compute U*A*U**T or L**T *A*L. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies whether the upper or lower triangular part of the -*> symmetric matrix A is stored, and how B has been factorized. -*> = 'U': Upper triangular -*> = 'L': Lower triangular -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrices A and B. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the leading -*> n by n upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading n by n lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> -*> On exit, if INFO = 0, the transformed matrix, stored in the -*> same format as A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,N) -*> The triangular factor from the Cholesky factorization of B, -*> as returned by DPOTRF. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,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. -* -*> \ingroup doubleSYcomputational -* -* ===================================================================== - SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, ITYPE, LDA, LDB, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, HALF - PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER K - DOUBLE PRECISION AKK, BKK, CT -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DSCAL, DSYR2, DTRMV, DTRSV, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN - INFO = -1 - ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYGS2', -INFO ) - RETURN - END IF -* - IF( ITYPE.EQ.1 ) THEN - IF( UPPER ) THEN -* -* Compute inv(U**T)*A*inv(U) -* - DO 10 K = 1, N -* -* Update the upper triangle of A(k:n,k:n) -* - AKK = A( K, K ) - BKK = B( K, K ) - AKK = AKK / BKK**2 - A( K, K ) = AKK - IF( K.LT.N ) THEN - CALL DSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA ) - CT = -HALF*AKK - CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), - $ LDA ) - CALL DSYR2( UPLO, N-K, -ONE, A( K, K+1 ), LDA, - $ B( K, K+1 ), LDB, A( K+1, K+1 ), LDA ) - CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), - $ LDA ) - CALL DTRSV( UPLO, 'Transpose', 'Non-unit', N-K, - $ B( K+1, K+1 ), LDB, A( K, K+1 ), LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute inv(L)*A*inv(L**T) -* - DO 20 K = 1, N -* -* Update the lower triangle of A(k:n,k:n) -* - AKK = A( K, K ) - BKK = B( K, K ) - AKK = AKK / BKK**2 - A( K, K ) = AKK - IF( K.LT.N ) THEN - CALL DSCAL( N-K, ONE / BKK, A( K+1, K ), 1 ) - CT = -HALF*AKK - CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 ) - CALL DSYR2( UPLO, N-K, -ONE, A( K+1, K ), 1, - $ B( K+1, K ), 1, A( K+1, K+1 ), LDA ) - CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 ) - CALL DTRSV( UPLO, 'No transpose', 'Non-unit', N-K, - $ B( K+1, K+1 ), LDB, A( K+1, K ), 1 ) - END IF - 20 CONTINUE - END IF - ELSE - IF( UPPER ) THEN -* -* Compute U*A*U**T -* - DO 30 K = 1, N -* -* Update the upper triangle of A(1:k,1:k) -* - AKK = A( K, K ) - BKK = B( K, K ) - CALL DTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B, - $ LDB, A( 1, K ), 1 ) - CT = HALF*AKK - CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 ) - CALL DSYR2( UPLO, K-1, ONE, A( 1, K ), 1, B( 1, K ), 1, - $ A, LDA ) - CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 ) - CALL DSCAL( K-1, BKK, A( 1, K ), 1 ) - A( K, K ) = AKK*BKK**2 - 30 CONTINUE - ELSE -* -* Compute L**T *A*L -* - DO 40 K = 1, N -* -* Update the lower triangle of A(1:k,1:k) -* - AKK = A( K, K ) - BKK = B( K, K ) - CALL DTRMV( UPLO, 'Transpose', 'Non-unit', K-1, B, LDB, - $ A( K, 1 ), LDA ) - CT = HALF*AKK - CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA ) - CALL DSYR2( UPLO, K-1, ONE, A( K, 1 ), LDA, B( K, 1 ), - $ LDB, A, LDA ) - CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA ) - CALL DSCAL( K-1, BKK, A( K, 1 ), LDA ) - A( K, K ) = AKK*BKK**2 - 40 CONTINUE - END IF - END IF - RETURN -* -* End of DSYGS2 -* - END diff --git a/lib/linalg/fortran/dsygst.f b/lib/linalg/fortran/dsygst.f deleted file mode 100644 index 05b90372ab..0000000000 --- a/lib/linalg/fortran/dsygst.f +++ /dev/null @@ -1,318 +0,0 @@ -*> \brief \b DSYGST -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSYGST + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, ITYPE, LDA, LDB, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYGST reduces a real symmetric-definite generalized eigenproblem -*> to standard form. -*> -*> If ITYPE = 1, the problem is A*x = lambda*B*x, -*> and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) -*> -*> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or -*> B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. -*> -*> B must have been previously factorized as U**T*U or L*L**T by DPOTRF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ITYPE -*> \verbatim -*> ITYPE is INTEGER -*> = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); -*> = 2 or 3: compute U*A*U**T or L**T*A*L. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored and B is factored as -*> U**T*U; -*> = 'L': Lower triangle of A is stored and B is factored as -*> L*L**T. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrices A and B. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the leading -*> N-by-N upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading N-by-N lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> -*> On exit, if INFO = 0, the transformed matrix, stored in the -*> same format as A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,N) -*> The triangular factor from the Cholesky factorization of B, -*> as returned by DPOTRF. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,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. -* -*> \ingroup doubleSYcomputational -* -* ===================================================================== - SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, ITYPE, LDA, LDB, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, HALF - PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER K, KB, NB -* .. -* .. External Subroutines .. - EXTERNAL DSYGS2, DSYMM, DSYR2K, DTRMM, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN - INFO = -1 - ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYGST', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DSYGST', UPLO, N, -1, -1, -1 ) -* - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) - ELSE -* -* Use blocked code -* - IF( ITYPE.EQ.1 ) THEN - IF( UPPER ) THEN -* -* Compute inv(U**T)*A*inv(U) -* - DO 10 K = 1, N, NB - KB = MIN( N-K+1, NB ) -* -* Update the upper triangle of A(k:n,k:n) -* - CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, - $ B( K, K ), LDB, INFO ) - IF( K+KB.LE.N ) THEN - CALL DTRSM( 'Left', UPLO, 'Transpose', 'Non-unit', - $ KB, N-K-KB+1, ONE, B( K, K ), LDB, - $ A( K, K+KB ), LDA ) - CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, - $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE, - $ A( K, K+KB ), LDA ) - CALL DSYR2K( UPLO, 'Transpose', N-K-KB+1, KB, -ONE, - $ A( K, K+KB ), LDA, B( K, K+KB ), LDB, - $ ONE, A( K+KB, K+KB ), LDA ) - CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, - $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE, - $ A( K, K+KB ), LDA ) - CALL DTRSM( 'Right', UPLO, 'No transpose', - $ 'Non-unit', KB, N-K-KB+1, ONE, - $ B( K+KB, K+KB ), LDB, A( K, K+KB ), - $ LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute inv(L)*A*inv(L**T) -* - DO 20 K = 1, N, NB - KB = MIN( N-K+1, NB ) -* -* Update the lower triangle of A(k:n,k:n) -* - CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, - $ B( K, K ), LDB, INFO ) - IF( K+KB.LE.N ) THEN - CALL DTRSM( 'Right', UPLO, 'Transpose', 'Non-unit', - $ N-K-KB+1, KB, ONE, B( K, K ), LDB, - $ A( K+KB, K ), LDA ) - CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, - $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE, - $ A( K+KB, K ), LDA ) - CALL DSYR2K( UPLO, 'No transpose', N-K-KB+1, KB, - $ -ONE, A( K+KB, K ), LDA, B( K+KB, K ), - $ LDB, ONE, A( K+KB, K+KB ), LDA ) - CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, - $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE, - $ A( K+KB, K ), LDA ) - CALL DTRSM( 'Left', UPLO, 'No transpose', - $ 'Non-unit', N-K-KB+1, KB, ONE, - $ B( K+KB, K+KB ), LDB, A( K+KB, K ), - $ LDA ) - END IF - 20 CONTINUE - END IF - ELSE - IF( UPPER ) THEN -* -* Compute U*A*U**T -* - DO 30 K = 1, N, NB - KB = MIN( N-K+1, NB ) -* -* Update the upper triangle of A(1:k+kb-1,1:k+kb-1) -* - CALL DTRMM( 'Left', UPLO, 'No transpose', 'Non-unit', - $ K-1, KB, ONE, B, LDB, A( 1, K ), LDA ) - CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), - $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA ) - CALL DSYR2K( UPLO, 'No transpose', K-1, KB, ONE, - $ A( 1, K ), LDA, B( 1, K ), LDB, ONE, A, - $ LDA ) - CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), - $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA ) - CALL DTRMM( 'Right', UPLO, 'Transpose', 'Non-unit', - $ K-1, KB, ONE, B( K, K ), LDB, A( 1, K ), - $ LDA ) - CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, - $ B( K, K ), LDB, INFO ) - 30 CONTINUE - ELSE -* -* Compute L**T*A*L -* - DO 40 K = 1, N, NB - KB = MIN( N-K+1, NB ) -* -* Update the lower triangle of A(1:k+kb-1,1:k+kb-1) -* - CALL DTRMM( 'Right', UPLO, 'No transpose', 'Non-unit', - $ KB, K-1, ONE, B, LDB, A( K, 1 ), LDA ) - CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), - $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA ) - CALL DSYR2K( UPLO, 'Transpose', K-1, KB, ONE, - $ A( K, 1 ), LDA, B( K, 1 ), LDB, ONE, A, - $ LDA ) - CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), - $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA ) - CALL DTRMM( 'Left', UPLO, 'Transpose', 'Non-unit', KB, - $ K-1, ONE, B( K, K ), LDB, A( K, 1 ), LDA ) - CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, - $ B( K, K ), LDB, INFO ) - 40 CONTINUE - END IF - END IF - END IF - RETURN -* -* End of DSYGST -* - END diff --git a/lib/linalg/fortran/dsygv.f b/lib/linalg/fortran/dsygv.f deleted file mode 100644 index 5208dbb1f1..0000000000 --- a/lib/linalg/fortran/dsygv.f +++ /dev/null @@ -1,311 +0,0 @@ -*> \brief \b DSYGV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSYGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYGV computes all the eigenvalues, and optionally, the eigenvectors -*> of a real generalized symmetric-definite eigenproblem, of the form -*> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. -*> Here A and B are assumed to be symmetric and B is also -*> positive definite. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ITYPE -*> \verbatim -*> ITYPE is INTEGER -*> Specifies the problem type to be solved: -*> = 1: A*x = (lambda)*B*x -*> = 2: A*B*x = (lambda)*x -*> = 3: B*A*x = (lambda)*x -*> \endverbatim -*> -*> \param[in] JOBZ -*> \verbatim -*> JOBZ is CHARACTER*1 -*> = 'N': Compute eigenvalues only; -*> = 'V': Compute eigenvalues and eigenvectors. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangles of A and B are stored; -*> = 'L': Lower triangles of A and B are stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrices A and B. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA, N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the -*> leading N-by-N upper triangular part of A contains the -*> upper triangular part of the matrix A. If UPLO = 'L', -*> the leading N-by-N lower triangular part of A contains -*> the lower triangular part of the matrix A. -*> -*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the -*> matrix Z of eigenvectors. The eigenvectors are normalized -*> as follows: -*> if ITYPE = 1 or 2, Z**T*B*Z = I; -*> if ITYPE = 3, Z**T*inv(B)*Z = I. -*> If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') -*> or the lower triangle (if UPLO='L') of A, including the -*> diagonal, is destroyed. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB, N) -*> On entry, the symmetric positive definite matrix B. -*> If UPLO = 'U', the leading N-by-N upper triangular part of B -*> contains the upper triangular part of the matrix B. -*> If UPLO = 'L', the leading N-by-N lower triangular part of B -*> contains the lower triangular part of the matrix B. -*> -*> On exit, if INFO <= N, the part of B containing the matrix is -*> overwritten by the triangular factor U or L from the Cholesky -*> factorization B = U**T*U or B = L*L**T. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,N). -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (N) -*> If INFO = 0, the eigenvalues in ascending order. -*> \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 length of the array WORK. LWORK >= max(1,3*N-1). -*> For optimal efficiency, LWORK >= (NB+2)*N, -*> where NB is the blocksize for DSYTRD returned by ILAENV. -*> -*> 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: DPOTRF or DSYEV returned an error code: -*> <= N: if INFO = i, DSYEV failed to converge; -*> i off-diagonal elements of an intermediate -*> tridiagonal form did not converge to zero; -*> > N: if INFO = N + i, for 1 <= i <= N, then the leading -*> minor of order i of B is not positive definite. -*> The factorization of B could not be completed and -*> no eigenvalues or eigenvectors were computed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleSYeigen -* -* ===================================================================== - SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, - $ LWORK, INFO ) -* -* -- LAPACK driver routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER JOBZ, UPLO - INTEGER INFO, ITYPE, LDA, LDB, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, UPPER, WANTZ - CHARACTER TRANS - INTEGER LWKMIN, LWKOPT, NB, NEIG -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DPOTRF, DSYEV, DSYGST, DTRMM, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) - UPPER = LSAME( UPLO, 'U' ) - LQUERY = ( LWORK.EQ.-1 ) -* - INFO = 0 - IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN - INFO = -1 - ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF -* - IF( INFO.EQ.0 ) THEN - LWKMIN = MAX( 1, 3*N - 1 ) - NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) - LWKOPT = MAX( LWKMIN, ( NB + 2 )*N ) - WORK( 1 ) = LWKOPT -* - IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN - INFO = -11 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYGV ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Form a Cholesky factorization of B. -* - CALL DPOTRF( UPLO, N, B, LDB, INFO ) - IF( INFO.NE.0 ) THEN - INFO = N + INFO - RETURN - END IF -* -* Transform problem to standard eigenvalue problem and solve. -* - CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) - CALL DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) -* - IF( WANTZ ) THEN -* -* Backtransform eigenvectors to the original problem. -* - NEIG = N - IF( INFO.GT.0 ) - $ NEIG = INFO - 1 - IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN -* -* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; -* backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y -* - IF( UPPER ) THEN - TRANS = 'N' - ELSE - TRANS = 'T' - END IF -* - CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, - $ B, LDB, A, LDA ) -* - ELSE IF( ITYPE.EQ.3 ) THEN -* -* For B*A*x=(lambda)*x; -* backtransform eigenvectors: x = L*y or U**T*y -* - IF( UPPER ) THEN - TRANS = 'T' - ELSE - TRANS = 'N' - END IF -* - CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, - $ B, LDB, A, LDA ) - END IF - END IF -* - WORK( 1 ) = LWKOPT - RETURN -* -* End of DSYGV -* - END diff --git a/lib/linalg/fortran/dsygvd.f b/lib/linalg/fortran/dsygvd.f deleted file mode 100644 index 3b38665a75..0000000000 --- a/lib/linalg/fortran/dsygvd.f +++ /dev/null @@ -1,377 +0,0 @@ -*> \brief \b DSYGVD -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSYGVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* .. -* .. Array Arguments .. -* INTEGER IWORK( * ) -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYGVD computes all the eigenvalues, and optionally, the eigenvectors -*> of a real generalized symmetric-definite eigenproblem, of the form -*> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and -*> B are assumed to be symmetric and B is also positive definite. -*> If eigenvectors are desired, it uses a divide and conquer algorithm. -*> -*> 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] ITYPE -*> \verbatim -*> ITYPE is INTEGER -*> Specifies the problem type to be solved: -*> = 1: A*x = (lambda)*B*x -*> = 2: A*B*x = (lambda)*x -*> = 3: B*A*x = (lambda)*x -*> \endverbatim -*> -*> \param[in] JOBZ -*> \verbatim -*> JOBZ is CHARACTER*1 -*> = 'N': Compute eigenvalues only; -*> = 'V': Compute eigenvalues and eigenvectors. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangles of A and B are stored; -*> = 'L': Lower triangles of A and B are stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrices A and B. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA, N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the -*> leading N-by-N upper triangular part of A contains the -*> upper triangular part of the matrix A. If UPLO = 'L', -*> the leading N-by-N lower triangular part of A contains -*> the lower triangular part of the matrix A. -*> -*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the -*> matrix Z of eigenvectors. The eigenvectors are normalized -*> as follows: -*> if ITYPE = 1 or 2, Z**T*B*Z = I; -*> if ITYPE = 3, Z**T*inv(B)*Z = I. -*> If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') -*> or the lower triangle (if UPLO='L') of A, including the -*> diagonal, is destroyed. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB, N) -*> On entry, the symmetric matrix B. If UPLO = 'U', the -*> leading N-by-N upper triangular part of B contains the -*> upper triangular part of the matrix B. If UPLO = 'L', -*> the leading N-by-N lower triangular part of B contains -*> the lower triangular part of the matrix B. -*> -*> On exit, if INFO <= N, the part of B containing the matrix is -*> overwritten by the triangular factor U or L from the Cholesky -*> factorization B = U**T*U or B = L*L**T. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,N). -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (N) -*> If INFO = 0, the eigenvalues in ascending order. -*> \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. -*> If N <= 1, LWORK >= 1. -*> If JOBZ = 'N' and N > 1, LWORK >= 2*N+1. -*> If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal sizes of the WORK and IWORK -*> arrays, returns these values as the first entries of the WORK -*> and IWORK arrays, and no error message related to LWORK or -*> LIWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) -*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. -*> \endverbatim -*> -*> \param[in] LIWORK -*> \verbatim -*> LIWORK is INTEGER -*> The dimension of the array IWORK. -*> If N <= 1, LIWORK >= 1. -*> If JOBZ = 'N' and N > 1, LIWORK >= 1. -*> If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. -*> -*> If LIWORK = -1, then a workspace query is assumed; the -*> routine only calculates the optimal sizes of the WORK and -*> IWORK arrays, returns these values as the first entries of -*> the WORK and IWORK arrays, and no error message related to -*> LWORK or LIWORK 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: DPOTRF or DSYEVD returned an error code: -*> <= N: if INFO = i and JOBZ = 'N', then the algorithm -*> failed to converge; i off-diagonal elements of an -*> intermediate tridiagonal form did not converge to -*> zero; -*> if INFO = i and JOBZ = 'V', then the algorithm -*> failed to compute an eigenvalue while working on -*> the submatrix lying in rows and columns INFO/(N+1) -*> through mod(INFO,N+1); -*> > N: if INFO = N + i, for 1 <= i <= N, then the leading -*> minor of order i of B is not positive definite. -*> The factorization of B could not be completed and -*> no eigenvalues or eigenvectors were computed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleSYeigen -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Modified so that no backsubstitution is performed if DSYEVD fails to -*> converge (NEIG in old code could be greater than N causing out of -*> bounds reference to A - reported by Ralf Meyer). Also corrected the -*> description of INFO and the test on ITYPE. Sven, 16 Feb 05. -*> \endverbatim -* -*> \par Contributors: -* ================== -*> -*> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA -*> -* ===================================================================== - SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, - $ LWORK, IWORK, LIWORK, INFO ) -* -* -- LAPACK driver routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER JOBZ, UPLO - INTEGER INFO, ITYPE, LDA, LDB, LIWORK, LWORK, N -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, UPPER, WANTZ - CHARACTER TRANS - INTEGER LIOPT, LIWMIN, LOPT, LWMIN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DPOTRF, DSYEVD, DSYGST, DTRMM, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) - UPPER = LSAME( UPLO, 'U' ) - LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) -* - INFO = 0 - IF( N.LE.1 ) THEN - LIWMIN = 1 - LWMIN = 1 - ELSE IF( WANTZ ) THEN - LIWMIN = 3 + 5*N - LWMIN = 1 + 6*N + 2*N**2 - ELSE - LIWMIN = 1 - LWMIN = 2*N + 1 - END IF - LOPT = LWMIN - LIOPT = LIWMIN - IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN - INFO = -1 - ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF -* - IF( INFO.EQ.0 ) THEN - WORK( 1 ) = LOPT - IWORK( 1 ) = LIOPT -* - IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN - INFO = -11 - ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYGVD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Form a Cholesky factorization of B. -* - CALL DPOTRF( UPLO, N, B, LDB, INFO ) - IF( INFO.NE.0 ) THEN - INFO = N + INFO - RETURN - END IF -* -* Transform problem to standard eigenvalue problem and solve. -* - CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) - CALL DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK, - $ INFO ) - LOPT = INT( MAX( DBLE( LOPT ), DBLE( WORK( 1 ) ) ) ) - LIOPT = INT( MAX( DBLE( LIOPT ), DBLE( IWORK( 1 ) ) ) ) -* - IF( WANTZ .AND. INFO.EQ.0 ) THEN -* -* Backtransform eigenvectors to the original problem. -* - IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN -* -* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; -* backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y -* - IF( UPPER ) THEN - TRANS = 'N' - ELSE - TRANS = 'T' - END IF -* - CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, N, ONE, - $ B, LDB, A, LDA ) -* - ELSE IF( ITYPE.EQ.3 ) THEN -* -* For B*A*x=(lambda)*x; -* backtransform eigenvectors: x = L*y or U**T*y -* - IF( UPPER ) THEN - TRANS = 'T' - ELSE - TRANS = 'N' - END IF -* - CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, N, ONE, - $ B, LDB, A, LDA ) - END IF - END IF -* - WORK( 1 ) = LOPT - IWORK( 1 ) = LIOPT -* - RETURN -* -* End of DSYGVD -* - END diff --git a/lib/linalg/fortran/dsymm.f b/lib/linalg/fortran/dsymm.f deleted file mode 100644 index 683e79f6ad..0000000000 --- a/lib/linalg/fortran/dsymm.f +++ /dev/null @@ -1,364 +0,0 @@ -*> \brief \b DSYMM -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA,BETA -* INTEGER LDA,LDB,LDC,M,N -* CHARACTER SIDE,UPLO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYMM performs one of the matrix-matrix operations -*> -*> C := alpha*A*B + beta*C, -*> -*> or -*> -*> C := alpha*B*A + beta*C, -*> -*> where alpha and beta are scalars, A is a symmetric matrix and B and -*> C are m by n matrices. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> On entry, SIDE specifies whether the symmetric matrix A -*> appears on the left or right in the operation as follows: -*> -*> SIDE = 'L' or 'l' C := alpha*A*B + beta*C, -*> -*> SIDE = 'R' or 'r' C := alpha*B*A + beta*C, -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the upper or lower -*> triangular part of the symmetric matrix A is to be -*> referenced as follows: -*> -*> UPLO = 'U' or 'u' Only the upper triangular part of the -*> symmetric matrix is to be referenced. -*> -*> UPLO = 'L' or 'l' Only the lower triangular part of the -*> symmetric matrix is to be referenced. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of the matrix C. -*> M must be at least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of the matrix C. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is -*> m when SIDE = 'L' or 'l' and is n otherwise. -*> Before entry with SIDE = 'L' or 'l', the m by m part of -*> the array A must contain the symmetric matrix, such that -*> when UPLO = 'U' or 'u', the leading m by m upper triangular -*> part of the array A must contain the upper triangular part -*> of the symmetric matrix and the strictly lower triangular -*> part of A is not referenced, and when UPLO = 'L' or 'l', -*> the leading m by m lower triangular part of the array A -*> must contain the lower triangular part of the symmetric -*> matrix and the strictly upper triangular part of A is not -*> referenced. -*> Before entry with SIDE = 'R' or 'r', the n by n part of -*> the array A must contain the symmetric matrix, such that -*> when UPLO = 'U' or 'u', the leading n by n upper triangular -*> part of the array A must contain the upper triangular part -*> of the symmetric matrix and the strictly lower triangular -*> part of A is not referenced, and when UPLO = 'L' or 'l', -*> the leading n by n lower triangular part of the array A -*> must contain the lower triangular part of the symmetric -*> matrix and the strictly upper triangular part of A is not -*> referenced. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. When SIDE = 'L' or 'l' then -*> LDA must be at least max( 1, m ), otherwise LDA must be at -*> least max( 1, n ). -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension ( LDB, N ) -*> Before entry, the leading m by n part of the array B must -*> contain the matrix B. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> On entry, LDB specifies the first dimension of B as declared -*> in the calling (sub) program. LDB must be at least -*> max( 1, m ). -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is DOUBLE PRECISION. -*> On entry, BETA specifies the scalar beta. When BETA is -*> supplied as zero then C need not be set on input. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension ( LDC, N ) -*> Before entry, the leading m by n part of the array C must -*> contain the matrix C, except when beta is zero, in which -*> case C need not be set on entry. -*> On exit, the array C is overwritten by the m by n updated -*> matrix. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> On entry, LDC specifies the first dimension of C as declared -*> in the calling (sub) program. LDC must be at least -*> max( 1, m ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level3 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 3 Blas routine. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* -- Reference BLAS level3 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA,BETA - INTEGER LDA,LDB,LDC,M,N - CHARACTER SIDE,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP1,TEMP2 - INTEGER I,INFO,J,K,NROWA - LOGICAL UPPER -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Set NROWA as the number of rows of A. -* - IF (LSAME(SIDE,'L')) THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME(UPLO,'U') -* -* Test the input parameters. -* - INFO = 0 - IF ((.NOT.LSAME(SIDE,'L')) .AND. (.NOT.LSAME(SIDE,'R'))) THEN - INFO = 1 - ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 2 - ELSE IF (M.LT.0) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 7 - ELSE IF (LDB.LT.MAX(1,M)) THEN - INFO = 9 - ELSE IF (LDC.LT.MAX(1,M)) THEN - INFO = 12 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DSYMM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. - + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - IF (BETA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - C(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1,N - DO 30 I = 1,M - C(I,J) = BETA*C(I,J) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF (LSAME(SIDE,'L')) THEN -* -* Form C := alpha*A*B + beta*C. -* - IF (UPPER) THEN - DO 70 J = 1,N - DO 60 I = 1,M - TEMP1 = ALPHA*B(I,J) - TEMP2 = ZERO - DO 50 K = 1,I - 1 - C(K,J) = C(K,J) + TEMP1*A(K,I) - TEMP2 = TEMP2 + B(K,J)*A(K,I) - 50 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2 - ELSE - C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) + - + ALPHA*TEMP2 - END IF - 60 CONTINUE - 70 CONTINUE - ELSE - DO 100 J = 1,N - DO 90 I = M,1,-1 - TEMP1 = ALPHA*B(I,J) - TEMP2 = ZERO - DO 80 K = I + 1,M - C(K,J) = C(K,J) + TEMP1*A(K,I) - TEMP2 = TEMP2 + B(K,J)*A(K,I) - 80 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2 - ELSE - C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) + - + ALPHA*TEMP2 - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form C := alpha*B*A + beta*C. -* - DO 170 J = 1,N - TEMP1 = ALPHA*A(J,J) - IF (BETA.EQ.ZERO) THEN - DO 110 I = 1,M - C(I,J) = TEMP1*B(I,J) - 110 CONTINUE - ELSE - DO 120 I = 1,M - C(I,J) = BETA*C(I,J) + TEMP1*B(I,J) - 120 CONTINUE - END IF - DO 140 K = 1,J - 1 - IF (UPPER) THEN - TEMP1 = ALPHA*A(K,J) - ELSE - TEMP1 = ALPHA*A(J,K) - END IF - DO 130 I = 1,M - C(I,J) = C(I,J) + TEMP1*B(I,K) - 130 CONTINUE - 140 CONTINUE - DO 160 K = J + 1,N - IF (UPPER) THEN - TEMP1 = ALPHA*A(J,K) - ELSE - TEMP1 = ALPHA*A(K,J) - END IF - DO 150 I = 1,M - C(I,J) = C(I,J) + TEMP1*B(I,K) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - END IF -* - RETURN -* -* End of DSYMM -* - END diff --git a/lib/linalg/fortran/dsymv.f b/lib/linalg/fortran/dsymv.f deleted file mode 100644 index 17310d7c62..0000000000 --- a/lib/linalg/fortran/dsymv.f +++ /dev/null @@ -1,330 +0,0 @@ -*> \brief \b DSYMV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA,BETA -* INTEGER INCX,INCY,LDA,N -* CHARACTER UPLO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYMV performs the matrix-vector operation -*> -*> y := alpha*A*x + beta*y, -*> -*> where alpha and beta are scalars, x and y are n element vectors and -*> A is an n by n symmetric matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the upper or lower -*> triangular part of the array A is to be referenced as -*> follows: -*> -*> UPLO = 'U' or 'u' Only the upper triangular part of A -*> is to be referenced. -*> -*> UPLO = 'L' or 'l' Only the lower triangular part of A -*> is to be referenced. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, N ) -*> Before entry with UPLO = 'U' or 'u', the leading n by n -*> upper triangular part of the array A must contain the upper -*> triangular part of the symmetric matrix and the strictly -*> lower triangular part of A is not referenced. -*> Before entry with UPLO = 'L' or 'l', the leading n by n -*> lower triangular part of the array A must contain the lower -*> triangular part of the symmetric matrix and the strictly -*> upper triangular part of A is not referenced. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, n ). -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCX ) ). -*> Before entry, the incremented array X must contain the n -*> element vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is DOUBLE PRECISION. -*> On entry, BETA specifies the scalar beta. When BETA is -*> supplied as zero then Y need not be set on input. -*> \endverbatim -*> -*> \param[in,out] Y -*> \verbatim -*> Y is DOUBLE PRECISION array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCY ) ). -*> Before entry, the incremented array Y must contain the n -*> element vector y. On exit, Y is overwritten by the updated -*> vector y. -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> On entry, INCY specifies the increment for the elements of -*> Y. INCY must not be zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> The vector and matrix arguments are not referenced when N = 0, or M = 0 -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA,BETA - INTEGER INCX,INCY,LDA,N - CHARACTER UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP1,TEMP2 - INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (N.LT.0) THEN - INFO = 2 - ELSE IF (LDA.LT.MAX(1,N)) THEN - INFO = 5 - ELSE IF (INCX.EQ.0) THEN - INFO = 7 - ELSE IF (INCY.EQ.0) THEN - INFO = 10 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DSYMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN -* -* Set up the start points in X and Y. -* - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (N-1)*INCX - END IF - IF (INCY.GT.0) THEN - KY = 1 - ELSE - KY = 1 - (N-1)*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* -* First form y := beta*y. -* - IF (BETA.NE.ONE) THEN - IF (INCY.EQ.1) THEN - IF (BETA.EQ.ZERO) THEN - DO 10 I = 1,N - Y(I) = ZERO - 10 CONTINUE - ELSE - DO 20 I = 1,N - Y(I) = BETA*Y(I) - 20 CONTINUE - END IF - ELSE - IY = KY - IF (BETA.EQ.ZERO) THEN - DO 30 I = 1,N - Y(IY) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40 I = 1,N - Y(IY) = BETA*Y(IY) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF (ALPHA.EQ.ZERO) RETURN - IF (LSAME(UPLO,'U')) THEN -* -* Form y when A is stored in upper triangle. -* - IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN - DO 60 J = 1,N - TEMP1 = ALPHA*X(J) - TEMP2 = ZERO - DO 50 I = 1,J - 1 - Y(I) = Y(I) + TEMP1*A(I,J) - TEMP2 = TEMP2 + A(I,J)*X(I) - 50 CONTINUE - Y(J) = Y(J) + TEMP1*A(J,J) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80 J = 1,N - TEMP1 = ALPHA*X(JX) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70 I = 1,J - 1 - Y(IY) = Y(IY) + TEMP1*A(I,J) - TEMP2 = TEMP2 + A(I,J)*X(IX) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y(JY) = Y(JY) + TEMP1*A(J,J) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y when A is stored in lower triangle. -* - IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN - DO 100 J = 1,N - TEMP1 = ALPHA*X(J) - TEMP2 = ZERO - Y(J) = Y(J) + TEMP1*A(J,J) - DO 90 I = J + 1,N - Y(I) = Y(I) + TEMP1*A(I,J) - TEMP2 = TEMP2 + A(I,J)*X(I) - 90 CONTINUE - Y(J) = Y(J) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120 J = 1,N - TEMP1 = ALPHA*X(JX) - TEMP2 = ZERO - Y(JY) = Y(JY) + TEMP1*A(J,J) - IX = JX - IY = JY - DO 110 I = J + 1,N - IX = IX + INCX - IY = IY + INCY - Y(IY) = Y(IY) + TEMP1*A(I,J) - TEMP2 = TEMP2 + A(I,J)*X(IX) - 110 CONTINUE - Y(JY) = Y(JY) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYMV -* - END diff --git a/lib/linalg/fortran/dsyr2.f b/lib/linalg/fortran/dsyr2.f deleted file mode 100644 index 4bad19b96b..0000000000 --- a/lib/linalg/fortran/dsyr2.f +++ /dev/null @@ -1,295 +0,0 @@ -*> \brief \b DSYR2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA -* INTEGER INCX,INCY,LDA,N -* CHARACTER UPLO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYR2 performs the symmetric rank 2 operation -*> -*> A := alpha*x*y**T + alpha*y*x**T + A, -*> -*> where alpha is a scalar, x and y are n element vectors and A is an n -*> by n symmetric matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the upper or lower -*> triangular part of the array A is to be referenced as -*> follows: -*> -*> UPLO = 'U' or 'u' Only the upper triangular part of A -*> is to be referenced. -*> -*> UPLO = 'L' or 'l' Only the lower triangular part of A -*> is to be referenced. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCX ) ). -*> Before entry, the incremented array X must contain the n -*> element vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -*> -*> \param[in] Y -*> \verbatim -*> Y is DOUBLE PRECISION array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCY ) ). -*> Before entry, the incremented array Y must contain the n -*> element vector y. -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> On entry, INCY specifies the increment for the elements of -*> Y. INCY must not be zero. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, N ) -*> Before entry with UPLO = 'U' or 'u', the leading n by n -*> upper triangular part of the array A must contain the upper -*> triangular part of the symmetric matrix and the strictly -*> lower triangular part of A is not referenced. On exit, the -*> upper triangular part of the array A is overwritten by the -*> upper triangular part of the updated matrix. -*> Before entry with UPLO = 'L' or 'l', the leading n by n -*> lower triangular part of the array A must contain the lower -*> triangular part of the symmetric matrix and the strictly -*> upper triangular part of A is not referenced. On exit, the -*> lower triangular part of the array A is overwritten by the -*> lower triangular part of the updated matrix. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, n ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX,INCY,LDA,N - CHARACTER UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER (ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP1,TEMP2 - INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (N.LT.0) THEN - INFO = 2 - ELSE IF (INCX.EQ.0) THEN - INFO = 5 - ELSE IF (INCY.EQ.0) THEN - INFO = 7 - ELSE IF (LDA.LT.MAX(1,N)) THEN - INFO = 9 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DSYR2 ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (N-1)*INCX - END IF - IF (INCY.GT.0) THEN - KY = 1 - ELSE - KY = 1 - (N-1)*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF (LSAME(UPLO,'U')) THEN -* -* Form A when A is stored in the upper triangle. -* - IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN - DO 20 J = 1,N - IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN - TEMP1 = ALPHA*Y(J) - TEMP2 = ALPHA*X(J) - DO 10 I = 1,J - A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - DO 40 J = 1,N - IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN - TEMP1 = ALPHA*Y(JY) - TEMP2 = ALPHA*X(JX) - IX = KX - IY = KY - DO 30 I = 1,J - A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in the lower triangle. -* - IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN - DO 60 J = 1,N - IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN - TEMP1 = ALPHA*Y(J) - TEMP2 = ALPHA*X(J) - DO 50 I = J,N - A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - DO 80 J = 1,N - IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN - TEMP1 = ALPHA*Y(JY) - TEMP2 = ALPHA*X(JX) - IX = JX - IY = JY - DO 70 I = J,N - A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYR2 -* - END diff --git a/lib/linalg/fortran/dsyr2k.f b/lib/linalg/fortran/dsyr2k.f deleted file mode 100644 index f5d16e0854..0000000000 --- a/lib/linalg/fortran/dsyr2k.f +++ /dev/null @@ -1,396 +0,0 @@ -*> \brief \b DSYR2K -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA,BETA -* INTEGER K,LDA,LDB,LDC,N -* CHARACTER TRANS,UPLO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYR2K performs one of the symmetric rank 2k operations -*> -*> C := alpha*A*B**T + alpha*B*A**T + beta*C, -*> -*> or -*> -*> C := alpha*A**T*B + alpha*B**T*A + beta*C, -*> -*> where alpha and beta are scalars, C is an n by n symmetric matrix -*> and A and B are n by k matrices in the first case and k by n -*> matrices in the second case. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the upper or lower -*> triangular part of the array C is to be referenced as -*> follows: -*> -*> UPLO = 'U' or 'u' Only the upper triangular part of C -*> is to be referenced. -*> -*> UPLO = 'L' or 'l' Only the lower triangular part of C -*> is to be referenced. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the operation to be performed as -*> follows: -*> -*> TRANS = 'N' or 'n' C := alpha*A*B**T + alpha*B*A**T + -*> beta*C. -*> -*> TRANS = 'T' or 't' C := alpha*A**T*B + alpha*B**T*A + -*> beta*C. -*> -*> TRANS = 'C' or 'c' C := alpha*A**T*B + alpha*B**T*A + -*> beta*C. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix C. N must be -*> at least zero. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> On entry with TRANS = 'N' or 'n', K specifies the number -*> of columns of the matrices A and B, and on entry with -*> TRANS = 'T' or 't' or 'C' or 'c', K specifies the number -*> of rows of the matrices A and B. K must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is -*> k when TRANS = 'N' or 'n', and is n otherwise. -*> Before entry with TRANS = 'N' or 'n', the leading n by k -*> part of the array A must contain the matrix A, otherwise -*> the leading k by n part of the array A must contain the -*> matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. When TRANS = 'N' or 'n' -*> then LDA must be at least max( 1, n ), otherwise LDA must -*> be at least max( 1, k ). -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension ( LDB, kb ), where kb is -*> k when TRANS = 'N' or 'n', and is n otherwise. -*> Before entry with TRANS = 'N' or 'n', the leading n by k -*> part of the array B must contain the matrix B, otherwise -*> the leading k by n part of the array B must contain the -*> matrix B. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> On entry, LDB specifies the first dimension of B as declared -*> in the calling (sub) program. When TRANS = 'N' or 'n' -*> then LDB must be at least max( 1, n ), otherwise LDB must -*> be at least max( 1, k ). -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is DOUBLE PRECISION. -*> On entry, BETA specifies the scalar beta. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension ( LDC, N ) -*> Before entry with UPLO = 'U' or 'u', the leading n by n -*> upper triangular part of the array C must contain the upper -*> triangular part of the symmetric matrix and the strictly -*> lower triangular part of C is not referenced. On exit, the -*> upper triangular part of the array C is overwritten by the -*> upper triangular part of the updated matrix. -*> Before entry with UPLO = 'L' or 'l', the leading n by n -*> lower triangular part of the array C must contain the lower -*> triangular part of the symmetric matrix and the strictly -*> upper triangular part of C is not referenced. On exit, the -*> lower triangular part of the array C is overwritten by the -*> lower triangular part of the updated matrix. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> On entry, LDC specifies the first dimension of C as declared -*> in the calling (sub) program. LDC must be at least -*> max( 1, n ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level3 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 3 Blas routine. -*> -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* -- Reference BLAS level3 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA,BETA - INTEGER K,LDA,LDB,LDC,N - CHARACTER TRANS,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP1,TEMP2 - INTEGER I,INFO,J,L,NROWA - LOGICAL UPPER -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Test the input parameters. -* - IF (LSAME(TRANS,'N')) THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME(UPLO,'U') -* - INFO = 0 - IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 1 - ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. - + (.NOT.LSAME(TRANS,'T')) .AND. - + (.NOT.LSAME(TRANS,'C'))) THEN - INFO = 2 - ELSE IF (N.LT.0) THEN - INFO = 3 - ELSE IF (K.LT.0) THEN - INFO = 4 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 7 - ELSE IF (LDB.LT.MAX(1,NROWA)) THEN - INFO = 9 - ELSE IF (LDC.LT.MAX(1,N)) THEN - INFO = 12 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DSYR2K',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. - + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - IF (UPPER) THEN - IF (BETA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,J - C(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1,N - DO 30 I = 1,J - C(I,J) = BETA*C(I,J) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF (BETA.EQ.ZERO) THEN - DO 60 J = 1,N - DO 50 I = J,N - C(I,J) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80 J = 1,N - DO 70 I = J,N - C(I,J) = BETA*C(I,J) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form C := alpha*A*B**T + alpha*B*A**T + C. -* - IF (UPPER) THEN - DO 130 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 90 I = 1,J - C(I,J) = ZERO - 90 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 100 I = 1,J - C(I,J) = BETA*C(I,J) - 100 CONTINUE - END IF - DO 120 L = 1,K - IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN - TEMP1 = ALPHA*B(J,L) - TEMP2 = ALPHA*A(J,L) - DO 110 I = 1,J - C(I,J) = C(I,J) + A(I,L)*TEMP1 + - + B(I,L)*TEMP2 - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 140 I = J,N - C(I,J) = ZERO - 140 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 150 I = J,N - C(I,J) = BETA*C(I,J) - 150 CONTINUE - END IF - DO 170 L = 1,K - IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN - TEMP1 = ALPHA*B(J,L) - TEMP2 = ALPHA*A(J,L) - DO 160 I = J,N - C(I,J) = C(I,J) + A(I,L)*TEMP1 + - + B(I,L)*TEMP2 - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A**T*B + alpha*B**T*A + C. -* - IF (UPPER) THEN - DO 210 J = 1,N - DO 200 I = 1,J - TEMP1 = ZERO - TEMP2 = ZERO - DO 190 L = 1,K - TEMP1 = TEMP1 + A(L,I)*B(L,J) - TEMP2 = TEMP2 + B(L,I)*A(L,J) - 190 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + - + ALPHA*TEMP2 - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240 J = 1,N - DO 230 I = J,N - TEMP1 = ZERO - TEMP2 = ZERO - DO 220 L = 1,K - TEMP1 = TEMP1 + A(L,I)*B(L,J) - TEMP2 = TEMP2 + B(L,I)*A(L,J) - 220 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + - + ALPHA*TEMP2 - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYR2K -* - END diff --git a/lib/linalg/fortran/dsyrk.f b/lib/linalg/fortran/dsyrk.f deleted file mode 100644 index 0548c0ce2f..0000000000 --- a/lib/linalg/fortran/dsyrk.f +++ /dev/null @@ -1,361 +0,0 @@ -*> \brief \b DSYRK -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA,BETA -* INTEGER K,LDA,LDC,N -* CHARACTER TRANS,UPLO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),C(LDC,*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYRK performs one of the symmetric rank k operations -*> -*> C := alpha*A*A**T + beta*C, -*> -*> or -*> -*> C := alpha*A**T*A + beta*C, -*> -*> where alpha and beta are scalars, C is an n by n symmetric matrix -*> and A is an n by k matrix in the first case and a k by n matrix -*> in the second case. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the upper or lower -*> triangular part of the array C is to be referenced as -*> follows: -*> -*> UPLO = 'U' or 'u' Only the upper triangular part of C -*> is to be referenced. -*> -*> UPLO = 'L' or 'l' Only the lower triangular part of C -*> is to be referenced. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the operation to be performed as -*> follows: -*> -*> TRANS = 'N' or 'n' C := alpha*A*A**T + beta*C. -*> -*> TRANS = 'T' or 't' C := alpha*A**T*A + beta*C. -*> -*> TRANS = 'C' or 'c' C := alpha*A**T*A + beta*C. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix C. N must be -*> at least zero. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> On entry with TRANS = 'N' or 'n', K specifies the number -*> of columns of the matrix A, and on entry with -*> TRANS = 'T' or 't' or 'C' or 'c', K specifies the number -*> of rows of the matrix A. K must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is -*> k when TRANS = 'N' or 'n', and is n otherwise. -*> Before entry with TRANS = 'N' or 'n', the leading n by k -*> part of the array A must contain the matrix A, otherwise -*> the leading k by n part of the array A must contain the -*> matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. When TRANS = 'N' or 'n' -*> then LDA must be at least max( 1, n ), otherwise LDA must -*> be at least max( 1, k ). -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is DOUBLE PRECISION. -*> On entry, BETA specifies the scalar beta. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension ( LDC, N ) -*> Before entry with UPLO = 'U' or 'u', the leading n by n -*> upper triangular part of the array C must contain the upper -*> triangular part of the symmetric matrix and the strictly -*> lower triangular part of C is not referenced. On exit, the -*> upper triangular part of the array C is overwritten by the -*> upper triangular part of the updated matrix. -*> Before entry with UPLO = 'L' or 'l', the leading n by n -*> lower triangular part of the array C must contain the lower -*> triangular part of the symmetric matrix and the strictly -*> upper triangular part of C is not referenced. On exit, the -*> lower triangular part of the array C is overwritten by the -*> lower triangular part of the updated matrix. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> On entry, LDC specifies the first dimension of C as declared -*> in the calling (sub) program. LDC must be at least -*> max( 1, n ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level3 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 3 Blas routine. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) -* -* -- Reference BLAS level3 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA,BETA - INTEGER K,LDA,LDC,N - CHARACTER TRANS,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),C(LDC,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,J,L,NROWA - LOGICAL UPPER -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Test the input parameters. -* - IF (LSAME(TRANS,'N')) THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME(UPLO,'U') -* - INFO = 0 - IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 1 - ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. - + (.NOT.LSAME(TRANS,'T')) .AND. - + (.NOT.LSAME(TRANS,'C'))) THEN - INFO = 2 - ELSE IF (N.LT.0) THEN - INFO = 3 - ELSE IF (K.LT.0) THEN - INFO = 4 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 7 - ELSE IF (LDC.LT.MAX(1,N)) THEN - INFO = 10 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DSYRK ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. - + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - IF (UPPER) THEN - IF (BETA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,J - C(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1,N - DO 30 I = 1,J - C(I,J) = BETA*C(I,J) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF (BETA.EQ.ZERO) THEN - DO 60 J = 1,N - DO 50 I = J,N - C(I,J) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80 J = 1,N - DO 70 I = J,N - C(I,J) = BETA*C(I,J) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form C := alpha*A*A**T + beta*C. -* - IF (UPPER) THEN - DO 130 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 90 I = 1,J - C(I,J) = ZERO - 90 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 100 I = 1,J - C(I,J) = BETA*C(I,J) - 100 CONTINUE - END IF - DO 120 L = 1,K - IF (A(J,L).NE.ZERO) THEN - TEMP = ALPHA*A(J,L) - DO 110 I = 1,J - C(I,J) = C(I,J) + TEMP*A(I,L) - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 140 I = J,N - C(I,J) = ZERO - 140 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 150 I = J,N - C(I,J) = BETA*C(I,J) - 150 CONTINUE - END IF - DO 170 L = 1,K - IF (A(J,L).NE.ZERO) THEN - TEMP = ALPHA*A(J,L) - DO 160 I = J,N - C(I,J) = C(I,J) + TEMP*A(I,L) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A**T*A + beta*C. -* - IF (UPPER) THEN - DO 210 J = 1,N - DO 200 I = 1,J - TEMP = ZERO - DO 190 L = 1,K - TEMP = TEMP + A(L,I)*A(L,J) - 190 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240 J = 1,N - DO 230 I = J,N - TEMP = ZERO - DO 220 L = 1,K - TEMP = TEMP + A(L,I)*A(L,J) - 220 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYRK -* - END diff --git a/lib/linalg/fortran/dsytd2.f b/lib/linalg/fortran/dsytd2.f deleted file mode 100644 index 977b6daa41..0000000000 --- a/lib/linalg/fortran/dsytd2.f +++ /dev/null @@ -1,320 +0,0 @@ -*> \brief \b DSYTD2 reduces a symmetric matrix to real symmetric tridiagonal form by an orthogonal similarity transformation (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSYTD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal -*> form T by an orthogonal similarity transformation: Q**T * A * Q = T. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies whether the upper or lower triangular part of the -*> symmetric matrix A is stored: -*> = 'U': Upper triangular -*> = 'L': Lower triangular -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the leading -*> n-by-n upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading n-by-n lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> On exit, if UPLO = 'U', the diagonal and first superdiagonal -*> of A are overwritten by the corresponding elements of the -*> tridiagonal matrix T, and the elements above the first -*> superdiagonal, with the array TAU, represent the orthogonal -*> matrix Q as a product of elementary reflectors; if UPLO -*> = 'L', the diagonal and first subdiagonal of A are over- -*> written by the corresponding elements of the tridiagonal -*> matrix T, and the elements below the first subdiagonal, with -*> the array TAU, represent the orthogonal matrix Q as a product -*> of elementary reflectors. See Further Details. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> The diagonal elements of the tridiagonal matrix T: -*> D(i) = A(i,i). -*> \endverbatim -*> -*> \param[out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> The off-diagonal elements of the tridiagonal matrix T: -*> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (N-1) -*> The scalar factors of the elementary reflectors (see Further -*> Details). -*> \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. -* -*> \ingroup doubleSYcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> If UPLO = 'U', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(n-1) . . . H(2) H(1). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**T -*> -*> where tau is a real scalar, and v is a real vector with -*> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in -*> A(1:i-1,i+1), and tau in TAU(i). -*> -*> If UPLO = 'L', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(1) H(2) . . . H(n-1). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**T -*> -*> where tau is a real scalar, and v is a real vector with -*> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), -*> and tau in TAU(i). -*> -*> The contents of A on exit are illustrated by the following examples -*> with n = 5: -*> -*> if UPLO = 'U': if UPLO = 'L': -*> -*> ( d e v2 v3 v4 ) ( d ) -*> ( d e v3 v4 ) ( e d ) -*> ( d e v4 ) ( v1 e d ) -*> ( d e ) ( v1 v2 e d ) -*> ( d ) ( v1 v2 v3 e d ) -*> -*> where d and e denote diagonal and off-diagonal elements of T, and vi -*> denotes an element of the vector defining H(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO, HALF - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, - $ HALF = 1.0D0 / 2.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I - DOUBLE PRECISION ALPHA, TAUI -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DLARFG, DSYMV, DSYR2, XERBLA -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL LSAME, DDOT -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYTD2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Reduce the upper triangle of A -* - DO 10 I = N - 1, 1, -1 -* -* Generate elementary reflector H(i) = I - tau * v * v**T -* to annihilate A(1:i-1,i+1) -* - CALL DLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI ) - E( I ) = A( I, I+1 ) -* - IF( TAUI.NE.ZERO ) THEN -* -* Apply H(i) from both sides to A(1:i,1:i) -* - A( I, I+1 ) = ONE -* -* Compute x := tau * A * v storing x in TAU(1:i) -* - CALL DSYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO, - $ TAU, 1 ) -* -* Compute w := x - 1/2 * tau * (x**T * v) * v -* - ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, A( 1, I+1 ), 1 ) - CALL DAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 ) -* -* Apply the transformation as a rank-2 update: -* A := A - v * w**T - w * v**T -* - CALL DSYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, - $ LDA ) -* - A( I, I+1 ) = E( I ) - END IF - D( I+1 ) = A( I+1, I+1 ) - TAU( I ) = TAUI - 10 CONTINUE - D( 1 ) = A( 1, 1 ) - ELSE -* -* Reduce the lower triangle of A -* - DO 20 I = 1, N - 1 -* -* Generate elementary reflector H(i) = I - tau * v * v**T -* to annihilate A(i+2:n,i) -* - CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, - $ TAUI ) - E( I ) = A( I+1, I ) -* - IF( TAUI.NE.ZERO ) THEN -* -* Apply H(i) from both sides to A(i+1:n,i+1:n) -* - A( I+1, I ) = ONE -* -* Compute x := tau * A * v storing y in TAU(i:n-1) -* - CALL DSYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, - $ A( I+1, I ), 1, ZERO, TAU( I ), 1 ) -* -* Compute w := x - 1/2 * tau * (x**T * v) * v -* - ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, A( I+1, I ), - $ 1 ) - CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 ) -* -* Apply the transformation as a rank-2 update: -* A := A - v * w**T - w * v**T -* - CALL DSYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1, - $ A( I+1, I+1 ), LDA ) -* - A( I+1, I ) = E( I ) - END IF - D( I ) = A( I, I ) - TAU( I ) = TAUI - 20 CONTINUE - D( N ) = A( N, N ) - END IF -* - RETURN -* -* End of DSYTD2 -* - END diff --git a/lib/linalg/fortran/dsytrd.f b/lib/linalg/fortran/dsytrd.f deleted file mode 100644 index 3dcfc3db2b..0000000000 --- a/lib/linalg/fortran/dsytrd.f +++ /dev/null @@ -1,373 +0,0 @@ -*> \brief \b DSYTRD -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSYTRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ), -* $ WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYTRD reduces a real symmetric matrix A to real symmetric -*> tridiagonal form T by an orthogonal similarity transformation: -*> Q**T * A * Q = T. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the leading -*> N-by-N upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading N-by-N lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> On exit, if UPLO = 'U', the diagonal and first superdiagonal -*> of A are overwritten by the corresponding elements of the -*> tridiagonal matrix T, and the elements above the first -*> superdiagonal, with the array TAU, represent the orthogonal -*> matrix Q as a product of elementary reflectors; if UPLO -*> = 'L', the diagonal and first subdiagonal of A are over- -*> written by the corresponding elements of the tridiagonal -*> matrix T, and the elements below the first subdiagonal, with -*> the array TAU, represent the orthogonal matrix Q as a product -*> of elementary reflectors. See Further Details. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> The diagonal elements of the tridiagonal matrix T: -*> D(i) = A(i,i). -*> \endverbatim -*> -*> \param[out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> The off-diagonal elements of the tridiagonal matrix T: -*> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (N-1) -*> The scalar factors of the elementary reflectors (see Further -*> Details). -*> \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. -*> For optimum performance LWORK >= N*NB, where NB is the -*> optimal blocksize. -*> -*> 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 -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleSYcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> If UPLO = 'U', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(n-1) . . . H(2) H(1). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**T -*> -*> where tau is a real scalar, and v is a real vector with -*> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in -*> A(1:i-1,i+1), and tau in TAU(i). -*> -*> If UPLO = 'L', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(1) H(2) . . . H(n-1). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**T -*> -*> where tau is a real scalar, and v is a real vector with -*> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), -*> and tau in TAU(i). -*> -*> The contents of A on exit are illustrated by the following examples -*> with n = 5: -*> -*> if UPLO = 'U': if UPLO = 'L': -*> -*> ( d e v2 v3 v4 ) ( d ) -*> ( d e v3 v4 ) ( e d ) -*> ( d e v4 ) ( v1 e d ) -*> ( d e ) ( v1 v2 e d ) -*> ( d ) ( v1 v2 v3 e d ) -*> -*> where d and e denote diagonal and off-diagonal elements of T, and vi -*> denotes an element of the vector defining H(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ), - $ WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, UPPER - INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DLATRD, DSYR2K, DSYTD2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - LQUERY = ( LWORK.EQ.-1 ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN - INFO = -9 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Determine the block size. -* - NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYTRD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NX = N - IWS = 1 - IF( NB.GT.1 .AND. NB.LT.N ) THEN -* -* Determine when to cross over from blocked to unblocked code -* (last block is always handled by unblocked code). -* - NX = MAX( NB, ILAENV( 3, 'DSYTRD', UPLO, N, -1, -1, -1 ) ) - IF( NX.LT.N ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: determine the -* minimum value of NB, and reduce NB or force use of -* unblocked code by setting NX = N. -* - NB = MAX( LWORK / LDWORK, 1 ) - NBMIN = ILAENV( 2, 'DSYTRD', UPLO, N, -1, -1, -1 ) - IF( NB.LT.NBMIN ) - $ NX = N - END IF - ELSE - NX = N - END IF - ELSE - NB = 1 - END IF -* - IF( UPPER ) THEN -* -* Reduce the upper triangle of A. -* Columns 1:kk are handled by the unblocked method. -* - KK = N - ( ( N-NX+NB-1 ) / NB )*NB - DO 20 I = N - NB + 1, KK + 1, -NB -* -* Reduce columns i:i+nb-1 to tridiagonal form and form the -* matrix W which is needed to update the unreduced part of -* the matrix -* - CALL DLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, - $ LDWORK ) -* -* Update the unreduced submatrix A(1:i-1,1:i-1), using an -* update of the form: A := A - V*W**T - W*V**T -* - CALL DSYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, I ), - $ LDA, WORK, LDWORK, ONE, A, LDA ) -* -* Copy superdiagonal elements back into A, and diagonal -* elements into D -* - DO 10 J = I, I + NB - 1 - A( J-1, J ) = E( J-1 ) - D( J ) = A( J, J ) - 10 CONTINUE - 20 CONTINUE -* -* Use unblocked code to reduce the last or only block -* - CALL DSYTD2( UPLO, KK, A, LDA, D, E, TAU, IINFO ) - ELSE -* -* Reduce the lower triangle of A -* - DO 40 I = 1, N - NX, NB -* -* Reduce columns i:i+nb-1 to tridiagonal form and form the -* matrix W which is needed to update the unreduced part of -* the matrix -* - CALL DLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), - $ TAU( I ), WORK, LDWORK ) -* -* Update the unreduced submatrix A(i+ib:n,i+ib:n), using -* an update of the form: A := A - V*W**T - W*V**T -* - CALL DSYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE, - $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE, - $ A( I+NB, I+NB ), LDA ) -* -* Copy subdiagonal elements back into A, and diagonal -* elements into D -* - DO 30 J = I, I + NB - 1 - A( J+1, J ) = E( J ) - D( J ) = A( J, J ) - 30 CONTINUE - 40 CONTINUE -* -* Use unblocked code to reduce the last or only block -* - CALL DSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ), - $ TAU( I ), IINFO ) - END IF -* - WORK( 1 ) = LWKOPT - RETURN -* -* End of DSYTRD -* - END diff --git a/lib/linalg/fortran/dtrmm.f b/lib/linalg/fortran/dtrmm.f deleted file mode 100644 index b2cc0a1fa8..0000000000 --- a/lib/linalg/fortran/dtrmm.f +++ /dev/null @@ -1,412 +0,0 @@ -*> \brief \b DTRMM -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA -* INTEGER LDA,LDB,M,N -* CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),B(LDB,*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DTRMM performs one of the matrix-matrix operations -*> -*> B := alpha*op( A )*B, or B := alpha*B*op( A ), -*> -*> where alpha is a scalar, B is an m by n matrix, A is a unit, or -*> non-unit, upper or lower triangular matrix and op( A ) is one of -*> -*> op( A ) = A or op( A ) = A**T. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> On entry, SIDE specifies whether op( A ) multiplies B from -*> the left or right as follows: -*> -*> SIDE = 'L' or 'l' B := alpha*op( A )*B. -*> -*> SIDE = 'R' or 'r' B := alpha*B*op( A ). -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the matrix A is an upper or -*> lower triangular matrix as follows: -*> -*> UPLO = 'U' or 'u' A is an upper triangular matrix. -*> -*> UPLO = 'L' or 'l' A is a lower triangular matrix. -*> \endverbatim -*> -*> \param[in] TRANSA -*> \verbatim -*> TRANSA is CHARACTER*1 -*> On entry, TRANSA specifies the form of op( A ) to be used in -*> the matrix multiplication as follows: -*> -*> TRANSA = 'N' or 'n' op( A ) = A. -*> -*> TRANSA = 'T' or 't' op( A ) = A**T. -*> -*> TRANSA = 'C' or 'c' op( A ) = A**T. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> On entry, DIAG specifies whether or not A is unit triangular -*> as follows: -*> -*> DIAG = 'U' or 'u' A is assumed to be unit triangular. -*> -*> DIAG = 'N' or 'n' A is not assumed to be unit -*> triangular. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of B. M must be at -*> least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of B. N must be -*> at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. When alpha is -*> zero then A is not referenced and B need not be set before -*> entry. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, k ), where k is m -*> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -*> Before entry with UPLO = 'U' or 'u', the leading k by k -*> upper triangular part of the array A must contain the upper -*> triangular matrix and the strictly lower triangular part of -*> A is not referenced. -*> Before entry with UPLO = 'L' or 'l', the leading k by k -*> lower triangular part of the array A must contain the lower -*> triangular matrix and the strictly upper triangular part of -*> A is not referenced. -*> Note that when DIAG = 'U' or 'u', the diagonal elements of -*> A are not referenced either, but are assumed to be unity. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. When SIDE = 'L' or 'l' then -*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -*> then LDA must be at least max( 1, n ). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension ( LDB, N ) -*> Before entry, the leading m by n part of the array B must -*> contain the matrix B, and on exit is overwritten by the -*> transformed matrix. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> On entry, LDB specifies the first dimension of B as declared -*> in the calling (sub) program. LDB must be at least -*> max( 1, m ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level3 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 3 Blas routine. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* -* -- Reference BLAS level3 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER LDA,LDB,M,N - CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,J,K,NROWA - LOGICAL LSIDE,NOUNIT,UPPER -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Test the input parameters. -* - LSIDE = LSAME(SIDE,'L') - IF (LSIDE) THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME(DIAG,'N') - UPPER = LSAME(UPLO,'U') -* - INFO = 0 - IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN - INFO = 1 - ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 2 - ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. - + (.NOT.LSAME(TRANSA,'T')) .AND. - + (.NOT.LSAME(TRANSA,'C'))) THEN - INFO = 3 - ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN - INFO = 4 - ELSE IF (M.LT.0) THEN - INFO = 5 - ELSE IF (N.LT.0) THEN - INFO = 6 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 9 - ELSE IF (LDB.LT.MAX(1,M)) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTRMM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (M.EQ.0 .OR. N.EQ.0) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - B(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF (LSIDE) THEN - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*A*B. -* - IF (UPPER) THEN - DO 50 J = 1,N - DO 40 K = 1,M - IF (B(K,J).NE.ZERO) THEN - TEMP = ALPHA*B(K,J) - DO 30 I = 1,K - 1 - B(I,J) = B(I,J) + TEMP*A(I,K) - 30 CONTINUE - IF (NOUNIT) TEMP = TEMP*A(K,K) - B(K,J) = TEMP - END IF - 40 CONTINUE - 50 CONTINUE - ELSE - DO 80 J = 1,N - DO 70 K = M,1,-1 - IF (B(K,J).NE.ZERO) THEN - TEMP = ALPHA*B(K,J) - B(K,J) = TEMP - IF (NOUNIT) B(K,J) = B(K,J)*A(K,K) - DO 60 I = K + 1,M - B(I,J) = B(I,J) + TEMP*A(I,K) - 60 CONTINUE - END IF - 70 CONTINUE - 80 CONTINUE - END IF - ELSE -* -* Form B := alpha*A**T*B. -* - IF (UPPER) THEN - DO 110 J = 1,N - DO 100 I = M,1,-1 - TEMP = B(I,J) - IF (NOUNIT) TEMP = TEMP*A(I,I) - DO 90 K = 1,I - 1 - TEMP = TEMP + A(K,I)*B(K,J) - 90 CONTINUE - B(I,J) = ALPHA*TEMP - 100 CONTINUE - 110 CONTINUE - ELSE - DO 140 J = 1,N - DO 130 I = 1,M - TEMP = B(I,J) - IF (NOUNIT) TEMP = TEMP*A(I,I) - DO 120 K = I + 1,M - TEMP = TEMP + A(K,I)*B(K,J) - 120 CONTINUE - B(I,J) = ALPHA*TEMP - 130 CONTINUE - 140 CONTINUE - END IF - END IF - ELSE - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*B*A. -* - IF (UPPER) THEN - DO 180 J = N,1,-1 - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 150 I = 1,M - B(I,J) = TEMP*B(I,J) - 150 CONTINUE - DO 170 K = 1,J - 1 - IF (A(K,J).NE.ZERO) THEN - TEMP = ALPHA*A(K,J) - DO 160 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - ELSE - DO 220 J = 1,N - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 190 I = 1,M - B(I,J) = TEMP*B(I,J) - 190 CONTINUE - DO 210 K = J + 1,N - IF (A(K,J).NE.ZERO) THEN - TEMP = ALPHA*A(K,J) - DO 200 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 200 CONTINUE - END IF - 210 CONTINUE - 220 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*A**T. -* - IF (UPPER) THEN - DO 260 K = 1,N - DO 240 J = 1,K - 1 - IF (A(J,K).NE.ZERO) THEN - TEMP = ALPHA*A(J,K) - DO 230 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 230 CONTINUE - END IF - 240 CONTINUE - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(K,K) - IF (TEMP.NE.ONE) THEN - DO 250 I = 1,M - B(I,K) = TEMP*B(I,K) - 250 CONTINUE - END IF - 260 CONTINUE - ELSE - DO 300 K = N,1,-1 - DO 280 J = K + 1,N - IF (A(J,K).NE.ZERO) THEN - TEMP = ALPHA*A(J,K) - DO 270 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 270 CONTINUE - END IF - 280 CONTINUE - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(K,K) - IF (TEMP.NE.ONE) THEN - DO 290 I = 1,M - B(I,K) = TEMP*B(I,K) - 290 CONTINUE - END IF - 300 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMM -* - END diff --git a/lib/linalg/fortran/dtrmv.f b/lib/linalg/fortran/dtrmv.f deleted file mode 100644 index e8af8e6136..0000000000 --- a/lib/linalg/fortran/dtrmv.f +++ /dev/null @@ -1,339 +0,0 @@ -*> \brief \b DTRMV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* -* .. Scalar Arguments .. -* INTEGER INCX,LDA,N -* CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),X(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DTRMV performs one of the matrix-vector operations -*> -*> x := A*x, or x := A**T*x, -*> -*> where x is an n element vector and A is an n by n unit, or non-unit, -*> upper or lower triangular matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the matrix is an upper or -*> lower triangular matrix as follows: -*> -*> UPLO = 'U' or 'u' A is an upper triangular matrix. -*> -*> UPLO = 'L' or 'l' A is a lower triangular matrix. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the operation to be performed as -*> follows: -*> -*> TRANS = 'N' or 'n' x := A*x. -*> -*> TRANS = 'T' or 't' x := A**T*x. -*> -*> TRANS = 'C' or 'c' x := A**T*x. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> On entry, DIAG specifies whether or not A is unit -*> triangular as follows: -*> -*> DIAG = 'U' or 'u' A is assumed to be unit triangular. -*> -*> DIAG = 'N' or 'n' A is not assumed to be unit -*> triangular. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, N ) -*> Before entry with UPLO = 'U' or 'u', the leading n by n -*> upper triangular part of the array A must contain the upper -*> triangular matrix and the strictly lower triangular part of -*> A is not referenced. -*> Before entry with UPLO = 'L' or 'l', the leading n by n -*> lower triangular part of the array A must contain the lower -*> triangular matrix and the strictly upper triangular part of -*> A is not referenced. -*> Note that when DIAG = 'U' or 'u', the diagonal elements of -*> A are not referenced either, but are assumed to be unity. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, n ). -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCX ) ). -*> Before entry, the incremented array X must contain the n -*> element vector x. On exit, X is overwritten with the -*> transformed vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> The vector and matrix arguments are not referenced when N = 0, or M = 0 -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,LDA,N - CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER (ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,J,JX,KX - LOGICAL NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 2 - ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (LDA.LT.MAX(1,N)) THEN - INFO = 6 - ELSE IF (INCX.EQ.0) THEN - INFO = 8 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTRMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x := A*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 20 J = 1,N - IF (X(J).NE.ZERO) THEN - TEMP = X(J) - DO 10 I = 1,J - 1 - X(I) = X(I) + TEMP*A(I,J) - 10 CONTINUE - IF (NOUNIT) X(J) = X(J)*A(J,J) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = X(JX) - IX = KX - DO 30 I = 1,J - 1 - X(IX) = X(IX) + TEMP*A(I,J) - IX = IX + INCX - 30 CONTINUE - IF (NOUNIT) X(JX) = X(JX)*A(J,J) - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 60 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - TEMP = X(J) - DO 50 I = N,J + 1,-1 - X(I) = X(I) + TEMP*A(I,J) - 50 CONTINUE - IF (NOUNIT) X(J) = X(J)*A(J,J) - END IF - 60 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 80 J = N,1,-1 - IF (X(JX).NE.ZERO) THEN - TEMP = X(JX) - IX = KX - DO 70 I = N,J + 1,-1 - X(IX) = X(IX) + TEMP*A(I,J) - IX = IX - INCX - 70 CONTINUE - IF (NOUNIT) X(JX) = X(JX)*A(J,J) - END IF - JX = JX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A**T*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 100 J = N,1,-1 - TEMP = X(J) - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 90 I = J - 1,1,-1 - TEMP = TEMP + A(I,J)*X(I) - 90 CONTINUE - X(J) = TEMP - 100 CONTINUE - ELSE - JX = KX + (N-1)*INCX - DO 120 J = N,1,-1 - TEMP = X(JX) - IX = JX - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 110 I = J - 1,1,-1 - IX = IX - INCX - TEMP = TEMP + A(I,J)*X(IX) - 110 CONTINUE - X(JX) = TEMP - JX = JX - INCX - 120 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 140 J = 1,N - TEMP = X(J) - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 130 I = J + 1,N - TEMP = TEMP + A(I,J)*X(I) - 130 CONTINUE - X(J) = TEMP - 140 CONTINUE - ELSE - JX = KX - DO 160 J = 1,N - TEMP = X(JX) - IX = JX - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 150 I = J + 1,N - IX = IX + INCX - TEMP = TEMP + A(I,J)*X(IX) - 150 CONTINUE - X(JX) = TEMP - JX = JX + INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMV -* - END diff --git a/lib/linalg/fortran/dtrsm.f b/lib/linalg/fortran/dtrsm.f deleted file mode 100644 index fa8080bc92..0000000000 --- a/lib/linalg/fortran/dtrsm.f +++ /dev/null @@ -1,440 +0,0 @@ -*> \brief \b DTRSM -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA -* INTEGER LDA,LDB,M,N -* CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),B(LDB,*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DTRSM solves one of the matrix equations -*> -*> op( A )*X = alpha*B, or X*op( A ) = alpha*B, -*> -*> where alpha is a scalar, X and B are m by n matrices, A is a unit, or -*> non-unit, upper or lower triangular matrix and op( A ) is one of -*> -*> op( A ) = A or op( A ) = A**T. -*> -*> The matrix X is overwritten on B. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> On entry, SIDE specifies whether op( A ) appears on the left -*> or right of X as follows: -*> -*> SIDE = 'L' or 'l' op( A )*X = alpha*B. -*> -*> SIDE = 'R' or 'r' X*op( A ) = alpha*B. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the matrix A is an upper or -*> lower triangular matrix as follows: -*> -*> UPLO = 'U' or 'u' A is an upper triangular matrix. -*> -*> UPLO = 'L' or 'l' A is a lower triangular matrix. -*> \endverbatim -*> -*> \param[in] TRANSA -*> \verbatim -*> TRANSA is CHARACTER*1 -*> On entry, TRANSA specifies the form of op( A ) to be used in -*> the matrix multiplication as follows: -*> -*> TRANSA = 'N' or 'n' op( A ) = A. -*> -*> TRANSA = 'T' or 't' op( A ) = A**T. -*> -*> TRANSA = 'C' or 'c' op( A ) = A**T. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> On entry, DIAG specifies whether or not A is unit triangular -*> as follows: -*> -*> DIAG = 'U' or 'u' A is assumed to be unit triangular. -*> -*> DIAG = 'N' or 'n' A is not assumed to be unit -*> triangular. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of B. M must be at -*> least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of B. N must be -*> at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. When alpha is -*> zero then A is not referenced and B need not be set before -*> entry. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, k ), -*> where k is m when SIDE = 'L' or 'l' -*> and k is n when SIDE = 'R' or 'r'. -*> Before entry with UPLO = 'U' or 'u', the leading k by k -*> upper triangular part of the array A must contain the upper -*> triangular matrix and the strictly lower triangular part of -*> A is not referenced. -*> Before entry with UPLO = 'L' or 'l', the leading k by k -*> lower triangular part of the array A must contain the lower -*> triangular matrix and the strictly upper triangular part of -*> A is not referenced. -*> Note that when DIAG = 'U' or 'u', the diagonal elements of -*> A are not referenced either, but are assumed to be unity. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. When SIDE = 'L' or 'l' then -*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -*> then LDA must be at least max( 1, n ). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension ( LDB, N ) -*> Before entry, the leading m by n part of the array B must -*> contain the right-hand side matrix B, and on exit is -*> overwritten by the solution matrix X. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> On entry, LDB specifies the first dimension of B as declared -*> in the calling (sub) program. LDB must be at least -*> max( 1, m ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level3 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 3 Blas routine. -*> -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* -* -- Reference BLAS level3 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER LDA,LDB,M,N - CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,J,K,NROWA - LOGICAL LSIDE,NOUNIT,UPPER -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Test the input parameters. -* - LSIDE = LSAME(SIDE,'L') - IF (LSIDE) THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME(DIAG,'N') - UPPER = LSAME(UPLO,'U') -* - INFO = 0 - IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN - INFO = 1 - ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 2 - ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. - + (.NOT.LSAME(TRANSA,'T')) .AND. - + (.NOT.LSAME(TRANSA,'C'))) THEN - INFO = 3 - ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN - INFO = 4 - ELSE IF (M.LT.0) THEN - INFO = 5 - ELSE IF (N.LT.0) THEN - INFO = 6 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 9 - ELSE IF (LDB.LT.MAX(1,M)) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTRSM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (M.EQ.0 .OR. N.EQ.0) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - B(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF (LSIDE) THEN - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*inv( A )*B. -* - IF (UPPER) THEN - DO 60 J = 1,N - IF (ALPHA.NE.ONE) THEN - DO 30 I = 1,M - B(I,J) = ALPHA*B(I,J) - 30 CONTINUE - END IF - DO 50 K = M,1,-1 - IF (B(K,J).NE.ZERO) THEN - IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) - DO 40 I = 1,K - 1 - B(I,J) = B(I,J) - B(K,J)*A(I,K) - 40 CONTINUE - END IF - 50 CONTINUE - 60 CONTINUE - ELSE - DO 100 J = 1,N - IF (ALPHA.NE.ONE) THEN - DO 70 I = 1,M - B(I,J) = ALPHA*B(I,J) - 70 CONTINUE - END IF - DO 90 K = 1,M - IF (B(K,J).NE.ZERO) THEN - IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) - DO 80 I = K + 1,M - B(I,J) = B(I,J) - B(K,J)*A(I,K) - 80 CONTINUE - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form B := alpha*inv( A**T )*B. -* - IF (UPPER) THEN - DO 130 J = 1,N - DO 120 I = 1,M - TEMP = ALPHA*B(I,J) - DO 110 K = 1,I - 1 - TEMP = TEMP - A(K,I)*B(K,J) - 110 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(I,I) - B(I,J) = TEMP - 120 CONTINUE - 130 CONTINUE - ELSE - DO 160 J = 1,N - DO 150 I = M,1,-1 - TEMP = ALPHA*B(I,J) - DO 140 K = I + 1,M - TEMP = TEMP - A(K,I)*B(K,J) - 140 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(I,I) - B(I,J) = TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*B*inv( A ). -* - IF (UPPER) THEN - DO 210 J = 1,N - IF (ALPHA.NE.ONE) THEN - DO 170 I = 1,M - B(I,J) = ALPHA*B(I,J) - 170 CONTINUE - END IF - DO 190 K = 1,J - 1 - IF (A(K,J).NE.ZERO) THEN - DO 180 I = 1,M - B(I,J) = B(I,J) - A(K,J)*B(I,K) - 180 CONTINUE - END IF - 190 CONTINUE - IF (NOUNIT) THEN - TEMP = ONE/A(J,J) - DO 200 I = 1,M - B(I,J) = TEMP*B(I,J) - 200 CONTINUE - END IF - 210 CONTINUE - ELSE - DO 260 J = N,1,-1 - IF (ALPHA.NE.ONE) THEN - DO 220 I = 1,M - B(I,J) = ALPHA*B(I,J) - 220 CONTINUE - END IF - DO 240 K = J + 1,N - IF (A(K,J).NE.ZERO) THEN - DO 230 I = 1,M - B(I,J) = B(I,J) - A(K,J)*B(I,K) - 230 CONTINUE - END IF - 240 CONTINUE - IF (NOUNIT) THEN - TEMP = ONE/A(J,J) - DO 250 I = 1,M - B(I,J) = TEMP*B(I,J) - 250 CONTINUE - END IF - 260 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*inv( A**T ). -* - IF (UPPER) THEN - DO 310 K = N,1,-1 - IF (NOUNIT) THEN - TEMP = ONE/A(K,K) - DO 270 I = 1,M - B(I,K) = TEMP*B(I,K) - 270 CONTINUE - END IF - DO 290 J = 1,K - 1 - IF (A(J,K).NE.ZERO) THEN - TEMP = A(J,K) - DO 280 I = 1,M - B(I,J) = B(I,J) - TEMP*B(I,K) - 280 CONTINUE - END IF - 290 CONTINUE - IF (ALPHA.NE.ONE) THEN - DO 300 I = 1,M - B(I,K) = ALPHA*B(I,K) - 300 CONTINUE - END IF - 310 CONTINUE - ELSE - DO 360 K = 1,N - IF (NOUNIT) THEN - TEMP = ONE/A(K,K) - DO 320 I = 1,M - B(I,K) = TEMP*B(I,K) - 320 CONTINUE - END IF - DO 340 J = K + 1,N - IF (A(J,K).NE.ZERO) THEN - TEMP = A(J,K) - DO 330 I = 1,M - B(I,J) = B(I,J) - TEMP*B(I,K) - 330 CONTINUE - END IF - 340 CONTINUE - IF (ALPHA.NE.ONE) THEN - DO 350 I = 1,M - B(I,K) = ALPHA*B(I,K) - 350 CONTINUE - END IF - 360 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRSM -* - END diff --git a/lib/linalg/fortran/dtrsv.f b/lib/linalg/fortran/dtrsv.f deleted file mode 100644 index d8ea9fa898..0000000000 --- a/lib/linalg/fortran/dtrsv.f +++ /dev/null @@ -1,335 +0,0 @@ -*> \brief \b DTRSV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* -* .. Scalar Arguments .. -* INTEGER INCX,LDA,N -* CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),X(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DTRSV solves one of the systems of equations -*> -*> A*x = b, or A**T*x = b, -*> -*> where b and x are n element vectors and A is an n by n unit, or -*> non-unit, upper or lower triangular matrix. -*> -*> No test for singularity or near-singularity is included in this -*> routine. Such tests must be performed before calling this routine. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the matrix is an upper or -*> lower triangular matrix as follows: -*> -*> UPLO = 'U' or 'u' A is an upper triangular matrix. -*> -*> UPLO = 'L' or 'l' A is a lower triangular matrix. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the equations to be solved as -*> follows: -*> -*> TRANS = 'N' or 'n' A*x = b. -*> -*> TRANS = 'T' or 't' A**T*x = b. -*> -*> TRANS = 'C' or 'c' A**T*x = b. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> On entry, DIAG specifies whether or not A is unit -*> triangular as follows: -*> -*> DIAG = 'U' or 'u' A is assumed to be unit triangular. -*> -*> DIAG = 'N' or 'n' A is not assumed to be unit -*> triangular. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, N ) -*> Before entry with UPLO = 'U' or 'u', the leading n by n -*> upper triangular part of the array A must contain the upper -*> triangular matrix and the strictly lower triangular part of -*> A is not referenced. -*> Before entry with UPLO = 'L' or 'l', the leading n by n -*> lower triangular part of the array A must contain the lower -*> triangular matrix and the strictly upper triangular part of -*> A is not referenced. -*> Note that when DIAG = 'U' or 'u', the diagonal elements of -*> A are not referenced either, but are assumed to be unity. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, n ). -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCX ) ). -*> Before entry, the incremented array X must contain the n -*> element right-hand side vector b. On exit, X is overwritten -*> with the solution vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> -*> Level 2 Blas routine. -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level1 -* -* ===================================================================== - SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,LDA,N - CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER (ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,J,JX,KX - LOGICAL NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 2 - ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (LDA.LT.MAX(1,N)) THEN - INFO = 6 - ELSE IF (INCX.EQ.0) THEN - INFO = 8 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTRSV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x := inv( A )*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 20 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - IF (NOUNIT) X(J) = X(J)/A(J,J) - TEMP = X(J) - DO 10 I = J - 1,1,-1 - X(I) = X(I) - TEMP*A(I,J) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - JX = KX + (N-1)*INCX - DO 40 J = N,1,-1 - IF (X(JX).NE.ZERO) THEN - IF (NOUNIT) X(JX) = X(JX)/A(J,J) - TEMP = X(JX) - IX = JX - DO 30 I = J - 1,1,-1 - IX = IX - INCX - X(IX) = X(IX) - TEMP*A(I,J) - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 60 J = 1,N - IF (X(J).NE.ZERO) THEN - IF (NOUNIT) X(J) = X(J)/A(J,J) - TEMP = X(J) - DO 50 I = J + 1,N - X(I) = X(I) - TEMP*A(I,J) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80 J = 1,N - IF (X(JX).NE.ZERO) THEN - IF (NOUNIT) X(JX) = X(JX)/A(J,J) - TEMP = X(JX) - IX = JX - DO 70 I = J + 1,N - IX = IX + INCX - X(IX) = X(IX) - TEMP*A(I,J) - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A**T )*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 100 J = 1,N - TEMP = X(J) - DO 90 I = 1,J - 1 - TEMP = TEMP - A(I,J)*X(I) - 90 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(J,J) - X(J) = TEMP - 100 CONTINUE - ELSE - JX = KX - DO 120 J = 1,N - TEMP = X(JX) - IX = KX - DO 110 I = 1,J - 1 - TEMP = TEMP - A(I,J)*X(IX) - IX = IX + INCX - 110 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(J,J) - X(JX) = TEMP - JX = JX + INCX - 120 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 140 J = N,1,-1 - TEMP = X(J) - DO 130 I = N,J + 1,-1 - TEMP = TEMP - A(I,J)*X(I) - 130 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(J,J) - X(J) = TEMP - 140 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 160 J = N,1,-1 - TEMP = X(JX) - IX = KX - DO 150 I = N,J + 1,-1 - TEMP = TEMP - A(I,J)*X(IX) - IX = IX - INCX - 150 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(J,J) - X(JX) = TEMP - JX = JX - INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRSV -* - END diff --git a/lib/linalg/fortran/dtrti2.f b/lib/linalg/fortran/dtrti2.f deleted file mode 100644 index 0d9115554c..0000000000 --- a/lib/linalg/fortran/dtrti2.f +++ /dev/null @@ -1,209 +0,0 @@ -*> \brief \b DTRTI2 computes the inverse of a triangular matrix (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DTRTI2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER DIAG, UPLO -* INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DTRTI2 computes the inverse of a real upper or lower triangular -*> matrix. -*> -*> This is the Level 2 BLAS version of the algorithm. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies whether the matrix A is upper or lower triangular. -*> = 'U': Upper triangular -*> = 'L': Lower triangular -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> Specifies whether or not the matrix A is unit triangular. -*> = 'N': Non-unit triangular -*> = 'U': Unit triangular -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the triangular matrix A. If UPLO = 'U', the -*> leading n by n upper triangular part of the array A contains -*> the upper triangular matrix, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading n by n lower triangular part of the array A contains -*> the lower triangular matrix, and the strictly upper -*> triangular part of A is not referenced. If DIAG = 'U', the -*> diagonal elements of A are also not referenced and are -*> assumed to be 1. -*> -*> On exit, the (triangular) inverse of the original matrix, in -*> the same storage format. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -k, the k-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. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J - DOUBLE PRECISION AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DSCAL, DTRMV, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTRTI2', -INFO ) - RETURN - END IF -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix. -* - DO 10 J = 1, N - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF -* -* Compute elements 1:j-1 of j-th column. -* - CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, - $ A( 1, J ), 1 ) - CALL DSCAL( J-1, AJJ, A( 1, J ), 1 ) - 10 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix. -* - DO 20 J = N, 1, -1 - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF - IF( J.LT.N ) THEN -* -* Compute elements j+1:n of j-th column. -* - CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J, - $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) - CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF -* - RETURN -* -* End of DTRTI2 -* - END diff --git a/lib/linalg/fortran/dtrtri.f b/lib/linalg/fortran/dtrtri.f deleted file mode 100644 index 1cf9a9aafb..0000000000 --- a/lib/linalg/fortran/dtrtri.f +++ /dev/null @@ -1,239 +0,0 @@ -*> \brief \b DTRTRI -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DTRTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER DIAG, UPLO -* INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DTRTRI computes the inverse of a real upper or lower triangular -*> matrix A. -*> -*> This is the Level 3 BLAS version of the algorithm. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': A is upper triangular; -*> = 'L': A is lower triangular. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> = 'N': A is non-unit triangular; -*> = 'U': A is unit triangular. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the triangular matrix A. If UPLO = 'U', the -*> leading N-by-N upper triangular part of the array A contains -*> the upper triangular matrix, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading N-by-N lower triangular part of the array A contains -*> the lower triangular matrix, and the strictly upper -*> triangular part of A is not referenced. If DIAG = 'U', the -*> diagonal elements of A are also not referenced and are -*> assumed to be 1. -*> On exit, the (triangular) inverse of the original matrix, in -*> the same storage format. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,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 = i, A(i,i) is exactly zero. The triangular -*> matrix is singular and its inverse can not be computed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J, JB, NB, NN -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DTRMM, DTRSM, DTRTI2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTRTRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Check for singularity if non-unit. -* - IF( NOUNIT ) THEN - DO 10 INFO = 1, N - IF( A( INFO, INFO ).EQ.ZERO ) - $ RETURN - 10 CONTINUE - INFO = 0 - END IF -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) - ELSE -* -* Use blocked code -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix -* - DO 20 J = 1, N, NB - JB = MIN( NB, N-J+1 ) -* -* Compute rows 1:j-1 of current block column -* - CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1, - $ JB, ONE, A, LDA, A( 1, J ), LDA ) - CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1, - $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA ) -* -* Compute inverse of current diagonal block -* - CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO ) - 20 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix -* - NN = ( ( N-1 ) / NB )*NB + 1 - DO 30 J = NN, 1, -NB - JB = MIN( NB, N-J+1 ) - IF( J+JB.LE.N ) THEN -* -* Compute rows j+jb:n of current block column -* - CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA, - $ A( J+JB, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, -ONE, A( J, J ), LDA, - $ A( J+JB, J ), LDA ) - END IF -* -* Compute inverse of current diagonal block -* - CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO ) - 30 CONTINUE - END IF - END IF -* - RETURN -* -* End of DTRTRI -* - END diff --git a/lib/linalg/fortran/dznrm2.f b/lib/linalg/fortran/dznrm2.f deleted file mode 100644 index e5a71d98f6..0000000000 --- a/lib/linalg/fortran/dznrm2.f +++ /dev/null @@ -1,140 +0,0 @@ -*> \brief \b DZNRM2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DZNRM2(N,X,INCX) -* -* .. Scalar Arguments .. -* INTEGER INCX,N -* .. -* .. Array Arguments .. -* COMPLEX*16 X(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DZNRM2 returns the euclidean norm of a vector via the function -*> name, so that -*> -*> DZNRM2 := sqrt( x**H*x ) -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is COMPLEX*16 array, dimension (N) -*> complex vector with N elements -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of X -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date December 2016 -* -*> \ingroup double_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> -- This version written on 25-October-1982. -*> Modified on 14-October-1993 to inline the call to ZLASSQ. -*> Sven Hammarling, Nag Ltd. -*> \endverbatim -*> -* ===================================================================== - DOUBLE PRECISION FUNCTION DZNRM2(N,X,INCX) -* -* -- 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..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - COMPLEX*16 X(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION NORM,SCALE,SSQ,TEMP - INTEGER IX -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS,DBLE,DIMAG,SQRT -* .. - IF (N.LT.1 .OR. INCX.LT.1) THEN - NORM = ZERO - ELSE - SCALE = ZERO - SSQ = ONE -* The following loop is equivalent to this call to the LAPACK -* auxiliary routine: -* CALL ZLASSQ( N, X, INCX, SCALE, SSQ ) -* - DO 10 IX = 1,1 + (N-1)*INCX,INCX - IF (DBLE(X(IX)).NE.ZERO) THEN - TEMP = ABS(DBLE(X(IX))) - IF (SCALE.LT.TEMP) THEN - SSQ = ONE + SSQ* (SCALE/TEMP)**2 - SCALE = TEMP - ELSE - SSQ = SSQ + (TEMP/SCALE)**2 - END IF - END IF - IF (DIMAG(X(IX)).NE.ZERO) THEN - TEMP = ABS(DIMAG(X(IX))) - IF (SCALE.LT.TEMP) THEN - SSQ = ONE + SSQ* (SCALE/TEMP)**2 - SCALE = TEMP - ELSE - SSQ = SSQ + (TEMP/SCALE)**2 - END IF - END IF - 10 CONTINUE - NORM = SCALE*SQRT(SSQ) - END IF -* - DZNRM2 = NORM - RETURN -* -* End of DZNRM2. -* - END diff --git a/lib/linalg/fortran/idamax.f b/lib/linalg/fortran/idamax.f deleted file mode 100644 index 1be301ea3e..0000000000 --- a/lib/linalg/fortran/idamax.f +++ /dev/null @@ -1,126 +0,0 @@ -*> \brief \b IDAMAX -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* INTEGER FUNCTION IDAMAX(N,DX,INCX) -* -* .. Scalar Arguments .. -* INTEGER INCX,N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION DX(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> IDAMAX finds the index of the first element having maximum absolute value. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in] DX -*> \verbatim -*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of DX -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup aux_blas -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, linpack, 3/11/78. -*> modified 3/93 to return if incx .le. 0. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - INTEGER FUNCTION IDAMAX(N,DX,INCX) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DMAX - INTEGER I,IX -* .. -* .. Intrinsic Functions .. - INTRINSIC DABS -* .. - IDAMAX = 0 - IF (N.LT.1 .OR. INCX.LE.0) RETURN - IDAMAX = 1 - IF (N.EQ.1) RETURN - IF (INCX.EQ.1) THEN -* -* code for increment equal to 1 -* - DMAX = DABS(DX(1)) - DO I = 2,N - IF (DABS(DX(I)).GT.DMAX) THEN - IDAMAX = I - DMAX = DABS(DX(I)) - END IF - END DO - ELSE -* -* code for increment not equal to 1 -* - IX = 1 - DMAX = DABS(DX(1)) - IX = IX + INCX - DO I = 2,N - IF (DABS(DX(IX)).GT.DMAX) THEN - IDAMAX = I - DMAX = DABS(DX(IX)) - END IF - IX = IX + INCX - END DO - END IF - RETURN -* -* End of IDAMAX -* - END diff --git a/lib/linalg/fortran/ieeeck.f b/lib/linalg/fortran/ieeeck.f deleted file mode 100644 index f9f6332ecf..0000000000 --- a/lib/linalg/fortran/ieeeck.f +++ /dev/null @@ -1,200 +0,0 @@ -*> \brief \b IEEECK -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download IEEECK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) -* -* .. Scalar Arguments .. -* INTEGER ISPEC -* REAL ONE, ZERO -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> IEEECK is called from the ILAENV to verify that Infinity and -*> possibly NaN arithmetic is safe (i.e. will not trap). -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ISPEC -*> \verbatim -*> ISPEC is INTEGER -*> Specifies whether to test just for infinity arithmetic -*> or whether to test for infinity and NaN arithmetic. -*> = 0: Verify infinity arithmetic only. -*> = 1: Verify infinity and NaN arithmetic. -*> \endverbatim -*> -*> \param[in] ZERO -*> \verbatim -*> ZERO is REAL -*> Must contain the value 0.0 -*> This is passed to prevent the compiler from optimizing -*> away this code. -*> \endverbatim -*> -*> \param[in] ONE -*> \verbatim -*> ONE is REAL -*> Must contain the value 1.0 -*> This is passed to prevent the compiler from optimizing -*> away this code. -*> -*> RETURN VALUE: INTEGER -*> = 0: Arithmetic failed to produce the correct answers -*> = 1: Arithmetic produced the correct answers -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER ISPEC - REAL ONE, ZERO -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, - $ NEGZRO, NEWZRO, POSINF -* .. -* .. Executable Statements .. - IEEECK = 1 -* - POSINF = ONE / ZERO - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = -ONE / ZERO - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGZRO = ONE / ( NEGINF+ONE ) - IF( NEGZRO.NE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = ONE / NEGZRO - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEWZRO = NEGZRO + ZERO - IF( NEWZRO.NE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - POSINF = ONE / NEWZRO - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = NEGINF*POSINF - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - POSINF = POSINF*POSINF - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* -* -* -* -* Return if we were only asked to check infinity arithmetic -* - IF( ISPEC.EQ.0 ) - $ RETURN -* - NAN1 = POSINF + NEGINF -* - NAN2 = POSINF / NEGINF -* - NAN3 = POSINF / POSINF -* - NAN4 = POSINF*ZERO -* - NAN5 = NEGINF*NEGZRO -* - NAN6 = NAN5*ZERO -* - IF( NAN1.EQ.NAN1 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN2.EQ.NAN2 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN3.EQ.NAN3 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN4.EQ.NAN4 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN5.EQ.NAN5 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN6.EQ.NAN6 ) THEN - IEEECK = 0 - RETURN - END IF -* - RETURN - END diff --git a/lib/linalg/fortran/iladlc.f b/lib/linalg/fortran/iladlc.f deleted file mode 100644 index a98e7218bf..0000000000 --- a/lib/linalg/fortran/iladlc.f +++ /dev/null @@ -1,115 +0,0 @@ -*> \brief \b ILADLC scans a matrix for its last non-zero column. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ILADLC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION ILADLC( M, N, A, LDA ) -* -* .. Scalar Arguments .. -* INTEGER M, N, LDA -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ILADLC scans A for its last non-zero column. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The m by n matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - INTEGER FUNCTION ILADLC( M, N, A, LDA ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( N.EQ.0 ) THEN - ILADLC = N - ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILADLC = N - ELSE -* Now scan each column from the end, returning with the first non-zero. - DO ILADLC = N, 1, -1 - DO I = 1, M - IF( A(I, ILADLC).NE.ZERO ) RETURN - END DO - END DO - END IF - RETURN - END diff --git a/lib/linalg/fortran/iladlr.f b/lib/linalg/fortran/iladlr.f deleted file mode 100644 index b1abded84b..0000000000 --- a/lib/linalg/fortran/iladlr.f +++ /dev/null @@ -1,118 +0,0 @@ -*> \brief \b ILADLR scans a matrix for its last non-zero row. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ILADLR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION ILADLR( M, N, A, LDA ) -* -* .. Scalar Arguments .. -* INTEGER M, N, LDA -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ILADLR scans A for its last non-zero row. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The m by n matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - INTEGER FUNCTION ILADLR( M, N, A, LDA ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( M.EQ.0 ) THEN - ILADLR = M - ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILADLR = M - ELSE -* Scan up each column tracking the last zero row seen. - ILADLR = 0 - DO J = 1, N - I=M - DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) - I=I-1 - ENDDO - ILADLR = MAX( ILADLR, I ) - END DO - END IF - RETURN - END diff --git a/lib/linalg/fortran/ilaenv.f b/lib/linalg/fortran/ilaenv.f deleted file mode 100644 index 3f0800b95e..0000000000 --- a/lib/linalg/fortran/ilaenv.f +++ /dev/null @@ -1,730 +0,0 @@ -*> \brief \b ILAENV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ILAENV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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: -* ============= -*> -*> \verbatim -*> -*> ILAENV is called from the LAPACK routines to choose problem-dependent -*> parameters for the local environment. See ISPEC for a description of -*> the parameters. -*> -*> ILAENV returns an INTEGER -*> if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC -*> if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value. -*> -*> This version provides a set of parameters which should give good, -*> but not optimal, performance on many of the currently available -*> computers. Users are encouraged to modify this subroutine to set -*> the tuning parameters for their particular machine using the option -*> and problem size information in the arguments. -*> -*> This routine will not function correctly if it is converted to all -*> lower case. Converting it to all upper case is allowed. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ISPEC -*> \verbatim -*> ISPEC is INTEGER -*> Specifies the parameter to be returned as the value of -*> ILAENV. -*> = 1: the optimal blocksize; if this value is 1, an unblocked -*> algorithm will give the best performance. -*> = 2: the minimum block size for which the block routine -*> should be used; if the usable block size is less than -*> this value, an unblocked routine should be used. -*> = 3: the crossover point (in a block routine, for N less -*> than this value, an unblocked routine should be used) -*> = 4: the number of shifts, used in the nonsymmetric -*> eigenvalue routines (DEPRECATED) -*> = 5: the minimum column dimension for blocking to be used; -*> rectangular blocks must have dimension at least k by m, -*> where k is given by ILAENV(2,...) and m by ILAENV(5,...) -*> = 6: the crossover point for the SVD (when reducing an m by n -*> matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds -*> this value, a QR factorization is used first to reduce -*> the matrix to a triangular form.) -*> = 7: the number of processors -*> = 8: the crossover point for the multishift QR method -*> for nonsymmetric eigenvalue problems (DEPRECATED) -*> = 9: maximum size of the subproblems at the bottom of the -*> computation tree in the divide-and-conquer algorithm -*> (used by xGELSD and xGESDD) -*> =10: ieee infinity and NaN arithmetic can be trusted not to trap -*> =11: infinity arithmetic can be trusted not to trap -*> 12 <= ISPEC <= 17: -*> xHSEQR or related subroutines, -*> see IPARMQ for detailed explanation -*> \endverbatim -*> -*> \param[in] NAME -*> \verbatim -*> NAME is CHARACTER*(*) -*> The name of the calling subroutine, in either upper case or -*> lower case. -*> \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] N1 -*> \verbatim -*> N1 is INTEGER -*> \endverbatim -*> -*> \param[in] N2 -*> \verbatim -*> N2 is INTEGER -*> \endverbatim -*> -*> \param[in] N3 -*> \verbatim -*> N3 is INTEGER -*> \endverbatim -*> -*> \param[in] N4 -*> \verbatim -*> N4 is INTEGER -*> Problem dimensions for the subroutine NAME; these may not all -*> be required. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The following conventions have been used when calling ILAENV from the -*> LAPACK routines: -*> 1) OPTS is a concatenation of all of the character options to -*> subroutine NAME, in the same order that they appear in the -*> argument list for NAME, even if they are not used in determining -*> the value of the parameter specified by ISPEC. -*> 2) The problem dimensions N1, N2, N3, N4 are specified in the order -*> that they appear in the argument list for NAME. N1 is used -*> first, N2 second, and so on, and unused problem dimensions are -*> passed a value of -1. -*> 3) The parameter value returned by ILAENV is checked for validity in -*> the calling subroutine. For example, ILAENV is used to retrieve -*> the optimal blocksize for STRTRI as follows: -*> -*> NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) -*> IF( NB.LE.1 ) NB = MAX( 1, N ) -*> \endverbatim -*> -* ===================================================================== - INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER*( * ) NAME, OPTS - INTEGER ISPEC, N1, N2, N3, N4 -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IC, IZ, NB, NBMIN, NX - LOGICAL CNAME, SNAME, TWOSTAGE - CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*16 -* .. -* .. Intrinsic Functions .. - INTRINSIC CHAR, ICHAR, INT, MIN, REAL -* .. -* .. External Functions .. - INTEGER IEEECK, IPARMQ - EXTERNAL IEEECK, IPARMQ -* .. -* .. Executable Statements .. -* - GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, - $ 130, 140, 150, 160, 160, 160, 160, 160, 160)ISPEC -* -* Invalid value for ISPEC -* - ILAENV = -1 - RETURN -* - 10 CONTINUE -* -* Convert NAME to upper case if the first character is lower case. -* - ILAENV = 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 20 I = 2, 6 - IC = ICHAR( SUBNAM( I: I ) ) - IF( IC.GE.97 .AND. IC.LE.122 ) - $ SUBNAM( I: I ) = CHAR( IC-32 ) - 20 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 30 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 ) - 30 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 40 I = 2, 6 - IC = ICHAR( SUBNAM( I: I ) ) - IF( IC.GE.225 .AND. IC.LE.250 ) - $ SUBNAM( I: I ) = CHAR( IC-32 ) - 40 CONTINUE - END IF - END IF -* - C1 = SUBNAM( 1: 1 ) - SNAME = C1.EQ.'S' .OR. C1.EQ.'D' - CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' - IF( .NOT.( CNAME .OR. SNAME ) ) - $ RETURN - C2 = SUBNAM( 2: 3 ) - C3 = SUBNAM( 4: 6 ) - C4 = C3( 2: 3 ) - TWOSTAGE = LEN( SUBNAM ).GE.11 - $ .AND. SUBNAM( 11: 11 ).EQ.'2' -* - GO TO ( 50, 60, 70 )ISPEC -* - 50 CONTINUE -* -* ISPEC = 1: block size -* -* In these examples, separate code is provided for setting NB for -* real and complex. We assume that NB will take the same value in -* single or double precision. -* - NB = 1 -* - IF( SUBNAM(2:6).EQ.'LAORH' ) THEN -* -* This is for *LAORHR_GETRFNP routine -* - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN - IF( SNAME ) THEN - NB = 32 - 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 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'PO' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( TWOSTAGE ) THEN - NB = 192 - ELSE - NB = 64 - END IF - ELSE - IF( TWOSTAGE ) THEN - NB = 192 - ELSE - NB = 64 - END IF - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NB = 32 - ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( TWOSTAGE ) THEN - NB = 192 - ELSE - NB = 64 - END IF - ELSE IF( C3.EQ.'TRD' ) THEN - NB = 32 - ELSE IF( C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - END IF - ELSE IF( C2.EQ.'GB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'PB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'TR' ) THEN - IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF ( C3.EQ.'EVC' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( C3.EQ.'SYL' ) THEN -* The upper bound is to prevent overly aggressive scaling. - IF( SNAME ) THEN - NB = MIN( MAX( 48, INT( ( MIN( N1, N2 ) * 16 ) / 100) ), - $ 240 ) - ELSE - NB = MIN( MAX( 24, INT( ( MIN( N1, N2 ) * 8 ) / 100) ), - $ 80 ) - END IF - END IF - ELSE IF( C2.EQ.'LA' ) THEN - IF( C3.EQ.'UUM' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( C3.EQ.'TRS' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - END IF - ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN - 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 -* - 60 CONTINUE -* -* ISPEC = 2: minimum block size -* - NBMIN = 2 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. - $ 'QLF' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NBMIN = 8 - ELSE - NBMIN = 8 - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - 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 -* - 70 CONTINUE -* -* ISPEC = 3: crossover point -* - NX = 0 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. - $ 'QLF' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NX = 32 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NX = 32 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NX = 128 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - 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 -* - 80 CONTINUE -* -* ISPEC = 4: number of shifts (used by xHSEQR) -* - ILAENV = 6 - RETURN -* - 90 CONTINUE -* -* ISPEC = 5: minimum column dimension (not used) -* - ILAENV = 2 - RETURN -* - 100 CONTINUE -* -* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) -* - ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) - RETURN -* - 110 CONTINUE -* -* ISPEC = 7: number of processors (not used) -* - ILAENV = 1 - RETURN -* - 120 CONTINUE -* -* ISPEC = 8: crossover point for multishift (used by xHSEQR) -* - ILAENV = 50 - RETURN -* - 130 CONTINUE -* -* ISPEC = 9: maximum size of the subproblems at the bottom of the -* computation tree in the divide-and-conquer algorithm -* (used by xGELSD and xGESDD) -* - ILAENV = 25 - RETURN -* - 140 CONTINUE -* -* ISPEC = 10: ieee and infinity NaN arithmetic can be trusted not to trap -* -* ILAENV = 0 - ILAENV = 1 - IF( ILAENV.EQ.1 ) THEN - ILAENV = IEEECK( 1, 0.0, 1.0 ) - END IF - RETURN -* - 150 CONTINUE -* -* ISPEC = 11: ieee infinity arithmetic can be trusted not to trap -* -* ILAENV = 0 - ILAENV = 1 - IF( ILAENV.EQ.1 ) THEN - ILAENV = IEEECK( 0, 0.0, 1.0 ) - END IF - RETURN -* - 160 CONTINUE -* -* 12 <= ISPEC <= 17: xHSEQR or related subroutines. -* - ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) - RETURN -* -* End of ILAENV -* - END diff --git a/lib/linalg/fortran/ilazlc.f b/lib/linalg/fortran/ilazlc.f deleted file mode 100644 index 8af3430e61..0000000000 --- a/lib/linalg/fortran/ilazlc.f +++ /dev/null @@ -1,115 +0,0 @@ -*> \brief \b ILAZLC scans a matrix for its last non-zero column. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ILAZLC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION ILAZLC( M, N, A, LDA ) -* -* .. Scalar Arguments .. -* INTEGER M, N, LDA -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ILAZLC scans A for its last non-zero column. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> The m by n matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - INTEGER FUNCTION ILAZLC( M, N, A, LDA ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = (0.0D+0, 0.0D+0) ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( N.EQ.0 ) THEN - ILAZLC = N - ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILAZLC = N - ELSE -* Now scan each column from the end, returning with the first non-zero. - DO ILAZLC = N, 1, -1 - DO I = 1, M - IF( A(I, ILAZLC).NE.ZERO ) RETURN - END DO - END DO - END IF - RETURN - END diff --git a/lib/linalg/fortran/ilazlr.f b/lib/linalg/fortran/ilazlr.f deleted file mode 100644 index e0134a6a35..0000000000 --- a/lib/linalg/fortran/ilazlr.f +++ /dev/null @@ -1,118 +0,0 @@ -*> \brief \b ILAZLR scans a matrix for its last non-zero row. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ILAZLR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION ILAZLR( M, N, A, LDA ) -* -* .. Scalar Arguments .. -* INTEGER M, N, LDA -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ILAZLR scans A for its last non-zero row. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> The m by n matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - INTEGER FUNCTION ILAZLR( M, N, A, LDA ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = (0.0D+0, 0.0D+0) ) -* .. -* .. Local Scalars .. - INTEGER I, J -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( M.EQ.0 ) THEN - ILAZLR = M - ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILAZLR = M - ELSE -* Scan up each column tracking the last zero row seen. - ILAZLR = 0 - DO J = 1, N - I=M - DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) - I=I-1 - ENDDO - ILAZLR = MAX( ILAZLR, I ) - END DO - END IF - RETURN - END diff --git a/lib/linalg/fortran/iparmq.f b/lib/linalg/fortran/iparmq.f deleted file mode 100644 index 54c05471ca..0000000000 --- a/lib/linalg/fortran/iparmq.f +++ /dev/null @@ -1,406 +0,0 @@ -*> \brief \b IPARMQ -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download IPARMQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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: -* ============= -*> -*> \verbatim -*> -*> This program sets problem and machine dependent parameters -*> useful for xHSEQR and related subroutines for eigenvalue -*> problems. It is called whenever -*> IPARMQ is called with 12 <= ISPEC <= 16 -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ISPEC -*> \verbatim -*> ISPEC is INTEGER -*> ISPEC specifies which tunable parameter IPARMQ should -*> return. -*> -*> ISPEC=12: (INMIN) Matrices of order nmin or less -*> are sent directly to xLAHQR, the implicit -*> double shift QR algorithm. NMIN must be -*> at least 11. -*> -*> ISPEC=13: (INWIN) Size of the deflation window. -*> This is best set greater than or equal to -*> the number of simultaneous shifts NS. -*> Larger matrices benefit from larger deflation -*> windows. -*> -*> ISPEC=14: (INIBL) Determines when to stop nibbling and -*> invest in an (expensive) multi-shift QR sweep. -*> If the aggressive early deflation subroutine -*> finds LD converged eigenvalues from an order -*> NW deflation window and LD > (NW*NIBBLE)/100, -*> then the next QR sweep is skipped and early -*> deflation is applied immediately to the -*> remaining active diagonal block. Setting -*> IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a -*> multi-shift QR sweep whenever early deflation -*> finds a converged eigenvalue. Setting -*> IPARMQ(ISPEC=14) greater than or equal to 100 -*> prevents TTQRE from skipping a multi-shift -*> QR sweep. -*> -*> ISPEC=15: (NSHFTS) The number of simultaneous shifts in -*> a multi-shift QR iteration. -*> -*> ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the -*> following meanings. -*> 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. -*> 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 -*> arithmetic work implied by the latter choice.) -*> -*> ISPEC=17: (ICOST) An estimate of the relative cost of flops -*> within the near-the-diagonal shift chase compared -*> to flops within the BLAS calls of a QZ sweep. -*> \endverbatim -*> -*> \param[in] NAME -*> \verbatim -*> NAME is CHARACTER string -*> Name of the calling subroutine -*> \endverbatim -*> -*> \param[in] OPTS -*> \verbatim -*> OPTS is CHARACTER string -*> This is a concatenation of the string arguments to -*> TTQRE. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> N is the order of the Hessenberg matrix H. -*> \endverbatim -*> -*> \param[in] ILO -*> \verbatim -*> ILO is INTEGER -*> \endverbatim -*> -*> \param[in] IHI -*> \verbatim -*> IHI is INTEGER -*> It is assumed that H is already upper triangular -*> in rows and columns 1:ILO-1 and IHI+1:N. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> 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. -* -*> \ingroup OTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Little is known about how best to choose these parameters. -*> It is possible to use different values of the parameters -*> for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. -*> -*> It is probably best to choose different parameters for -*> different matrices and different parameters at different -*> times during the iteration, but this has not been -*> implemented --- yet. -*> -*> -*> The best choices of most of the parameters depend -*> in an ill-understood way on the relative execution -*> rate of xLAQR3 and xLAQR5 and on the nature of each -*> particular eigenvalue problem. Experiment may be the -*> only practical way to determine which choices are most -*> effective. -*> -*> Following is a list of default values supplied by IPARMQ. -*> These defaults may be adjusted in order to attain better -*> performance in any particular computational environment. -*> -*> IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. -*> Default: 75. (Must be at least 11.) -*> -*> IPARMQ(ISPEC=13) Recommended deflation window size. -*> This depends on ILO, IHI and NS, the -*> number of simultaneous shifts returned -*> by IPARMQ(ISPEC=15). The default for -*> (IHI-ILO+1) <= 500 is NS. The default -*> for (IHI-ILO+1) > 500 is 3*NS/2. -*> -*> IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. -*> -*> IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. -*> a multi-shift QR iteration. -*> -*> If IHI-ILO+1 is ... -*> -*> greater than ...but less ... the -*> or equal to ... than default is -*> -*> 0 30 NS = 2+ -*> 30 60 NS = 4+ -*> 60 150 NS = 10 -*> 150 590 NS = ** -*> 590 3000 NS = 64 -*> 3000 6000 NS = 128 -*> 6000 infinity NS = 256 -*> -*> (+) By default matrices of this order are -*> passed to the implicit double shift routine -*> xLAHQR. See IPARMQ(ISPEC=12) above. These -*> values of NS are used only in case of a rare -*> xLAHQR failure. -*> -*> (**) The asterisks (**) indicate an ad-hoc -*> function increasing from 10 to 64. -*> -*> IPARMQ(ISPEC=16) Select structured matrix multiply. -*> (See ISPEC=16 above for details.) -*> Default: 3. -*> -*> IPARMQ(ISPEC=17) Relative cost heuristic for blocksize selection. -*> Expressed as a percentage. -*> Default: 10. -*> \endverbatim -*> -* ===================================================================== - INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER IHI, ILO, ISPEC, LWORK, N - CHARACTER NAME*( * ), OPTS*( * ) -* -* ================================================================ -* .. Parameters .. - INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22, ICOST - PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, - $ ISHFTS = 15, IACC22 = 16, ICOST = 17 ) - INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP, RCOST - PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, - $ NIBBLE = 14, KNWSWP = 500, RCOST = 10 ) - REAL TWO - PARAMETER ( TWO = 2.0 ) -* .. -* .. Local Scalars .. - INTEGER NH, NS - INTEGER I, IC, IZ - CHARACTER SUBNAM*6 -* .. -* .. Intrinsic Functions .. - INTRINSIC LOG, MAX, MOD, NINT, REAL -* .. -* .. Executable Statements .. - IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. - $ ( ISPEC.EQ.IACC22 ) ) THEN -* -* ==== Set the number simultaneous shifts ==== -* - NH = IHI - ILO + 1 - NS = 2 - IF( NH.GE.30 ) - $ NS = 4 - IF( NH.GE.60 ) - $ NS = 10 - IF( NH.GE.150 ) - $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) - IF( NH.GE.590 ) - $ NS = 64 - IF( NH.GE.3000 ) - $ NS = 128 - IF( NH.GE.6000 ) - $ NS = 256 - NS = MAX( 2, NS-MOD( NS, 2 ) ) - END IF -* - IF( ISPEC.EQ.INMIN ) THEN -* -* -* ===== Matrices of order smaller than NMIN get sent -* . to xLAHQR, the classic double shift algorithm. -* . This must be at least 11. ==== -* - IPARMQ = NMIN -* - ELSE IF( ISPEC.EQ.INIBL ) THEN -* -* ==== INIBL: skip a multi-shift qr iteration and -* . whenever aggressive early deflation finds -* . at least (NIBBLE*(window size)/100) deflations. ==== -* - IPARMQ = NIBBLE -* - ELSE IF( ISPEC.EQ.ISHFTS ) THEN -* -* ==== NSHFTS: The number of simultaneous shifts ===== -* - IPARMQ = NS -* - ELSE IF( ISPEC.EQ.INWIN ) THEN -* -* ==== NW: deflation window size. ==== -* - IF( NH.LE.KNWSWP ) THEN - IPARMQ = NS - ELSE - IPARMQ = 3*NS / 2 - END IF -* - ELSE IF( ISPEC.EQ.IACC22 ) THEN -* -* ==== IACC22: Whether to accumulate reflections -* . before updating the far-from-diagonal elements -* . and whether to use 2-by-2 block structure while -* . 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 - 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 IF( ISPEC.EQ.ICOST ) THEN -* -* === Relative cost of near-the-diagonal chase vs -* BLAS updates === -* - IPARMQ = RCOST - ELSE -* ===== invalid value of ispec ===== - IPARMQ = -1 -* - END IF -* -* ==== End of IPARMQ ==== -* - END diff --git a/lib/linalg/fortran/lsame.f b/lib/linalg/fortran/lsame.f deleted file mode 100644 index 6aa4007065..0000000000 --- a/lib/linalg/fortran/lsame.f +++ /dev/null @@ -1,122 +0,0 @@ -*> \brief \b LSAME -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* LOGICAL FUNCTION LSAME(CA,CB) -* -* .. Scalar Arguments .. -* CHARACTER CA,CB -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> LSAME returns .TRUE. if CA is the same letter as CB regardless of -*> case. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] CA -*> \verbatim -*> CA is CHARACTER*1 -*> \endverbatim -*> -*> \param[in] CB -*> \verbatim -*> CB is CHARACTER*1 -*> CA and CB specify the single characters to be compared. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup aux_blas -* -* ===================================================================== - LOGICAL FUNCTION LSAME(CA,CB) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER CA,CB -* .. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC ICHAR -* .. -* .. Local Scalars .. - INTEGER INTA,INTB,ZCODE -* .. -* -* Test if the characters are equal -* - LSAME = CA .EQ. CB - IF (LSAME) RETURN -* -* Now test for equivalence if both characters are alphabetic. -* - ZCODE = ICHAR('Z') -* -* Use 'Z' rather than 'A' so that ASCII can be detected on Prime -* machines, on which ICHAR returns a value with bit 8 set. -* ICHAR('A') on Prime machines returns 193 which is the same as -* ICHAR('A') on an EBCDIC machine. -* - INTA = ICHAR(CA) - INTB = ICHAR(CB) -* - IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN -* -* ASCII is assumed - ZCODE is the ASCII code of either lower or -* upper case 'Z'. -* - IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32 - IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32 -* - ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN -* -* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or -* upper case 'Z'. -* - IF (INTA.GE.129 .AND. INTA.LE.137 .OR. - + INTA.GE.145 .AND. INTA.LE.153 .OR. - + INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64 - IF (INTB.GE.129 .AND. INTB.LE.137 .OR. - + INTB.GE.145 .AND. INTB.LE.153 .OR. - + INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64 -* - ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN -* -* ASCII is assumed, on Prime machines - ZCODE is the ASCII code -* plus 128 of either lower or upper case 'Z'. -* - IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32 - IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32 - END IF - LSAME = INTA .EQ. INTB -* -* RETURN -* -* End of LSAME -* - END diff --git a/lib/linalg/fortran/xerbla.f b/lib/linalg/fortran/xerbla.f deleted file mode 100644 index 6b141499ee..0000000000 --- a/lib/linalg/fortran/xerbla.f +++ /dev/null @@ -1,96 +0,0 @@ -*> \brief \b XERBLA -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download XERBLA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE XERBLA( SRNAME, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER*(*) SRNAME -* INTEGER INFO -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> XERBLA is an error handler for the LAPACK routines. -*> It is called by an LAPACK routine if an input parameter has an -*> invalid value. A message is printed and execution stops. -*> -*> Installers may consider modifying the STOP statement in order to -*> call system-specific exception-handling facilities. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SRNAME -*> \verbatim -*> SRNAME is CHARACTER*(*) -*> The name of the routine which called XERBLA. -*> \endverbatim -*> -*> \param[in] INFO -*> \verbatim -*> INFO is INTEGER -*> The position of the invalid parameter in the parameter list -*> of the calling routine. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER*(*) SRNAME - INTEGER INFO -* .. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC LEN_TRIM -* .. -* .. Executable Statements .. -* - WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO -* - STOP -* - 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', - $ 'an illegal value' ) -* -* End of XERBLA -* - END diff --git a/lib/linalg/fortran/zaxpy.f b/lib/linalg/fortran/zaxpy.f deleted file mode 100644 index 35c0e4b892..0000000000 --- a/lib/linalg/fortran/zaxpy.f +++ /dev/null @@ -1,139 +0,0 @@ -*> \brief \b ZAXPY -* -* =========== DOCUMENTATION =========== -* -* 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 -* .. -* .. Array Arguments .. -* COMPLEX*16 ZX(*),ZY(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> 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. -* -*> \ingroup complex16_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, 3/11/78. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZAXPY(N,ZA,ZX,INCX,ZY,INCY) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 ZA - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - COMPLEX*16 ZX(*),ZY(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,IX,IY -* .. -* .. External Functions .. - DOUBLE PRECISION DCABS1 - EXTERNAL DCABS1 -* .. - IF (N.LE.0) RETURN - IF (DCABS1(ZA).EQ.0.0d0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* - DO I = 1,N - ZY(I) = ZY(I) + ZA*ZX(I) - END DO - ELSE -* -* code for unequal increments or equal increments -* not equal to 1 -* - IX = 1 - IY = 1 - IF (INCX.LT.0) IX = (-N+1)*INCX + 1 - IF (INCY.LT.0) IY = (-N+1)*INCY + 1 - DO I = 1,N - ZY(IY) = ZY(IY) + ZA*ZX(IX) - IX = IX + INCX - IY = IY + INCY - END DO - END IF -* - RETURN -* -* End of ZAXPY -* - END diff --git a/lib/linalg/fortran/zcopy.f b/lib/linalg/fortran/zcopy.f deleted file mode 100644 index 1efcdb6b0f..0000000000 --- a/lib/linalg/fortran/zcopy.f +++ /dev/null @@ -1,125 +0,0 @@ -*> \brief \b ZCOPY -* -* =========== DOCUMENTATION =========== -* -* 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: -* ============= -*> -*> \verbatim -*> -*> 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. -* -*> \ingroup complex16_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, linpack, 4/11/78. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZCOPY(N,ZX,INCX,ZY,INCY) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - COMPLEX*16 ZX(*),ZY(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,IX,IY -* .. - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* - DO I = 1,N - ZY(I) = ZX(I) - END DO - ELSE -* -* code for unequal increments or equal increments -* not equal to 1 -* - IX = 1 - IY = 1 - IF (INCX.LT.0) IX = (-N+1)*INCX + 1 - IF (INCY.LT.0) IY = (-N+1)*INCY + 1 - DO I = 1,N - ZY(IY) = ZX(IX) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN -* -* End of ZCOPY -* - END diff --git a/lib/linalg/fortran/zdotc.f b/lib/linalg/fortran/zdotc.f deleted file mode 100644 index bcc29e2dad..0000000000 --- a/lib/linalg/fortran/zdotc.f +++ /dev/null @@ -1,134 +0,0 @@ -*> \brief \b ZDOTC -* -* =========== DOCUMENTATION =========== -* -* 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 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 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] 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. -* -*> \ingroup complex16_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, 3/11/78. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - COMPLEX*16 FUNCTION ZDOTC(N,ZX,INCX,ZY,INCY) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - COMPLEX*16 ZX(*),ZY(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - COMPLEX*16 ZTEMP - INTEGER I,IX,IY -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG -* .. - ZTEMP = (0.0d0,0.0d0) - ZDOTC = (0.0d0,0.0d0) - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* - DO I = 1,N - ZTEMP = ZTEMP + DCONJG(ZX(I))*ZY(I) - END DO - ELSE -* -* code for unequal increments or equal increments -* not equal to 1 -* - IX = 1 - IY = 1 - IF (INCX.LT.0) IX = (-N+1)*INCX + 1 - IF (INCY.LT.0) IY = (-N+1)*INCY + 1 - DO I = 1,N - ZTEMP = ZTEMP + DCONJG(ZX(IX))*ZY(IY) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - ZDOTC = ZTEMP - RETURN -* -* End of ZDOTC -* - END diff --git a/lib/linalg/fortran/zdrot.f b/lib/linalg/fortran/zdrot.f deleted file mode 100644 index 3145561d67..0000000000 --- a/lib/linalg/fortran/zdrot.f +++ /dev/null @@ -1,153 +0,0 @@ -*> \brief \b ZDROT -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE ZDROT( N, ZX, INCX, ZY, INCY, C, S ) -* -* .. Scalar Arguments .. -* INTEGER INCX, INCY, N -* DOUBLE PRECISION C, S -* .. -* .. Array Arguments .. -* COMPLEX*16 ZX( * ), ZY( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Applies a plane rotation, where the cos and sin (c and s) are real -*> and the vectors cx and cy are complex. -*> jack dongarra, linpack, 3/11/78. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the vectors cx and cy. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in,out] ZX -*> \verbatim -*> ZX is COMPLEX*16 array, dimension at least -*> ( 1 + ( N - 1 )*abs( INCX ) ). -*> Before entry, the incremented array ZX must contain the n -*> element vector cx. On exit, ZX is overwritten by the updated -*> vector cx. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> ZX. INCX must not be zero. -*> \endverbatim -*> -*> \param[in,out] ZY -*> \verbatim -*> ZY is COMPLEX*16 array, dimension at least -*> ( 1 + ( N - 1 )*abs( INCY ) ). -*> Before entry, the incremented array ZY must contain the n -*> element vector cy. On exit, ZY is overwritten by the updated -*> vector cy. -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> On entry, INCY specifies the increment for the elements of -*> ZY. INCY must not be zero. -*> \endverbatim -*> -*> \param[in] C -*> \verbatim -*> C is DOUBLE PRECISION -*> On entry, C specifies the cosine, cos. -*> \endverbatim -*> -*> \param[in] S -*> \verbatim -*> S is DOUBLE PRECISION -*> On entry, S specifies the sine, sin. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level1 -* -* ===================================================================== - SUBROUTINE ZDROT( N, ZX, INCX, ZY, INCY, C, S ) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX, INCY, N - DOUBLE PRECISION C, S -* .. -* .. Array Arguments .. - COMPLEX*16 ZX( * ), ZY( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IX, IY - COMPLEX*16 CTEMP -* .. -* .. Executable Statements .. -* - IF( N.LE.0 ) - $ RETURN - IF( INCX.EQ.1 .AND. INCY.EQ.1 ) THEN -* -* code for both increments equal to 1 -* - DO I = 1, N - CTEMP = C*ZX( I ) + S*ZY( I ) - ZY( I ) = C*ZY( I ) - S*ZX( I ) - ZX( I ) = CTEMP - END DO - ELSE -* -* code for unequal increments or equal increments not equal -* to 1 -* - IX = 1 - IY = 1 - IF( INCX.LT.0 ) - $ IX = ( -N+1 )*INCX + 1 - IF( INCY.LT.0 ) - $ IY = ( -N+1 )*INCY + 1 - DO I = 1, N - CTEMP = C*ZX( IX ) + S*ZY( IY ) - ZY( IY ) = C*ZY( IY ) - S*ZX( IX ) - ZX( IX ) = CTEMP - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN -* -* End of ZDROT -* - END diff --git a/lib/linalg/fortran/zdscal.f b/lib/linalg/fortran/zdscal.f deleted file mode 100644 index 5a16048771..0000000000 --- a/lib/linalg/fortran/zdscal.f +++ /dev/null @@ -1,123 +0,0 @@ -*> \brief \b ZDSCAL -* -* =========== DOCUMENTATION =========== -* -* 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 -* .. -* .. Array Arguments .. -* COMPLEX*16 ZX(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> 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. -* -*> \ingroup complex16_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, 3/11/78. -*> modified 3/93 to return if incx .le. 0. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZDSCAL(N,DA,ZX,INCX) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION DA - INTEGER INCX,N -* .. -* .. Array Arguments .. - COMPLEX*16 ZX(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,NINCX -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER (ONE=1.0D+0) -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, DIMAG -* .. - IF (N.LE.0 .OR. INCX.LE.0 .OR. DA.EQ.ONE) RETURN - IF (INCX.EQ.1) THEN -* -* code for increment equal to 1 -* - DO I = 1,N - ZX(I) = DCMPLX(DA*DBLE(ZX(I)),DA*DIMAG(ZX(I))) - END DO - ELSE -* -* code for increment not equal to 1 -* - NINCX = N*INCX - DO I = 1,NINCX,INCX - ZX(I) = DCMPLX(DA*DBLE(ZX(I)),DA*DIMAG(ZX(I))) - END DO - END IF - RETURN -* -* End of ZDSCAL -* - END diff --git a/lib/linalg/fortran/zgemm.f b/lib/linalg/fortran/zgemm.f deleted file mode 100644 index 0b712f1b73..0000000000 --- a/lib/linalg/fortran/zgemm.f +++ /dev/null @@ -1,477 +0,0 @@ -*> \brief \b ZGEMM -* -* =========== DOCUMENTATION =========== -* -* 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 -* CHARACTER TRANSA,TRANSB -* .. -* .. Array Arguments .. -* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZGEMM performs one of the matrix-matrix operations -*> -*> C := alpha*op( A )*op( B ) + beta*C, -*> -*> where op( X ) is one of -*> -*> op( X ) = X or op( X ) = X**T or op( X ) = X**H, -*> -*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) -*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] TRANSA -*> \verbatim -*> TRANSA is CHARACTER*1 -*> On entry, TRANSA specifies the form of op( A ) to be used in -*> the matrix multiplication as follows: -*> -*> TRANSA = 'N' or 'n', op( A ) = A. -*> -*> TRANSA = 'T' or 't', op( A ) = A**T. -*> -*> TRANSA = 'C' or 'c', op( A ) = A**H. -*> \endverbatim -*> -*> \param[in] TRANSB -*> \verbatim -*> TRANSB is CHARACTER*1 -*> On entry, TRANSB specifies the form of op( B ) to be used in -*> the matrix multiplication as follows: -*> -*> TRANSB = 'N' or 'n', op( B ) = B. -*> -*> TRANSB = 'T' or 't', op( B ) = B**T. -*> -*> TRANSB = 'C' or 'c', op( B ) = B**H. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of the matrix -*> op( A ) and of the matrix C. M must be at least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of the matrix -*> op( B ) and the number of columns of the matrix C. N must be -*> at least zero. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> On entry, K specifies the number of columns of the matrix -*> op( A ) and the number of rows of the matrix op( B ). K must -*> be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is COMPLEX*16 -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> 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 -*> the leading k by m part of the array A must contain the -*> matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. When TRANSA = 'N' or 'n' then -*> LDA must be at least max( 1, m ), otherwise LDA must be at -*> least max( 1, k ). -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is COMPLEX*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 -*> the leading n by k part of the array B must contain the -*> matrix B. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> On entry, LDB specifies the first dimension of B as declared -*> in the calling (sub) program. When TRANSB = 'N' or 'n' then -*> LDB must be at least max( 1, k ), otherwise LDB must be at -*> least max( 1, n ). -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is COMPLEX*16 -*> On entry, BETA specifies the scalar beta. When BETA is -*> supplied as zero then C need not be set on input. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is COMPLEX*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. -*> On exit, the array C is overwritten by the m by n matrix -*> ( alpha*op( A )*op( B ) + beta*C ). -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> On entry, LDC specifies the first dimension of C as declared -*> in the calling (sub) program. LDC must be at least -*> max( 1, m ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level3 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 3 Blas routine. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* -- Reference BLAS level3 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 ALPHA,BETA - INTEGER K,LDA,LDB,LDC,M,N - CHARACTER TRANSA,TRANSB -* .. -* .. Array Arguments .. - COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG,MAX -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I,INFO,J,L,NROWA,NROWB - LOGICAL CONJA,CONJB,NOTA,NOTB -* .. -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER (ONE= (1.0D+0,0.0D+0)) - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* -* Set NOTA and NOTB as true if A and B respectively are not -* conjugated or transposed, set CONJA and CONJB as true if A and -* B respectively are to be transposed but not conjugated and set -* NROWA and NROWB as the number of rows of A and B respectively. -* - NOTA = LSAME(TRANSA,'N') - NOTB = LSAME(TRANSB,'N') - CONJA = LSAME(TRANSA,'C') - CONJB = LSAME(TRANSB,'C') - IF (NOTA) THEN - NROWA = M - ELSE - NROWA = K - END IF - IF (NOTB) THEN - NROWB = K - ELSE - NROWB = N - END IF -* -* Test the input parameters. -* - INFO = 0 - IF ((.NOT.NOTA) .AND. (.NOT.CONJA) .AND. - + (.NOT.LSAME(TRANSA,'T'))) THEN - INFO = 1 - ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND. - + (.NOT.LSAME(TRANSB,'T'))) THEN - INFO = 2 - ELSE IF (M.LT.0) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (K.LT.0) THEN - INFO = 5 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 8 - ELSE IF (LDB.LT.MAX(1,NROWB)) THEN - INFO = 10 - ELSE IF (LDC.LT.MAX(1,M)) THEN - INFO = 13 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZGEMM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. - + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - IF (BETA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - C(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1,N - DO 30 I = 1,M - C(I,J) = BETA*C(I,J) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF (NOTB) THEN - IF (NOTA) THEN -* -* Form C := alpha*A*B + beta*C. -* - DO 90 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 50 I = 1,M - C(I,J) = ZERO - 50 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 60 I = 1,M - C(I,J) = BETA*C(I,J) - 60 CONTINUE - END IF - DO 80 L = 1,K - TEMP = ALPHA*B(L,J) - DO 70 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - ELSE IF (CONJA) THEN -* -* Form C := alpha*A**H*B + beta*C. -* - DO 120 J = 1,N - DO 110 I = 1,M - TEMP = ZERO - DO 100 L = 1,K - TEMP = TEMP + DCONJG(A(L,I))*B(L,J) - 100 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 110 CONTINUE - 120 CONTINUE - ELSE -* -* Form C := alpha*A**T*B + beta*C -* - DO 150 J = 1,N - DO 140 I = 1,M - TEMP = ZERO - DO 130 L = 1,K - TEMP = TEMP + A(L,I)*B(L,J) - 130 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 140 CONTINUE - 150 CONTINUE - END IF - ELSE IF (NOTA) THEN - IF (CONJB) THEN -* -* Form C := alpha*A*B**H + beta*C. -* - DO 200 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 160 I = 1,M - C(I,J) = ZERO - 160 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 170 I = 1,M - C(I,J) = BETA*C(I,J) - 170 CONTINUE - END IF - DO 190 L = 1,K - TEMP = ALPHA*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 -* - DO 250 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 210 I = 1,M - C(I,J) = ZERO - 210 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 220 I = 1,M - C(I,J) = BETA*C(I,J) - 220 CONTINUE - END IF - DO 240 L = 1,K - TEMP = ALPHA*B(J,L) - DO 230 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 230 CONTINUE - 240 CONTINUE - 250 CONTINUE - END IF - ELSE IF (CONJA) THEN - IF (CONJB) THEN -* -* Form C := alpha*A**H*B**H + beta*C. -* - DO 280 J = 1,N - DO 270 I = 1,M - TEMP = ZERO - DO 260 L = 1,K - TEMP = TEMP + DCONJG(A(L,I))*DCONJG(B(J,L)) - 260 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 270 CONTINUE - 280 CONTINUE - ELSE -* -* Form C := alpha*A**H*B**T + beta*C -* - DO 310 J = 1,N - DO 300 I = 1,M - TEMP = ZERO - DO 290 L = 1,K - TEMP = TEMP + DCONJG(A(L,I))*B(J,L) - 290 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 300 CONTINUE - 310 CONTINUE - END IF - ELSE - IF (CONJB) THEN -* -* Form C := alpha*A**T*B**H + beta*C -* - DO 340 J = 1,N - DO 330 I = 1,M - TEMP = ZERO - DO 320 L = 1,K - TEMP = TEMP + A(L,I)*DCONJG(B(J,L)) - 320 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 330 CONTINUE - 340 CONTINUE - ELSE -* -* Form C := alpha*A**T*B**T + beta*C -* - DO 370 J = 1,N - DO 360 I = 1,M - TEMP = ZERO - DO 350 L = 1,K - TEMP = TEMP + A(L,I)*B(J,L) - 350 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 360 CONTINUE - 370 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZGEMM -* - END diff --git a/lib/linalg/fortran/zgemv.f b/lib/linalg/fortran/zgemv.f deleted file mode 100644 index 2664454b94..0000000000 --- a/lib/linalg/fortran/zgemv.f +++ /dev/null @@ -1,347 +0,0 @@ -*> \brief \b ZGEMV -* -* =========== DOCUMENTATION =========== -* -* 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 -* CHARACTER TRANS -* .. -* .. Array Arguments .. -* COMPLEX*16 A(LDA,*),X(*),Y(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZGEMV performs one of the matrix-vector operations -*> -*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or -*> -*> y := alpha*A**H*x + beta*y, -*> -*> where alpha and beta are scalars, x and y are vectors and A is an -*> m by n matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the operation to be performed as -*> follows: -*> -*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -*> -*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. -*> -*> TRANS = 'C' or 'c' y := alpha*A**H*x + beta*y. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of the matrix A. -*> M must be at least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is COMPLEX*16 -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> 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 -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, m ). -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is COMPLEX*16 array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -*> and at least -*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -*> Before entry, the incremented array X must contain the -*> vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is COMPLEX*16 -*> On entry, BETA specifies the scalar beta. When BETA is -*> supplied as zero then Y need not be set on input. -*> \endverbatim -*> -*> \param[in,out] Y -*> \verbatim -*> Y is COMPLEX*16 array, dimension at least -*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -*> and at least -*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -*> Before entry with BETA non-zero, the incremented array Y -*> must contain the vector y. On exit, Y is overwritten by the -*> updated vector y. -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> On entry, INCY specifies the increment for the elements of -*> Y. INCY must not be zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> The vector and matrix arguments are not referenced when N = 0, or M = 0 -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 ALPHA,BETA - INTEGER INCX,INCY,LDA,M,N - CHARACTER TRANS -* .. -* .. Array Arguments .. - COMPLEX*16 A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER (ONE= (1.0D+0,0.0D+0)) - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY - LOGICAL NOCONJ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG,MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 1 - ELSE IF (M.LT.0) THEN - INFO = 2 - ELSE IF (N.LT.0) THEN - INFO = 3 - ELSE IF (LDA.LT.MAX(1,M)) THEN - INFO = 6 - ELSE IF (INCX.EQ.0) THEN - INFO = 8 - ELSE IF (INCY.EQ.0) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZGEMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. - + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN -* - NOCONJ = LSAME(TRANS,'T') -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF (LSAME(TRANS,'N')) THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (LENX-1)*INCX - END IF - IF (INCY.GT.0) THEN - KY = 1 - ELSE - KY = 1 - (LENY-1)*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF (BETA.NE.ONE) THEN - IF (INCY.EQ.1) THEN - IF (BETA.EQ.ZERO) THEN - DO 10 I = 1,LENY - Y(I) = ZERO - 10 CONTINUE - ELSE - DO 20 I = 1,LENY - Y(I) = BETA*Y(I) - 20 CONTINUE - END IF - ELSE - IY = KY - IF (BETA.EQ.ZERO) THEN - DO 30 I = 1,LENY - Y(IY) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40 I = 1,LENY - Y(IY) = BETA*Y(IY) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF (ALPHA.EQ.ZERO) RETURN - IF (LSAME(TRANS,'N')) THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF (INCY.EQ.1) THEN - DO 60 J = 1,N - TEMP = ALPHA*X(JX) - DO 50 I = 1,M - Y(I) = Y(I) + TEMP*A(I,J) - 50 CONTINUE - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80 J = 1,N - TEMP = ALPHA*X(JX) - IY = KY - DO 70 I = 1,M - Y(IY) = Y(IY) + TEMP*A(I,J) - IY = IY + INCY - 70 CONTINUE - JX = JX + INCX - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A**T*x + y or y := alpha*A**H*x + y. -* - JY = KY - IF (INCX.EQ.1) THEN - DO 110 J = 1,N - TEMP = ZERO - IF (NOCONJ) THEN - DO 90 I = 1,M - TEMP = TEMP + A(I,J)*X(I) - 90 CONTINUE - ELSE - DO 100 I = 1,M - TEMP = TEMP + DCONJG(A(I,J))*X(I) - 100 CONTINUE - END IF - Y(JY) = Y(JY) + ALPHA*TEMP - JY = JY + INCY - 110 CONTINUE - ELSE - DO 140 J = 1,N - TEMP = ZERO - IX = KX - IF (NOCONJ) THEN - DO 120 I = 1,M - TEMP = TEMP + A(I,J)*X(IX) - IX = IX + INCX - 120 CONTINUE - ELSE - DO 130 I = 1,M - TEMP = TEMP + DCONJG(A(I,J))*X(IX) - IX = IX + INCX - 130 CONTINUE - END IF - Y(JY) = Y(JY) + ALPHA*TEMP - JY = JY + INCY - 140 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZGEMV -* - END diff --git a/lib/linalg/fortran/zgerc.f b/lib/linalg/fortran/zgerc.f deleted file mode 100644 index 2eb4349367..0000000000 --- a/lib/linalg/fortran/zgerc.f +++ /dev/null @@ -1,224 +0,0 @@ -*> \brief \b ZGERC -* -* =========== DOCUMENTATION =========== -* -* 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 -* .. -* .. Array Arguments .. -* COMPLEX*16 A(LDA,*),X(*),Y(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZGERC performs the rank 1 operation -*> -*> A := alpha*x*y**H + A, -*> -*> where alpha is a scalar, x is an m element vector, y is an n element -*> vector and A is an m by n matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of the matrix A. -*> M must be at least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is COMPLEX*16 -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> 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. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -*> -*> \param[in] Y -*> \verbatim -*> Y is COMPLEX*16 array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCY ) ). -*> Before entry, the incremented array Y must contain the n -*> element vector y. -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> On entry, INCY specifies the increment for the elements of -*> Y. INCY must not be zero. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*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. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, m ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - INTEGER INCX,INCY,LDA,M,N -* .. -* .. Array Arguments .. - COMPLEX*16 A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I,INFO,IX,J,JY,KX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG,MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (M.LT.0) THEN - INFO = 1 - ELSE IF (N.LT.0) THEN - INFO = 2 - ELSE IF (INCX.EQ.0) THEN - INFO = 5 - ELSE IF (INCY.EQ.0) THEN - INFO = 7 - ELSE IF (LDA.LT.MAX(1,M)) THEN - INFO = 9 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZGERC ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF (INCY.GT.0) THEN - JY = 1 - ELSE - JY = 1 - (N-1)*INCY - END IF - IF (INCX.EQ.1) THEN - DO 20 J = 1,N - IF (Y(JY).NE.ZERO) THEN - TEMP = ALPHA*DCONJG(Y(JY)) - DO 10 I = 1,M - A(I,J) = A(I,J) + X(I)*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (M-1)*INCX - END IF - DO 40 J = 1,N - IF (Y(JY).NE.ZERO) THEN - TEMP = ALPHA*DCONJG(Y(JY)) - IX = KX - DO 30 I = 1,M - A(I,J) = A(I,J) + X(IX)*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of ZGERC -* - END diff --git a/lib/linalg/fortran/zheev.f b/lib/linalg/fortran/zheev.f deleted file mode 100644 index 59af34a742..0000000000 --- a/lib/linalg/fortran/zheev.f +++ /dev/null @@ -1,295 +0,0 @@ -*> \brief ZHEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZHEEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, -* INFO ) -* -* .. Scalar Arguments .. -* CHARACTER JOBZ, UPLO -* INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION RWORK( * ), W( * ) -* COMPLEX*16 A( LDA, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZHEEV computes all eigenvalues and, optionally, eigenvectors of a -*> complex Hermitian matrix A. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] JOBZ -*> \verbatim -*> JOBZ is CHARACTER*1 -*> = 'N': Compute eigenvalues only; -*> = 'V': Compute eigenvalues and eigenvectors. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA, N) -*> On entry, the Hermitian matrix A. If UPLO = 'U', the -*> leading N-by-N upper triangular part of A contains the -*> upper triangular part of the matrix A. If UPLO = 'L', -*> the leading N-by-N lower triangular part of A contains -*> the lower triangular part of the matrix A. -*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the -*> orthonormal eigenvectors of the matrix A. -*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') -*> or the upper triangle (if UPLO='U') of A, including the -*> diagonal, is destroyed. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (N) -*> If INFO = 0, the eigenvalues in ascending order. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 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 length of the array WORK. LWORK >= max(1,2*N-1). -*> For optimal efficiency, LWORK >= (NB+1)*N, -*> where NB is the blocksize for ZHETRD returned by ILAENV. -*> -*> 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] RWORK -*> \verbatim -*> RWORK is DOUBLE PRECISION array, dimension (max(1, 3*N-2)) -*> \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, the algorithm failed to converge; i -*> off-diagonal elements of an intermediate tridiagonal -*> 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. -* -*> \ingroup complex16HEeigen -* -* ===================================================================== - SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, - $ INFO ) -* -* -- LAPACK driver routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER JOBZ, UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION RWORK( * ), W( * ) - COMPLEX*16 A( LDA, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LOWER, LQUERY, WANTZ - INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, - $ LLWORK, LWKOPT, NB - DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, - $ SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, ZLANHE - EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE -* .. -* .. External Subroutines .. - EXTERNAL DSCAL, DSTERF, XERBLA, ZHETRD, ZLASCL, ZSTEQR, - $ ZUNGTR -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) - LOWER = LSAME( UPLO, 'L' ) - LQUERY = ( LWORK.EQ.-1 ) -* - INFO = 0 - IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF -* - IF( INFO.EQ.0 ) THEN - NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) - LWKOPT = MAX( 1, ( NB+1 )*N ) - WORK( 1 ) = LWKOPT -* - IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY ) - $ INFO = -8 - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHEEV ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - RETURN - END IF -* - IF( N.EQ.1 ) THEN - W( 1 ) = DBLE( A( 1, 1 ) ) - WORK( 1 ) = 1 - IF( WANTZ ) - $ A( 1, 1 ) = CONE - RETURN - END IF -* -* Get machine constants. -* - SAFMIN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Precision' ) - SMLNUM = SAFMIN / EPS - BIGNUM = ONE / SMLNUM - RMIN = SQRT( SMLNUM ) - RMAX = SQRT( BIGNUM ) -* -* Scale matrix to allowable range, if necessary. -* - ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK ) - ISCALE = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN - ISCALE = 1 - SIGMA = RMIN / ANRM - ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 - SIGMA = RMAX / ANRM - END IF - IF( ISCALE.EQ.1 ) - $ CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) -* -* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. -* - INDE = 1 - INDTAU = 1 - INDWRK = INDTAU + N - LLWORK = LWORK - INDWRK + 1 - CALL ZHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ), - $ WORK( INDWRK ), LLWORK, IINFO ) -* -* For eigenvalues only, call DSTERF. For eigenvectors, first call -* ZUNGTR to generate the unitary matrix, then call ZSTEQR. -* - IF( .NOT.WANTZ ) THEN - CALL DSTERF( N, W, RWORK( INDE ), INFO ) - ELSE - CALL ZUNGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), - $ LLWORK, IINFO ) - INDWRK = INDE + N - CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), A, LDA, - $ RWORK( INDWRK ), INFO ) - END IF -* -* If matrix was scaled, then rescale eigenvalues appropriately. -* - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = N - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF -* -* Set WORK(1) to optimal complex workspace size. -* - WORK( 1 ) = LWKOPT -* - RETURN -* -* End of ZHEEV -* - END diff --git a/lib/linalg/fortran/zheevd.f b/lib/linalg/fortran/zheevd.f deleted file mode 100644 index 7f58c7f726..0000000000 --- a/lib/linalg/fortran/zheevd.f +++ /dev/null @@ -1,395 +0,0 @@ -*> \brief ZHEEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZHEEVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, -* LRWORK, IWORK, LIWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER JOBZ, UPLO -* INTEGER INFO, LDA, LIWORK, LRWORK, LWORK, N -* .. -* .. Array Arguments .. -* INTEGER IWORK( * ) -* DOUBLE PRECISION RWORK( * ), W( * ) -* COMPLEX*16 A( LDA, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZHEEVD computes all eigenvalues and, optionally, eigenvectors of a -*> complex Hermitian matrix A. If eigenvectors are desired, it uses a -*> divide and conquer algorithm. -*> -*> 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] JOBZ -*> \verbatim -*> JOBZ is CHARACTER*1 -*> = 'N': Compute eigenvalues only; -*> = 'V': Compute eigenvalues and eigenvectors. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA, N) -*> On entry, the Hermitian matrix A. If UPLO = 'U', the -*> leading N-by-N upper triangular part of A contains the -*> upper triangular part of the matrix A. If UPLO = 'L', -*> the leading N-by-N lower triangular part of A contains -*> the lower triangular part of the matrix A. -*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the -*> orthonormal eigenvectors of the matrix A. -*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') -*> or the upper triangle (if UPLO='U') of A, including the -*> diagonal, is destroyed. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (N) -*> If INFO = 0, the eigenvalues in ascending order. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 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 length of the array WORK. -*> If N <= 1, LWORK must be at least 1. -*> If JOBZ = 'N' and N > 1, LWORK must be at least N + 1. -*> If JOBZ = 'V' and N > 1, LWORK must be at least 2*N + N**2. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal sizes of the WORK, RWORK and -*> IWORK arrays, returns these values as the first entries of -*> the WORK, RWORK and IWORK arrays, and no error message -*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] RWORK -*> \verbatim -*> RWORK is DOUBLE PRECISION array, -*> dimension (LRWORK) -*> On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. -*> \endverbatim -*> -*> \param[in] LRWORK -*> \verbatim -*> LRWORK is INTEGER -*> The dimension of the array RWORK. -*> If N <= 1, LRWORK must be at least 1. -*> If JOBZ = 'N' and N > 1, LRWORK must be at least N. -*> If JOBZ = 'V' and N > 1, LRWORK must be at least -*> 1 + 5*N + 2*N**2. -*> -*> If LRWORK = -1, then a workspace query is assumed; the -*> routine only calculates the optimal sizes of the WORK, RWORK -*> and IWORK arrays, returns these values as the first entries -*> of the WORK, RWORK and IWORK arrays, and no error message -*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) -*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. -*> \endverbatim -*> -*> \param[in] LIWORK -*> \verbatim -*> LIWORK is INTEGER -*> The dimension of the array IWORK. -*> If N <= 1, LIWORK must be at least 1. -*> If JOBZ = 'N' and N > 1, LIWORK must be at least 1. -*> If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. -*> -*> If LIWORK = -1, then a workspace query is assumed; the -*> routine only calculates the optimal sizes of the WORK, RWORK -*> and IWORK arrays, returns these values as the first entries -*> of the WORK, RWORK and IWORK arrays, and no error message -*> related to LWORK or LRWORK or LIWORK 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: if INFO = i and JOBZ = 'N', then the algorithm failed -*> to converge; i off-diagonal elements of an intermediate -*> tridiagonal form did not converge to zero; -*> if INFO = i and JOBZ = 'V', then the algorithm failed -*> to compute an eigenvalue 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. -* -*> \ingroup complex16HEeigen -* -*> \par Further Details: -* ===================== -*> -*> Modified description of INFO. Sven, 16 Feb 05. -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA -*> -* ===================================================================== - SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, - $ LRWORK, IWORK, LIWORK, INFO ) -* -* -- LAPACK driver routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER JOBZ, UPLO - INTEGER INFO, LDA, LIWORK, LRWORK, LWORK, N -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION RWORK( * ), W( * ) - COMPLEX*16 A( LDA, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LOWER, LQUERY, WANTZ - INTEGER IINFO, IMAX, INDE, INDRWK, INDTAU, INDWK2, - $ INDWRK, ISCALE, LIOPT, LIWMIN, LLRWK, LLWORK, - $ LLWRK2, LOPT, LROPT, LRWMIN, LWMIN - DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, - $ SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, ZLANHE - EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE -* .. -* .. External Subroutines .. - EXTERNAL DSCAL, DSTERF, XERBLA, ZHETRD, ZLACPY, ZLASCL, - $ ZSTEDC, ZUNMTR -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) - LOWER = LSAME( UPLO, 'L' ) - LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) -* - INFO = 0 - IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( N.LE.1 ) THEN - LWMIN = 1 - LRWMIN = 1 - LIWMIN = 1 - LOPT = LWMIN - LROPT = LRWMIN - LIOPT = LIWMIN - ELSE - IF( WANTZ ) THEN - LWMIN = 2*N + N*N - LRWMIN = 1 + 5*N + 2*N**2 - LIWMIN = 3 + 5*N - ELSE - LWMIN = N + 1 - LRWMIN = N - LIWMIN = 1 - END IF - LOPT = MAX( LWMIN, N + - $ N*ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) ) - LROPT = LRWMIN - LIOPT = LIWMIN - END IF - WORK( 1 ) = LOPT - RWORK( 1 ) = LROPT - IWORK( 1 ) = LIOPT -* - IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN - INFO = -8 - ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN - INFO = -10 - ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHEEVD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( N.EQ.1 ) THEN - W( 1 ) = DBLE( A( 1, 1 ) ) - IF( WANTZ ) - $ A( 1, 1 ) = CONE - RETURN - END IF -* -* Get machine constants. -* - SAFMIN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Precision' ) - SMLNUM = SAFMIN / EPS - BIGNUM = ONE / SMLNUM - RMIN = SQRT( SMLNUM ) - RMAX = SQRT( BIGNUM ) -* -* Scale matrix to allowable range, if necessary. -* - ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK ) - ISCALE = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN - ISCALE = 1 - SIGMA = RMIN / ANRM - ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 - SIGMA = RMAX / ANRM - END IF - IF( ISCALE.EQ.1 ) - $ CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) -* -* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. -* - INDE = 1 - INDTAU = 1 - INDWRK = INDTAU + N - INDRWK = INDE + N - INDWK2 = INDWRK + N*N - LLWORK = LWORK - INDWRK + 1 - LLWRK2 = LWORK - INDWK2 + 1 - LLRWK = LRWORK - INDRWK + 1 - CALL ZHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ), - $ WORK( INDWRK ), LLWORK, IINFO ) -* -* For eigenvalues only, call DSTERF. For eigenvectors, first call -* ZSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the -* tridiagonal matrix, then call ZUNMTR to multiply it to the -* Householder transformations represented as Householder vectors in -* A. -* - IF( .NOT.WANTZ ) THEN - CALL DSTERF( N, W, RWORK( INDE ), INFO ) - ELSE - CALL ZSTEDC( 'I', N, W, RWORK( INDE ), WORK( INDWRK ), N, - $ WORK( INDWK2 ), LLWRK2, RWORK( INDRWK ), LLRWK, - $ IWORK, LIWORK, INFO ) - CALL ZUNMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ), - $ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO ) - CALL ZLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA ) - END IF -* -* If matrix was scaled, then rescale eigenvalues appropriately. -* - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = N - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF -* - WORK( 1 ) = LOPT - RWORK( 1 ) = LROPT - IWORK( 1 ) = LIOPT -* - RETURN -* -* End of ZHEEVD -* - END diff --git a/lib/linalg/fortran/zhemv.f b/lib/linalg/fortran/zhemv.f deleted file mode 100644 index dad68bf25b..0000000000 --- a/lib/linalg/fortran/zhemv.f +++ /dev/null @@ -1,334 +0,0 @@ -*> \brief \b ZHEMV -* -* =========== DOCUMENTATION =========== -* -* 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 -* CHARACTER UPLO -* .. -* .. Array Arguments .. -* COMPLEX*16 A(LDA,*),X(*),Y(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZHEMV performs the matrix-vector operation -*> -*> y := alpha*A*x + beta*y, -*> -*> where alpha and beta are scalars, x and y are n element vectors and -*> A is an n by n hermitian matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the upper or lower -*> triangular part of the array A is to be referenced as -*> follows: -*> -*> UPLO = 'U' or 'u' Only the upper triangular part of A -*> is to be referenced. -*> -*> UPLO = 'L' or 'l' Only the lower triangular part of A -*> is to be referenced. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is COMPLEX*16 -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> 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 -*> lower triangular part of A is not referenced. -*> Before entry with UPLO = 'L' or 'l', the leading n by n -*> lower triangular part of the array A must contain the lower -*> triangular part of the hermitian matrix and the strictly -*> upper triangular part of A is not referenced. -*> Note that the imaginary parts of the diagonal elements need -*> not be set and are assumed to be zero. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, n ). -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is COMPLEX*16 array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCX ) ). -*> Before entry, the incremented array X must contain the n -*> element vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is COMPLEX*16 -*> On entry, BETA specifies the scalar beta. When BETA is -*> supplied as zero then Y need not be set on input. -*> \endverbatim -*> -*> \param[in,out] Y -*> \verbatim -*> Y is COMPLEX*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 -*> vector y. -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> On entry, INCY specifies the increment for the elements of -*> Y. INCY must not be zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> The vector and matrix arguments are not referenced when N = 0, or M = 0 -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 ALPHA,BETA - INTEGER INCX,INCY,LDA,N - CHARACTER UPLO -* .. -* .. Array Arguments .. - COMPLEX*16 A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER (ONE= (1.0D+0,0.0D+0)) - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP1,TEMP2 - INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE,DCONJG,MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (N.LT.0) THEN - INFO = 2 - ELSE IF (LDA.LT.MAX(1,N)) THEN - INFO = 5 - ELSE IF (INCX.EQ.0) THEN - INFO = 7 - ELSE IF (INCY.EQ.0) THEN - INFO = 10 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZHEMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN -* -* Set up the start points in X and Y. -* - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (N-1)*INCX - END IF - IF (INCY.GT.0) THEN - KY = 1 - ELSE - KY = 1 - (N-1)*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* -* First form y := beta*y. -* - IF (BETA.NE.ONE) THEN - IF (INCY.EQ.1) THEN - IF (BETA.EQ.ZERO) THEN - DO 10 I = 1,N - Y(I) = ZERO - 10 CONTINUE - ELSE - DO 20 I = 1,N - Y(I) = BETA*Y(I) - 20 CONTINUE - END IF - ELSE - IY = KY - IF (BETA.EQ.ZERO) THEN - DO 30 I = 1,N - Y(IY) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40 I = 1,N - Y(IY) = BETA*Y(IY) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF (ALPHA.EQ.ZERO) RETURN - IF (LSAME(UPLO,'U')) THEN -* -* Form y when A is stored in upper triangle. -* - IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN - DO 60 J = 1,N - TEMP1 = ALPHA*X(J) - TEMP2 = ZERO - DO 50 I = 1,J - 1 - Y(I) = Y(I) + TEMP1*A(I,J) - TEMP2 = TEMP2 + DCONJG(A(I,J))*X(I) - 50 CONTINUE - Y(J) = Y(J) + TEMP1*DBLE(A(J,J)) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80 J = 1,N - TEMP1 = ALPHA*X(JX) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70 I = 1,J - 1 - Y(IY) = Y(IY) + TEMP1*A(I,J) - TEMP2 = TEMP2 + DCONJG(A(I,J))*X(IX) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y(JY) = Y(JY) + TEMP1*DBLE(A(J,J)) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y when A is stored in lower triangle. -* - IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN - DO 100 J = 1,N - TEMP1 = ALPHA*X(J) - TEMP2 = ZERO - Y(J) = Y(J) + TEMP1*DBLE(A(J,J)) - DO 90 I = J + 1,N - Y(I) = Y(I) + TEMP1*A(I,J) - TEMP2 = TEMP2 + DCONJG(A(I,J))*X(I) - 90 CONTINUE - Y(J) = Y(J) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120 J = 1,N - TEMP1 = ALPHA*X(JX) - TEMP2 = ZERO - Y(JY) = Y(JY) + TEMP1*DBLE(A(J,J)) - IX = JX - IY = JY - DO 110 I = J + 1,N - IX = IX + INCX - IY = IY + INCY - Y(IY) = Y(IY) + TEMP1*A(I,J) - TEMP2 = TEMP2 + DCONJG(A(I,J))*X(IX) - 110 CONTINUE - Y(JY) = Y(JY) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHEMV -* - END diff --git a/lib/linalg/fortran/zher2.f b/lib/linalg/fortran/zher2.f deleted file mode 100644 index d1f2b57ec4..0000000000 --- a/lib/linalg/fortran/zher2.f +++ /dev/null @@ -1,314 +0,0 @@ -*> \brief \b ZHER2 -* -* =========== DOCUMENTATION =========== -* -* 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 -* CHARACTER UPLO -* .. -* .. Array Arguments .. -* COMPLEX*16 A(LDA,*),X(*),Y(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZHER2 performs the hermitian rank 2 operation -*> -*> A := alpha*x*y**H + conjg( alpha )*y*x**H + A, -*> -*> where alpha is a scalar, x and y are n element vectors and A is an n -*> by n hermitian matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the upper or lower -*> triangular part of the array A is to be referenced as -*> follows: -*> -*> UPLO = 'U' or 'u' Only the upper triangular part of A -*> is to be referenced. -*> -*> UPLO = 'L' or 'l' Only the lower triangular part of A -*> is to be referenced. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is COMPLEX*16 -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> 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. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -*> -*> \param[in] Y -*> \verbatim -*> Y is COMPLEX*16 array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCY ) ). -*> Before entry, the incremented array Y must contain the n -*> element vector y. -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> On entry, INCY specifies the increment for the elements of -*> Y. INCY must not be zero. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*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 -*> lower triangular part of A is not referenced. On exit, the -*> upper triangular part of the array A is overwritten by the -*> upper triangular part of the updated matrix. -*> Before entry with UPLO = 'L' or 'l', the leading n by n -*> lower triangular part of the array A must contain the lower -*> triangular part of the hermitian matrix and the strictly -*> upper triangular part of A is not referenced. On exit, the -*> lower triangular part of the array A is overwritten by the -*> lower triangular part of the updated matrix. -*> Note that the imaginary parts of the diagonal elements need -*> not be set, they are assumed to be zero, and on exit they -*> are set to zero. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, n ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - INTEGER INCX,INCY,LDA,N - CHARACTER UPLO -* .. -* .. Array Arguments .. - COMPLEX*16 A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP1,TEMP2 - INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE,DCONJG,MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (N.LT.0) THEN - INFO = 2 - ELSE IF (INCX.EQ.0) THEN - INFO = 5 - ELSE IF (INCY.EQ.0) THEN - INFO = 7 - ELSE IF (LDA.LT.MAX(1,N)) THEN - INFO = 9 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZHER2 ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (N-1)*INCX - END IF - IF (INCY.GT.0) THEN - KY = 1 - ELSE - KY = 1 - (N-1)*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF (LSAME(UPLO,'U')) THEN -* -* Form A when A is stored in the upper triangle. -* - IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN - DO 20 J = 1,N - IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN - TEMP1 = ALPHA*DCONJG(Y(J)) - TEMP2 = DCONJG(ALPHA*X(J)) - DO 10 I = 1,J - 1 - A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 - 10 CONTINUE - A(J,J) = DBLE(A(J,J)) + - + DBLE(X(J)*TEMP1+Y(J)*TEMP2) - ELSE - A(J,J) = DBLE(A(J,J)) - END IF - 20 CONTINUE - ELSE - DO 40 J = 1,N - IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN - TEMP1 = ALPHA*DCONJG(Y(JY)) - TEMP2 = DCONJG(ALPHA*X(JX)) - IX = KX - IY = KY - DO 30 I = 1,J - 1 - A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - A(J,J) = DBLE(A(J,J)) + - + DBLE(X(JX)*TEMP1+Y(JY)*TEMP2) - ELSE - A(J,J) = DBLE(A(J,J)) - END IF - JX = JX + INCX - JY = JY + INCY - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in the lower triangle. -* - IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN - DO 60 J = 1,N - IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN - TEMP1 = ALPHA*DCONJG(Y(J)) - TEMP2 = DCONJG(ALPHA*X(J)) - A(J,J) = DBLE(A(J,J)) + - + DBLE(X(J)*TEMP1+Y(J)*TEMP2) - DO 50 I = J + 1,N - A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 - 50 CONTINUE - ELSE - A(J,J) = DBLE(A(J,J)) - END IF - 60 CONTINUE - ELSE - DO 80 J = 1,N - IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN - TEMP1 = ALPHA*DCONJG(Y(JY)) - TEMP2 = DCONJG(ALPHA*X(JX)) - A(J,J) = DBLE(A(J,J)) + - + DBLE(X(JX)*TEMP1+Y(JY)*TEMP2) - IX = JX - IY = JY - DO 70 I = J + 1,N - IX = IX + INCX - IY = IY + INCY - A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 - 70 CONTINUE - ELSE - A(J,J) = DBLE(A(J,J)) - END IF - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHER2 -* - END diff --git a/lib/linalg/fortran/zher2k.f b/lib/linalg/fortran/zher2k.f deleted file mode 100644 index 5c75083cd5..0000000000 --- a/lib/linalg/fortran/zher2k.f +++ /dev/null @@ -1,440 +0,0 @@ -*> \brief \b ZHER2K -* -* =========== DOCUMENTATION =========== -* -* 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 -* INTEGER K,LDA,LDB,LDC,N -* CHARACTER TRANS,UPLO -* .. -* .. Array Arguments .. -* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZHER2K performs one of the hermitian rank 2k operations -*> -*> C := alpha*A*B**H + conjg( alpha )*B*A**H + beta*C, -*> -*> or -*> -*> C := alpha*A**H*B + conjg( alpha )*B**H*A + beta*C, -*> -*> where alpha and beta are scalars with beta real, C is an n by n -*> hermitian matrix and A and B are n by k matrices in the first case -*> and k by n matrices in the second case. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the upper or lower -*> triangular part of the array C is to be referenced as -*> follows: -*> -*> UPLO = 'U' or 'u' Only the upper triangular part of C -*> is to be referenced. -*> -*> UPLO = 'L' or 'l' Only the lower triangular part of C -*> is to be referenced. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the operation to be performed as -*> follows: -*> -*> TRANS = 'N' or 'n' C := alpha*A*B**H + -*> conjg( alpha )*B*A**H + -*> beta*C. -*> -*> TRANS = 'C' or 'c' C := alpha*A**H*B + -*> conjg( alpha )*B**H*A + -*> beta*C. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix C. N must be -*> at least zero. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> On entry with TRANS = 'N' or 'n', K specifies the number -*> of columns of the matrices A and B, and on entry with -*> TRANS = 'C' or 'c', K specifies the number of rows of the -*> matrices A and B. K must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is COMPLEX*16 . -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> 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 -*> the leading k by n part of the array A must contain the -*> matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. When TRANS = 'N' or 'n' -*> then LDA must be at least max( 1, n ), otherwise LDA must -*> be at least max( 1, k ). -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is COMPLEX*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 -*> the leading k by n part of the array B must contain the -*> matrix B. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> On entry, LDB specifies the first dimension of B as declared -*> in the calling (sub) program. When TRANS = 'N' or 'n' -*> then LDB must be at least max( 1, n ), otherwise LDB must -*> be at least max( 1, k ). -*> Unchanged on exit. -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is DOUBLE PRECISION . -*> On entry, BETA specifies the scalar beta. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> 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 -*> lower triangular part of C is not referenced. On exit, the -*> upper triangular part of the array C is overwritten by the -*> upper triangular part of the updated matrix. -*> Before entry with UPLO = 'L' or 'l', the leading n by n -*> lower triangular part of the array C must contain the lower -*> triangular part of the hermitian matrix and the strictly -*> upper triangular part of C is not referenced. On exit, the -*> lower triangular part of the array C is overwritten by the -*> lower triangular part of the updated matrix. -*> Note that the imaginary parts of the diagonal elements need -*> not be set, they are assumed to be zero, and on exit they -*> are set to zero. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> On entry, LDC specifies the first dimension of C as declared -*> in the calling (sub) program. LDC must be at least -*> max( 1, n ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level3 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 3 Blas routine. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> -*> -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. -*> Ed Anderson, Cray Research Inc. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* -- Reference BLAS level3 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - DOUBLE PRECISION BETA - INTEGER K,LDA,LDB,LDC,N - CHARACTER TRANS,UPLO -* .. -* .. Array Arguments .. - COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE,DCONJG,MAX -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP1,TEMP2 - INTEGER I,INFO,J,L,NROWA - LOGICAL UPPER -* .. -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER (ONE=1.0D+0) - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* -* Test the input parameters. -* - IF (LSAME(TRANS,'N')) THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME(UPLO,'U') -* - INFO = 0 - IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 1 - ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. - + (.NOT.LSAME(TRANS,'C'))) THEN - INFO = 2 - ELSE IF (N.LT.0) THEN - INFO = 3 - ELSE IF (K.LT.0) THEN - INFO = 4 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 7 - ELSE IF (LDB.LT.MAX(1,NROWA)) THEN - INFO = 9 - ELSE IF (LDC.LT.MAX(1,N)) THEN - INFO = 12 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZHER2K',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. - + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - IF (UPPER) THEN - IF (BETA.EQ.DBLE(ZERO)) THEN - DO 20 J = 1,N - DO 10 I = 1,J - C(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1,N - DO 30 I = 1,J - 1 - C(I,J) = BETA*C(I,J) - 30 CONTINUE - C(J,J) = BETA*DBLE(C(J,J)) - 40 CONTINUE - END IF - ELSE - IF (BETA.EQ.DBLE(ZERO)) THEN - DO 60 J = 1,N - DO 50 I = J,N - C(I,J) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80 J = 1,N - C(J,J) = BETA*DBLE(C(J,J)) - DO 70 I = J + 1,N - C(I,J) = BETA*C(I,J) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form C := alpha*A*B**H + conjg( alpha )*B*A**H + -* C. -* - IF (UPPER) THEN - DO 130 J = 1,N - IF (BETA.EQ.DBLE(ZERO)) THEN - DO 90 I = 1,J - C(I,J) = ZERO - 90 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 100 I = 1,J - 1 - C(I,J) = BETA*C(I,J) - 100 CONTINUE - C(J,J) = BETA*DBLE(C(J,J)) - ELSE - C(J,J) = DBLE(C(J,J)) - END IF - DO 120 L = 1,K - IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN - TEMP1 = ALPHA*DCONJG(B(J,L)) - TEMP2 = DCONJG(ALPHA*A(J,L)) - DO 110 I = 1,J - 1 - C(I,J) = C(I,J) + A(I,L)*TEMP1 + - + B(I,L)*TEMP2 - 110 CONTINUE - C(J,J) = DBLE(C(J,J)) + - + DBLE(A(J,L)*TEMP1+B(J,L)*TEMP2) - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180 J = 1,N - IF (BETA.EQ.DBLE(ZERO)) THEN - DO 140 I = J,N - C(I,J) = ZERO - 140 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 150 I = J + 1,N - C(I,J) = BETA*C(I,J) - 150 CONTINUE - C(J,J) = BETA*DBLE(C(J,J)) - ELSE - C(J,J) = DBLE(C(J,J)) - END IF - DO 170 L = 1,K - IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN - TEMP1 = ALPHA*DCONJG(B(J,L)) - TEMP2 = DCONJG(ALPHA*A(J,L)) - DO 160 I = J + 1,N - C(I,J) = C(I,J) + A(I,L)*TEMP1 + - + B(I,L)*TEMP2 - 160 CONTINUE - C(J,J) = DBLE(C(J,J)) + - + DBLE(A(J,L)*TEMP1+B(J,L)*TEMP2) - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A**H*B + conjg( alpha )*B**H*A + -* C. -* - IF (UPPER) THEN - DO 210 J = 1,N - DO 200 I = 1,J - TEMP1 = ZERO - TEMP2 = ZERO - DO 190 L = 1,K - TEMP1 = TEMP1 + DCONJG(A(L,I))*B(L,J) - TEMP2 = TEMP2 + DCONJG(B(L,I))*A(L,J) - 190 CONTINUE - IF (I.EQ.J) THEN - IF (BETA.EQ.DBLE(ZERO)) THEN - C(J,J) = DBLE(ALPHA*TEMP1+ - + DCONJG(ALPHA)*TEMP2) - ELSE - C(J,J) = BETA*DBLE(C(J,J)) + - + DBLE(ALPHA*TEMP1+ - + DCONJG(ALPHA)*TEMP2) - END IF - ELSE - IF (BETA.EQ.DBLE(ZERO)) THEN - C(I,J) = ALPHA*TEMP1 + DCONJG(ALPHA)*TEMP2 - ELSE - C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + - + DCONJG(ALPHA)*TEMP2 - END IF - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240 J = 1,N - DO 230 I = J,N - TEMP1 = ZERO - TEMP2 = ZERO - DO 220 L = 1,K - TEMP1 = TEMP1 + DCONJG(A(L,I))*B(L,J) - TEMP2 = TEMP2 + DCONJG(B(L,I))*A(L,J) - 220 CONTINUE - IF (I.EQ.J) THEN - IF (BETA.EQ.DBLE(ZERO)) THEN - C(J,J) = DBLE(ALPHA*TEMP1+ - + DCONJG(ALPHA)*TEMP2) - ELSE - C(J,J) = BETA*DBLE(C(J,J)) + - + DBLE(ALPHA*TEMP1+ - + DCONJG(ALPHA)*TEMP2) - END IF - ELSE - IF (BETA.EQ.DBLE(ZERO)) THEN - C(I,J) = ALPHA*TEMP1 + DCONJG(ALPHA)*TEMP2 - ELSE - C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + - + DCONJG(ALPHA)*TEMP2 - END IF - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHER2K -* - END diff --git a/lib/linalg/fortran/zhetd2.f b/lib/linalg/fortran/zhetd2.f deleted file mode 100644 index a6d900b7c7..0000000000 --- a/lib/linalg/fortran/zhetd2.f +++ /dev/null @@ -1,331 +0,0 @@ -*> \brief \b ZHETD2 reduces a Hermitian matrix to real symmetric tridiagonal form by an unitary similarity transformation (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZHETD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ), E( * ) -* COMPLEX*16 A( LDA, * ), TAU( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZHETD2 reduces a complex Hermitian matrix A to real symmetric -*> tridiagonal form T by a unitary similarity transformation: -*> Q**H * A * Q = T. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies whether the upper or lower triangular part of the -*> Hermitian matrix A is stored: -*> = 'U': Upper triangular -*> = 'L': Lower triangular -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading -*> n-by-n upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading n-by-n lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> On exit, if UPLO = 'U', the diagonal and first superdiagonal -*> of A are overwritten by the corresponding elements of the -*> tridiagonal matrix T, and the elements above the first -*> superdiagonal, with the array TAU, represent the unitary -*> matrix Q as a product of elementary reflectors; if UPLO -*> = 'L', the diagonal and first subdiagonal of A are over- -*> written by the corresponding elements of the tridiagonal -*> matrix T, and the elements below the first subdiagonal, with -*> the array TAU, represent the unitary matrix Q as a product -*> of elementary reflectors. See Further Details. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> The diagonal elements of the tridiagonal matrix T: -*> D(i) = A(i,i). -*> \endverbatim -*> -*> \param[out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> The off-diagonal elements of the tridiagonal matrix T: -*> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (N-1) -*> The scalar factors of the elementary reflectors (see Further -*> Details). -*> \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. -* -*> \ingroup complex16HEcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> If UPLO = 'U', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(n-1) . . . H(2) H(1). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**H -*> -*> where tau is a complex scalar, and v is a complex vector with -*> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in -*> A(1:i-1,i+1), and tau in TAU(i). -*> -*> If UPLO = 'L', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(1) H(2) . . . H(n-1). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**H -*> -*> where tau is a complex scalar, and v is a complex vector with -*> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), -*> and tau in TAU(i). -*> -*> The contents of A on exit are illustrated by the following examples -*> with n = 5: -*> -*> if UPLO = 'U': if UPLO = 'L': -*> -*> ( d e v2 v3 v4 ) ( d ) -*> ( d e v3 v4 ) ( e d ) -*> ( d e v4 ) ( v1 e d ) -*> ( d e ) ( v1 v2 e d ) -*> ( d ) ( v1 v2 v3 e d ) -*> -*> where d and e denote diagonal and off-diagonal elements of T, and vi -*> denotes an element of the vector defining H(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ) - COMPLEX*16 A( LDA, * ), TAU( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO, HALF - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ), - $ HALF = ( 0.5D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I - COMPLEX*16 ALPHA, TAUI -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZAXPY, ZHEMV, ZHER2, ZLARFG -* .. -* .. External Functions .. - LOGICAL LSAME - COMPLEX*16 ZDOTC - EXTERNAL LSAME, ZDOTC -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - UPPER = LSAME( UPLO, 'U') - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHETD2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Reduce the upper triangle of A -* - A( N, N ) = DBLE( A( N, N ) ) - DO 10 I = N - 1, 1, -1 -* -* Generate elementary reflector H(i) = I - tau * v * v**H -* to annihilate A(1:i-1,i+1) -* - ALPHA = A( I, I+1 ) - CALL ZLARFG( I, ALPHA, A( 1, I+1 ), 1, TAUI ) - E( I ) = DBLE( ALPHA ) -* - IF( TAUI.NE.ZERO ) THEN -* -* Apply H(i) from both sides to A(1:i,1:i) -* - A( I, I+1 ) = ONE -* -* Compute x := tau * A * v storing x in TAU(1:i) -* - CALL ZHEMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO, - $ TAU, 1 ) -* -* Compute w := x - 1/2 * tau * (x**H * v) * v -* - ALPHA = -HALF*TAUI*ZDOTC( I, TAU, 1, A( 1, I+1 ), 1 ) - CALL ZAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 ) -* -* Apply the transformation as a rank-2 update: -* A := A - v * w**H - w * v**H -* - CALL ZHER2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, - $ LDA ) -* - ELSE - A( I, I ) = DBLE( A( I, I ) ) - END IF - A( I, I+1 ) = E( I ) - D( I+1 ) = DBLE( A( I+1, I+1 ) ) - TAU( I ) = TAUI - 10 CONTINUE - D( 1 ) = DBLE( A( 1, 1 ) ) - ELSE -* -* Reduce the lower triangle of A -* - A( 1, 1 ) = DBLE( A( 1, 1 ) ) - DO 20 I = 1, N - 1 -* -* Generate elementary reflector H(i) = I - tau * v * v**H -* to annihilate A(i+2:n,i) -* - ALPHA = A( I+1, I ) - CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAUI ) - E( I ) = DBLE( ALPHA ) -* - IF( TAUI.NE.ZERO ) THEN -* -* Apply H(i) from both sides to A(i+1:n,i+1:n) -* - A( I+1, I ) = ONE -* -* Compute x := tau * A * v storing y in TAU(i:n-1) -* - CALL ZHEMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, - $ A( I+1, I ), 1, ZERO, TAU( I ), 1 ) -* -* Compute w := x - 1/2 * tau * (x**H * v) * v -* - ALPHA = -HALF*TAUI*ZDOTC( N-I, TAU( I ), 1, A( I+1, I ), - $ 1 ) - CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 ) -* -* Apply the transformation as a rank-2 update: -* A := A - v * w**H - w * v**H -* - CALL ZHER2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1, - $ A( I+1, I+1 ), LDA ) -* - ELSE - A( I+1, I+1 ) = DBLE( A( I+1, I+1 ) ) - END IF - A( I+1, I ) = E( I ) - D( I ) = DBLE( A( I, I ) ) - TAU( I ) = TAUI - 20 CONTINUE - D( N ) = DBLE( A( N, N ) ) - END IF -* - RETURN -* -* End of ZHETD2 -* - END diff --git a/lib/linalg/fortran/zhetrd.f b/lib/linalg/fortran/zhetrd.f deleted file mode 100644 index 5b7d6546cc..0000000000 --- a/lib/linalg/fortran/zhetrd.f +++ /dev/null @@ -1,375 +0,0 @@ -*> \brief \b ZHETRD -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZHETRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ), E( * ) -* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZHETRD reduces a complex Hermitian matrix A to real symmetric -*> tridiagonal form T by a unitary similarity transformation: -*> Q**H * A * Q = T. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading -*> N-by-N upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading N-by-N lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> On exit, if UPLO = 'U', the diagonal and first superdiagonal -*> of A are overwritten by the corresponding elements of the -*> tridiagonal matrix T, and the elements above the first -*> superdiagonal, with the array TAU, represent the unitary -*> matrix Q as a product of elementary reflectors; if UPLO -*> = 'L', the diagonal and first subdiagonal of A are over- -*> written by the corresponding elements of the tridiagonal -*> matrix T, and the elements below the first subdiagonal, with -*> the array TAU, represent the unitary matrix Q as a product -*> of elementary reflectors. See Further Details. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> The diagonal elements of the tridiagonal matrix T: -*> D(i) = A(i,i). -*> \endverbatim -*> -*> \param[out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> The off-diagonal elements of the tridiagonal matrix T: -*> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (N-1) -*> The scalar factors of the elementary reflectors (see Further -*> Details). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 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. -*> For optimum performance LWORK >= N*NB, where NB is the -*> optimal blocksize. -*> -*> 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 -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16HEcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> If UPLO = 'U', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(n-1) . . . H(2) H(1). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**H -*> -*> where tau is a complex scalar, and v is a complex vector with -*> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in -*> A(1:i-1,i+1), and tau in TAU(i). -*> -*> If UPLO = 'L', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(1) H(2) . . . H(n-1). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**H -*> -*> where tau is a complex scalar, and v is a complex vector with -*> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), -*> and tau in TAU(i). -*> -*> The contents of A on exit are illustrated by the following examples -*> with n = 5: -*> -*> if UPLO = 'U': if UPLO = 'L': -*> -*> ( d e v2 v3 v4 ) ( d ) -*> ( d e v3 v4 ) ( e d ) -*> ( d e v4 ) ( v1 e d ) -*> ( d e ) ( v1 v2 e d ) -*> ( d ) ( v1 v2 v3 e d ) -*> -*> where d and e denote diagonal and off-diagonal elements of T, and vi -*> denotes an element of the vector defining H(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ) - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, UPPER - INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZHER2K, ZHETD2, ZLATRD -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - LQUERY = ( LWORK.EQ.-1 ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN - INFO = -9 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Determine the block size. -* - NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHETRD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NX = N - IWS = 1 - IF( NB.GT.1 .AND. NB.LT.N ) THEN -* -* Determine when to cross over from blocked to unblocked code -* (last block is always handled by unblocked code). -* - NX = MAX( NB, ILAENV( 3, 'ZHETRD', UPLO, N, -1, -1, -1 ) ) - IF( NX.LT.N ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: determine the -* minimum value of NB, and reduce NB or force use of -* unblocked code by setting NX = N. -* - NB = MAX( LWORK / LDWORK, 1 ) - NBMIN = ILAENV( 2, 'ZHETRD', UPLO, N, -1, -1, -1 ) - IF( NB.LT.NBMIN ) - $ NX = N - END IF - ELSE - NX = N - END IF - ELSE - NB = 1 - END IF -* - IF( UPPER ) THEN -* -* Reduce the upper triangle of A. -* Columns 1:kk are handled by the unblocked method. -* - KK = N - ( ( N-NX+NB-1 ) / NB )*NB - DO 20 I = N - NB + 1, KK + 1, -NB -* -* Reduce columns i:i+nb-1 to tridiagonal form and form the -* matrix W which is needed to update the unreduced part of -* the matrix -* - CALL ZLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, - $ LDWORK ) -* -* Update the unreduced submatrix A(1:i-1,1:i-1), using an -* update of the form: A := A - V*W**H - W*V**H -* - CALL ZHER2K( UPLO, 'No transpose', I-1, NB, -CONE, - $ A( 1, I ), LDA, WORK, LDWORK, ONE, A, LDA ) -* -* Copy superdiagonal elements back into A, and diagonal -* elements into D -* - DO 10 J = I, I + NB - 1 - A( J-1, J ) = E( J-1 ) - D( J ) = DBLE( A( J, J ) ) - 10 CONTINUE - 20 CONTINUE -* -* Use unblocked code to reduce the last or only block -* - CALL ZHETD2( UPLO, KK, A, LDA, D, E, TAU, IINFO ) - ELSE -* -* Reduce the lower triangle of A -* - DO 40 I = 1, N - NX, NB -* -* Reduce columns i:i+nb-1 to tridiagonal form and form the -* matrix W which is needed to update the unreduced part of -* the matrix -* - CALL ZLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), - $ TAU( I ), WORK, LDWORK ) -* -* Update the unreduced submatrix A(i+nb:n,i+nb:n), using -* an update of the form: A := A - V*W**H - W*V**H -* - CALL ZHER2K( UPLO, 'No transpose', N-I-NB+1, NB, -CONE, - $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE, - $ A( I+NB, I+NB ), LDA ) -* -* Copy subdiagonal elements back into A, and diagonal -* elements into D -* - DO 30 J = I, I + NB - 1 - A( J+1, J ) = E( J ) - D( J ) = DBLE( A( J, J ) ) - 30 CONTINUE - 40 CONTINUE -* -* Use unblocked code to reduce the last or only block -* - CALL ZHETD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ), - $ TAU( I ), IINFO ) - END IF -* - WORK( 1 ) = LWKOPT - RETURN -* -* End of ZHETRD -* - END diff --git a/lib/linalg/fortran/zhpr.f b/lib/linalg/fortran/zhpr.f deleted file mode 100644 index 2ba5774a21..0000000000 --- a/lib/linalg/fortran/zhpr.f +++ /dev/null @@ -1,276 +0,0 @@ -*> \brief \b ZHPR -* -* =========== DOCUMENTATION =========== -* -* 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 -* CHARACTER UPLO -* .. -* .. Array Arguments .. -* COMPLEX*16 AP(*),X(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZHPR performs the hermitian rank 1 operation -*> -*> A := alpha*x*x**H + A, -*> -*> where alpha is a real scalar, x is an n element vector and A is an -*> n by n hermitian matrix, supplied in packed form. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the upper or lower -*> triangular part of the matrix A is supplied in the packed -*> array AP as follows: -*> -*> UPLO = 'U' or 'u' The upper triangular part of A is -*> supplied in AP. -*> -*> UPLO = 'L' or 'l' The lower triangular part of A is -*> supplied in AP. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> 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. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -*> -*> \param[in,out] AP -*> \verbatim -*> AP is COMPLEX*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 -*> packed sequentially, column by column, so that AP( 1 ) -*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -*> and a( 2, 2 ) respectively, and so on. On exit, the array -*> AP is overwritten by the upper triangular part of the -*> updated matrix. -*> Before entry with UPLO = 'L' or 'l', the array AP must -*> contain the lower triangular part of the hermitian matrix -*> packed sequentially, column by column, so that AP( 1 ) -*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -*> and a( 3, 1 ) respectively, and so on. On exit, the array -*> AP is overwritten by the lower triangular part of the -*> updated matrix. -*> Note that the imaginary parts of the diagonal elements need -*> not be set, they are assumed to be zero, and on exit they -*> are set to zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZHPR(UPLO,N,ALPHA,X,INCX,AP) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX,N - CHARACTER UPLO -* .. -* .. Array Arguments .. - COMPLEX*16 AP(*),X(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I,INFO,IX,J,JX,K,KK,KX -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE,DCONJG -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (N.LT.0) THEN - INFO = 2 - ELSE IF (INCX.EQ.0) THEN - INFO = 5 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZHPR ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((N.EQ.0) .OR. (ALPHA.EQ.DBLE(ZERO))) RETURN -* -* Set the start point in X if the increment is not unity. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* - KK = 1 - IF (LSAME(UPLO,'U')) THEN -* -* Form A when upper triangle is stored in AP. -* - IF (INCX.EQ.1) THEN - DO 20 J = 1,N - IF (X(J).NE.ZERO) THEN - TEMP = ALPHA*DCONJG(X(J)) - K = KK - DO 10 I = 1,J - 1 - AP(K) = AP(K) + X(I)*TEMP - K = K + 1 - 10 CONTINUE - AP(KK+J-1) = DBLE(AP(KK+J-1)) + DBLE(X(J)*TEMP) - ELSE - AP(KK+J-1) = DBLE(AP(KK+J-1)) - END IF - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = ALPHA*DCONJG(X(JX)) - IX = KX - DO 30 K = KK,KK + J - 2 - AP(K) = AP(K) + X(IX)*TEMP - IX = IX + INCX - 30 CONTINUE - AP(KK+J-1) = DBLE(AP(KK+J-1)) + DBLE(X(JX)*TEMP) - ELSE - AP(KK+J-1) = DBLE(AP(KK+J-1)) - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF (INCX.EQ.1) THEN - DO 60 J = 1,N - IF (X(J).NE.ZERO) THEN - TEMP = ALPHA*DCONJG(X(J)) - AP(KK) = DBLE(AP(KK)) + DBLE(TEMP*X(J)) - K = KK + 1 - DO 50 I = J + 1,N - AP(K) = AP(K) + X(I)*TEMP - K = K + 1 - 50 CONTINUE - ELSE - AP(KK) = DBLE(AP(KK)) - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - JX = KX - DO 80 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = ALPHA*DCONJG(X(JX)) - AP(KK) = DBLE(AP(KK)) + DBLE(TEMP*X(JX)) - IX = JX - DO 70 K = KK + 1,KK + N - J - IX = IX + INCX - AP(K) = AP(K) + X(IX)*TEMP - 70 CONTINUE - ELSE - AP(KK) = DBLE(AP(KK)) - END IF - JX = JX + INCX - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHPR -* - END diff --git a/lib/linalg/fortran/zlacgv.f b/lib/linalg/fortran/zlacgv.f deleted file mode 100644 index dc935e08f4..0000000000 --- a/lib/linalg/fortran/zlacgv.f +++ /dev/null @@ -1,113 +0,0 @@ -*> \brief \b ZLACGV conjugates a complex vector. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLACGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLACGV( N, X, INCX ) -* -* .. Scalar Arguments .. -* INTEGER INCX, N -* .. -* .. Array Arguments .. -* COMPLEX*16 X( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLACGV conjugates a complex vector of length N. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The length of the vector X. N >= 0. -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is COMPLEX*16 array, dimension -*> (1+(N-1)*abs(INCX)) -*> On entry, the vector of length N to be conjugated. -*> On exit, X is overwritten with conjg(X). -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> The spacing between successive elements of X. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - SUBROUTINE ZLACGV( N, X, INCX ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX, N -* .. -* .. Array Arguments .. - COMPLEX*16 X( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IOFF -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG -* .. -* .. Executable Statements .. -* - IF( INCX.EQ.1 ) THEN - DO 10 I = 1, N - X( I ) = DCONJG( X( I ) ) - 10 CONTINUE - ELSE - IOFF = 1 - IF( INCX.LT.0 ) - $ IOFF = 1 - ( N-1 )*INCX - DO 20 I = 1, N - X( IOFF ) = DCONJG( X( IOFF ) ) - IOFF = IOFF + INCX - 20 CONTINUE - END IF - RETURN -* -* End of ZLACGV -* - END diff --git a/lib/linalg/fortran/zlacpy.f b/lib/linalg/fortran/zlacpy.f deleted file mode 100644 index 06017509e0..0000000000 --- a/lib/linalg/fortran/zlacpy.f +++ /dev/null @@ -1,156 +0,0 @@ -*> \brief \b ZLACPY copies all or part of one two-dimensional array to another. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLACPY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER LDA, LDB, M, N -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLACPY copies all or part of a two-dimensional matrix A to another -*> matrix B. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies the part of the matrix A to be copied to B. -*> = 'U': Upper triangular part -*> = 'L': Lower triangular part -*> Otherwise: All of the matrix A -*> \endverbatim -*> -*> \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] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> The m by n matrix A. If UPLO = 'U', only the upper trapezium -*> is accessed; if UPLO = 'L', only the lower trapezium is -*> accessed. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] B -*> \verbatim -*> B is COMPLEX*16 array, dimension (LDB,N) -*> On exit, B = A in the locations specified by UPLO. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDB, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( LSAME( UPLO, 'U' ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, MIN( J, M ) - B( I, J ) = A( I, J ) - 10 CONTINUE - 20 CONTINUE -* - ELSE IF( LSAME( UPLO, 'L' ) ) THEN - DO 40 J = 1, N - DO 30 I = J, M - B( I, J ) = A( I, J ) - 30 CONTINUE - 40 CONTINUE -* - ELSE - DO 60 J = 1, N - DO 50 I = 1, M - B( I, J ) = A( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF -* - RETURN -* -* End of ZLACPY -* - END diff --git a/lib/linalg/fortran/zlacrm.f b/lib/linalg/fortran/zlacrm.f deleted file mode 100644 index ce8b9b02c5..0000000000 --- a/lib/linalg/fortran/zlacrm.f +++ /dev/null @@ -1,182 +0,0 @@ -*> \brief \b ZLACRM multiplies a complex matrix by a square real matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLACRM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK ) -* -* .. Scalar Arguments .. -* INTEGER LDA, LDB, LDC, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION B( LDB, * ), RWORK( * ) -* COMPLEX*16 A( LDA, * ), C( LDC, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLACRM performs a very simple matrix-matrix multiplication: -*> C := A * B, -*> where A is M by N and complex; B is N by N and real; -*> C is M by N and complex. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A and of the matrix C. -*> M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns and rows of the matrix B and -*> the number of columns of the matrix C. -*> N >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA, N) -*> On entry, A contains the M by N matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >=max(1,M). -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB, N) -*> On entry, B contains the N by N matrix B. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >=max(1,N). -*> \endverbatim -*> -*> \param[out] C -*> \verbatim -*> C is COMPLEX*16 array, dimension (LDC, N) -*> On exit, C contains the M by N matrix C. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >=max(1,N). -*> \endverbatim -*> -*> \param[out] RWORK -*> \verbatim -*> RWORK is DOUBLE PRECISION array, dimension (2*M*N) -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER LDA, LDB, LDC, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION B( LDB, * ), RWORK( * ) - COMPLEX*16 A( LDA, * ), C( LDC, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, L -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, DIMAG -* .. -* .. External Subroutines .. - EXTERNAL DGEMM -* .. -* .. Executable Statements .. -* -* Quick return if possible. -* - IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) - $ RETURN -* - DO 20 J = 1, N - DO 10 I = 1, M - RWORK( ( J-1 )*M+I ) = DBLE( A( I, J ) ) - 10 CONTINUE - 20 CONTINUE -* - L = M*N + 1 - CALL DGEMM( 'N', 'N', M, N, N, ONE, RWORK, M, B, LDB, ZERO, - $ RWORK( L ), M ) - DO 40 J = 1, N - DO 30 I = 1, M - C( I, J ) = RWORK( L+( J-1 )*M+I-1 ) - 30 CONTINUE - 40 CONTINUE -* - DO 60 J = 1, N - DO 50 I = 1, M - RWORK( ( J-1 )*M+I ) = DIMAG( A( I, J ) ) - 50 CONTINUE - 60 CONTINUE - CALL DGEMM( 'N', 'N', M, N, N, ONE, RWORK, M, B, LDB, ZERO, - $ RWORK( L ), M ) - DO 80 J = 1, N - DO 70 I = 1, M - C( I, J ) = DCMPLX( DBLE( C( I, J ) ), - $ RWORK( L+( J-1 )*M+I-1 ) ) - 70 CONTINUE - 80 CONTINUE -* - RETURN -* -* End of ZLACRM -* - END diff --git a/lib/linalg/fortran/zladiv.f b/lib/linalg/fortran/zladiv.f deleted file mode 100644 index ae111d73d6..0000000000 --- a/lib/linalg/fortran/zladiv.f +++ /dev/null @@ -1,94 +0,0 @@ -*> \brief \b ZLADIV performs complex division in real arithmetic, avoiding unnecessary overflow. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLADIV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* COMPLEX*16 FUNCTION ZLADIV( X, Y ) -* -* .. Scalar Arguments .. -* COMPLEX*16 X, Y -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLADIV := X / Y, where X and Y are complex. The computation of X / Y -*> will not overflow on an intermediary step unless the results -*> overflows. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] X -*> \verbatim -*> X is COMPLEX*16 -*> \endverbatim -*> -*> \param[in] Y -*> \verbatim -*> Y is COMPLEX*16 -*> The complex scalars X and Y. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - COMPLEX*16 FUNCTION ZLADIV( X, Y ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 X, Y -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION ZI, ZR -* .. -* .. External Subroutines .. - EXTERNAL DLADIV -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, DIMAG -* .. -* .. Executable Statements .. -* - CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR, - $ ZI ) - ZLADIV = DCMPLX( ZR, ZI ) -* - RETURN -* -* End of ZLADIV -* - END diff --git a/lib/linalg/fortran/zlaed0.f b/lib/linalg/fortran/zlaed0.f deleted file mode 100644 index c4deac037a..0000000000 --- a/lib/linalg/fortran/zlaed0.f +++ /dev/null @@ -1,368 +0,0 @@ -*> \brief \b ZLAED0 used by ZSTEDC. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmetric tridiagonal matrix using the divide and conquer method. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLAED0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK, -* IWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDQ, LDQS, N, QSIZ -* .. -* .. Array Arguments .. -* INTEGER IWORK( * ) -* DOUBLE PRECISION D( * ), E( * ), RWORK( * ) -* COMPLEX*16 Q( LDQ, * ), QSTORE( LDQS, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Using the divide and conquer method, ZLAED0 computes all eigenvalues -*> of a symmetric tridiagonal matrix which is one diagonal block of -*> those from reducing a dense or band Hermitian matrix and -*> corresponding eigenvectors of the dense or band matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] QSIZ -*> \verbatim -*> QSIZ is INTEGER -*> The dimension of the unitary matrix used to reduce -*> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the diagonal elements of the tridiagonal matrix. -*> On exit, the eigenvalues in ascending order. -*> \endverbatim -*> -*> \param[in,out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> On entry, the off-diagonal elements of the tridiagonal matrix. -*> On exit, E has been destroyed. -*> \endverbatim -*> -*> \param[in,out] Q -*> \verbatim -*> Q is COMPLEX*16 array, dimension (LDQ,N) -*> On entry, Q must contain an QSIZ x N matrix whose columns -*> unitarily orthonormal. It is a part of the unitary matrix -*> that reduces the full dense Hermitian matrix to a -*> (reducible) symmetric tridiagonal matrix. -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max(1,N). -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, -*> the dimension of IWORK must be at least -*> 6 + 6*N + 5*N*lg N -*> ( lg( N ) = smallest integer k -*> such that 2^k >= N ) -*> \endverbatim -*> -*> \param[out] RWORK -*> \verbatim -*> RWORK is DOUBLE PRECISION array, -*> dimension (1 + 3*N + 2*N*lg N + 3*N**2) -*> ( lg( N ) = smallest integer k -*> such that 2^k >= N ) -*> \endverbatim -*> -*> \param[out] QSTORE -*> \verbatim -*> QSTORE is COMPLEX*16 array, dimension (LDQS, N) -*> Used to store parts of -*> the eigenvector matrix when the updating matrix multiplies -*> take place. -*> \endverbatim -*> -*> \param[in] LDQS -*> \verbatim -*> LDQS is INTEGER -*> The leading dimension of the array QSTORE. -*> LDQS >= max(1,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 an eigenvalue 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. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK, - $ IWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDQ, LDQS, N, QSIZ -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION D( * ), E( * ), RWORK( * ) - COMPLEX*16 Q( LDQ, * ), QSTORE( LDQS, * ) -* .. -* -* ===================================================================== -* -* Warning: N could be as big as QSIZ! -* -* .. Parameters .. - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.D+0 ) -* .. -* .. Local Scalars .. - INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM, - $ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM, - $ J, K, LGN, LL, MATSIZ, MSD2, SMLSIZ, SMM1, - $ SPM1, SPM2, SUBMAT, SUBPBS, TLVLS - DOUBLE PRECISION TEMP -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DSTEQR, XERBLA, ZCOPY, ZLACRM, ZLAED7 -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, LOG, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* -* IF( ICOMPQ .LT. 0 .OR. ICOMPQ .GT. 2 ) THEN -* INFO = -1 -* ELSE IF( ( ICOMPQ .EQ. 1 ) .AND. ( QSIZ .LT. MAX( 0, N ) ) ) -* $ THEN - IF( QSIZ.LT.MAX( 0, N ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZLAED0', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - SMLSIZ = ILAENV( 9, 'ZLAED0', ' ', 0, 0, 0, 0 ) -* -* Determine the size and placement of the submatrices, and save in -* the leading elements of IWORK. -* - IWORK( 1 ) = N - SUBPBS = 1 - TLVLS = 0 - 10 CONTINUE - IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN - DO 20 J = SUBPBS, 1, -1 - IWORK( 2*J ) = ( IWORK( J )+1 ) / 2 - IWORK( 2*J-1 ) = IWORK( J ) / 2 - 20 CONTINUE - TLVLS = TLVLS + 1 - SUBPBS = 2*SUBPBS - GO TO 10 - END IF - DO 30 J = 2, SUBPBS - IWORK( J ) = IWORK( J ) + IWORK( J-1 ) - 30 CONTINUE -* -* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 -* using rank-1 modifications (cuts). -* - SPM1 = SUBPBS - 1 - DO 40 I = 1, SPM1 - SUBMAT = IWORK( I ) + 1 - SMM1 = SUBMAT - 1 - D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) ) - D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) ) - 40 CONTINUE -* - INDXQ = 4*N + 3 -* -* Set up workspaces for eigenvalues only/accumulate new vectors -* routine -* - TEMP = LOG( DBLE( N ) ) / LOG( TWO ) - LGN = INT( TEMP ) - IF( 2**LGN.LT.N ) - $ LGN = LGN + 1 - IF( 2**LGN.LT.N ) - $ LGN = LGN + 1 - IPRMPT = INDXQ + N + 1 - IPERM = IPRMPT + N*LGN - IQPTR = IPERM + N*LGN - IGIVPT = IQPTR + N + 2 - IGIVCL = IGIVPT + N*LGN -* - IGIVNM = 1 - IQ = IGIVNM + 2*N*LGN - IWREM = IQ + N**2 + 1 -* Initialize pointers - DO 50 I = 0, SUBPBS - IWORK( IPRMPT+I ) = 1 - IWORK( IGIVPT+I ) = 1 - 50 CONTINUE - IWORK( IQPTR ) = 1 -* -* Solve each submatrix eigenproblem at the bottom of the divide and -* conquer tree. -* - CURR = 0 - DO 70 I = 0, SPM1 - IF( I.EQ.0 ) THEN - SUBMAT = 1 - MATSIZ = IWORK( 1 ) - ELSE - SUBMAT = IWORK( I ) + 1 - MATSIZ = IWORK( I+1 ) - IWORK( I ) - END IF - LL = IQ - 1 + IWORK( IQPTR+CURR ) - CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ), - $ RWORK( LL ), MATSIZ, RWORK, INFO ) - CALL ZLACRM( QSIZ, MATSIZ, Q( 1, SUBMAT ), LDQ, RWORK( LL ), - $ MATSIZ, QSTORE( 1, SUBMAT ), LDQS, - $ RWORK( IWREM ) ) - IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2 - CURR = CURR + 1 - IF( INFO.GT.0 ) THEN - INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1 - RETURN - END IF - K = 1 - DO 60 J = SUBMAT, IWORK( I+1 ) - IWORK( INDXQ+J ) = K - K = K + 1 - 60 CONTINUE - 70 CONTINUE -* -* Successively merge eigensystems of adjacent submatrices -* into eigensystem for the corresponding larger matrix. -* -* while ( SUBPBS > 1 ) -* - CURLVL = 1 - 80 CONTINUE - IF( SUBPBS.GT.1 ) THEN - SPM2 = SUBPBS - 2 - DO 90 I = 0, SPM2, 2 - IF( I.EQ.0 ) THEN - SUBMAT = 1 - MATSIZ = IWORK( 2 ) - MSD2 = IWORK( 1 ) - CURPRB = 0 - ELSE - SUBMAT = IWORK( I ) + 1 - MATSIZ = IWORK( I+2 ) - IWORK( I ) - MSD2 = MATSIZ / 2 - CURPRB = CURPRB + 1 - END IF -* -* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) -* into an eigensystem of size MATSIZ. ZLAED7 handles the case -* when the eigenvectors of a full or band Hermitian matrix (which -* was reduced to tridiagonal form) are desired. -* -* I am free to use Q as a valuable working space until Loop 150. -* - CALL ZLAED7( MATSIZ, MSD2, QSIZ, TLVLS, CURLVL, CURPRB, - $ D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS, - $ E( SUBMAT+MSD2-1 ), IWORK( INDXQ+SUBMAT ), - $ RWORK( IQ ), IWORK( IQPTR ), IWORK( IPRMPT ), - $ IWORK( IPERM ), IWORK( IGIVPT ), - $ IWORK( IGIVCL ), RWORK( IGIVNM ), - $ Q( 1, SUBMAT ), RWORK( IWREM ), - $ IWORK( SUBPBS+1 ), INFO ) - IF( INFO.GT.0 ) THEN - INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1 - RETURN - END IF - IWORK( I / 2+1 ) = IWORK( I+2 ) - 90 CONTINUE - SUBPBS = SUBPBS / 2 - CURLVL = CURLVL + 1 - GO TO 80 - END IF -* -* end while -* -* Re-merge the eigenvalues/vectors which were deflated at the final -* merge step. -* - DO 100 I = 1, N - J = IWORK( INDXQ+I ) - RWORK( I ) = D( J ) - CALL ZCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 ) - 100 CONTINUE - CALL DCOPY( N, RWORK, 1, D, 1 ) -* - RETURN -* -* End of ZLAED0 -* - END diff --git a/lib/linalg/fortran/zlaed7.f b/lib/linalg/fortran/zlaed7.f deleted file mode 100644 index 83f32d8b81..0000000000 --- a/lib/linalg/fortran/zlaed7.f +++ /dev/null @@ -1,382 +0,0 @@ -*> \brief \b ZLAED7 used by ZSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is dense. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLAED7 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, -* LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM, -* GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK, -* INFO ) -* -* .. Scalar Arguments .. -* INTEGER CURLVL, CURPBM, CUTPNT, INFO, LDQ, N, QSIZ, -* $ TLVLS -* DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. -* INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ), -* $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * ) -* DOUBLE PRECISION D( * ), GIVNUM( 2, * ), QSTORE( * ), RWORK( * ) -* COMPLEX*16 Q( LDQ, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLAED7 computes the updated eigensystem of a diagonal -*> matrix after modification by a rank-one symmetric matrix. This -*> routine is used only for the eigenproblem which requires all -*> eigenvalues and optionally eigenvectors of a dense or banded -*> Hermitian matrix that has been reduced to tridiagonal form. -*> -*> T = Q(in) ( D(in) + RHO * Z*Z**H ) Q**H(in) = Q(out) * D(out) * Q**H(out) -*> -*> where Z = Q**Hu, u is a vector of length N with ones in the -*> CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. -*> -*> The eigenvectors of the original matrix are stored in Q, and the -*> eigenvalues are in D. The algorithm consists of three stages: -*> -*> 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 occurrence the dimension of the -*> secular equation problem is reduced by one. This stage is -*> performed by the routine DLAED2. -*> -*> The second stage consists of calculating the updated -*> eigenvalues. This is done by finding the roots of the secular -*> equation via the routine DLAED4 (as called by SLAED3). -*> This routine also calculates the eigenvectors of the current -*> problem. -*> -*> The final stage consists of computing the updated eigenvectors -*> directly using the updated eigenvalues. The eigenvectors for -*> the current problem are multiplied with the eigenvectors from -*> the overall problem. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in] CUTPNT -*> \verbatim -*> CUTPNT is INTEGER -*> Contains the location of the last eigenvalue in the leading -*> sub-matrix. min(1,N) <= CUTPNT <= N. -*> \endverbatim -*> -*> \param[in] QSIZ -*> \verbatim -*> QSIZ is INTEGER -*> The dimension of the unitary matrix used to reduce -*> the full matrix to tridiagonal form. QSIZ >= N. -*> \endverbatim -*> -*> \param[in] TLVLS -*> \verbatim -*> TLVLS is INTEGER -*> The total number of merging levels in the overall divide and -*> conquer tree. -*> \endverbatim -*> -*> \param[in] CURLVL -*> \verbatim -*> CURLVL is INTEGER -*> The current level in the overall merge routine, -*> 0 <= curlvl <= tlvls. -*> \endverbatim -*> -*> \param[in] CURPBM -*> \verbatim -*> CURPBM is INTEGER -*> The current problem in the current level in the overall -*> merge routine (counting from upper left to lower right). -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the eigenvalues of the rank-1-perturbed matrix. -*> On exit, the eigenvalues of the repaired matrix. -*> \endverbatim -*> -*> \param[in,out] Q -*> \verbatim -*> Q is COMPLEX*16 array, dimension (LDQ,N) -*> On entry, the eigenvectors of the rank-1-perturbed matrix. -*> On exit, the eigenvectors of the repaired tridiagonal matrix. -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max(1,N). -*> \endverbatim -*> -*> \param[in] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> Contains the subdiagonal element used to create the rank-1 -*> modification. -*> \endverbatim -*> -*> \param[out] INDXQ -*> \verbatim -*> INDXQ is INTEGER array, dimension (N) -*> This contains the permutation which will reintegrate the -*> subproblem just solved back into sorted order, -*> ie. D( INDXQ( I = 1, N ) ) will be in ascending order. -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (4*N) -*> \endverbatim -*> -*> \param[out] RWORK -*> \verbatim -*> RWORK is DOUBLE PRECISION array, -*> dimension (3*N+2*QSIZ*N) -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (QSIZ*N) -*> \endverbatim -*> -*> \param[in,out] QSTORE -*> \verbatim -*> QSTORE is DOUBLE PRECISION array, dimension (N**2+1) -*> Stores eigenvectors of submatrices encountered during -*> divide and conquer, packed together. QPTR points to -*> beginning of the submatrices. -*> \endverbatim -*> -*> \param[in,out] QPTR -*> \verbatim -*> QPTR is INTEGER array, dimension (N+2) -*> List of indices pointing to beginning of submatrices stored -*> in QSTORE. The submatrices are numbered starting at the -*> bottom left of the divide and conquer tree, from left to -*> right and bottom to top. -*> \endverbatim -*> -*> \param[in] PRMPTR -*> \verbatim -*> PRMPTR is INTEGER array, dimension (N lg N) -*> Contains a list of pointers which indicate where in PERM a -*> level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) -*> indicates the size of the permutation and also the size of -*> the full, non-deflated problem. -*> \endverbatim -*> -*> \param[in] PERM -*> \verbatim -*> PERM is INTEGER array, dimension (N lg N) -*> Contains the permutations (from deflation and sorting) to be -*> applied to each eigenblock. -*> \endverbatim -*> -*> \param[in] GIVPTR -*> \verbatim -*> GIVPTR is INTEGER array, dimension (N lg N) -*> Contains a list of pointers which indicate where in GIVCOL a -*> level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) -*> indicates the number of Givens rotations. -*> \endverbatim -*> -*> \param[in] GIVCOL -*> \verbatim -*> GIVCOL is INTEGER array, dimension (2, N lg N) -*> Each pair of numbers indicates a pair of columns to take place -*> in a Givens rotation. -*> \endverbatim -*> -*> \param[in] GIVNUM -*> \verbatim -*> GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N) -*> Each number indicates the S value to be used in the -*> corresponding Givens rotation. -*> \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, an eigenvalue did not converge -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, - $ LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM, - $ GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK, - $ INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER CURLVL, CURPBM, CUTPNT, INFO, LDQ, N, QSIZ, - $ TLVLS - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ), - $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * ) - DOUBLE PRECISION D( * ), GIVNUM( 2, * ), QSTORE( * ), RWORK( * ) - COMPLEX*16 Q( LDQ, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER COLTYP, CURR, I, IDLMDA, INDX, - $ INDXC, INDXP, IQ, IW, IZ, K, N1, N2, PTR -* .. -* .. External Subroutines .. - EXTERNAL DLAED9, DLAEDA, DLAMRG, XERBLA, ZLACRM, ZLAED8 -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* -* IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN -* INFO = -1 -* ELSE IF( N.LT.0 ) THEN - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN - INFO = -2 - ELSE IF( QSIZ.LT.N ) THEN - INFO = -3 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZLAED7', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* 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 DLAED2 and SLAED3. -* - IZ = 1 - IDLMDA = IZ + N - IW = IDLMDA + N - IQ = IW + N -* - INDX = 1 - INDXC = INDX + N - COLTYP = INDXC + N - INDXP = COLTYP + N -* -* Form the z-vector which consists of the last row of Q_1 and the -* first row of Q_2. -* - PTR = 1 + 2**TLVLS - DO 10 I = 1, CURLVL - 1 - PTR = PTR + 2**( TLVLS-I ) - 10 CONTINUE - CURR = PTR + CURPBM - CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, - $ GIVCOL, GIVNUM, QSTORE, QPTR, RWORK( IZ ), - $ RWORK( IZ+N ), INFO ) -* -* When solving the final problem, we no longer need the stored data, -* so we will overwrite the data from this level onto the previously -* used storage space. -* - IF( CURLVL.EQ.TLVLS ) THEN - QPTR( CURR ) = 1 - PRMPTR( CURR ) = 1 - GIVPTR( CURR ) = 1 - END IF -* -* Sort and Deflate eigenvalues. -* - CALL ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, RWORK( IZ ), - $ RWORK( IDLMDA ), WORK, QSIZ, RWORK( IW ), - $ IWORK( INDXP ), IWORK( INDX ), INDXQ, - $ PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ), - $ GIVCOL( 1, GIVPTR( CURR ) ), - $ GIVNUM( 1, GIVPTR( CURR ) ), INFO ) - PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N - GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR ) -* -* Solve Secular Equation. -* - IF( K.NE.0 ) THEN - CALL DLAED9( K, 1, K, N, D, RWORK( IQ ), K, RHO, - $ RWORK( IDLMDA ), RWORK( IW ), - $ QSTORE( QPTR( CURR ) ), K, INFO ) - CALL ZLACRM( QSIZ, K, WORK, QSIZ, QSTORE( QPTR( CURR ) ), K, Q, - $ LDQ, RWORK( IQ ) ) - QPTR( CURR+1 ) = QPTR( CURR ) + K**2 - IF( INFO.NE.0 ) THEN - RETURN - END IF -* -* Prepare the INDXQ sorting premutation. -* - N1 = K - N2 = N - K - CALL DLAMRG( N1, N2, D, 1, -1, INDXQ ) - ELSE - QPTR( CURR+1 ) = QPTR( CURR ) - DO 20 I = 1, N - INDXQ( I ) = I - 20 CONTINUE - END IF -* - RETURN -* -* End of ZLAED7 -* - END diff --git a/lib/linalg/fortran/zlaed8.f b/lib/linalg/fortran/zlaed8.f deleted file mode 100644 index 995a673de9..0000000000 --- a/lib/linalg/fortran/zlaed8.f +++ /dev/null @@ -1,483 +0,0 @@ -*> \brief \b ZLAED8 used by ZSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matrix is dense. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLAED8 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, -* Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, -* GIVCOL, GIVNUM, INFO ) -* -* .. Scalar Arguments .. -* INTEGER CUTPNT, GIVPTR, INFO, K, LDQ, LDQ2, N, QSIZ -* DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. -* INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ), -* $ INDXQ( * ), PERM( * ) -* DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), W( * ), -* $ Z( * ) -* COMPLEX*16 Q( LDQ, * ), Q2( LDQ2, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLAED8 merges the two sets of eigenvalues 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 -*> eigenvalues are close together or if there is a tiny element in the -*> Z vector. For each such occurrence the order of the related secular -*> equation problem is reduced by one. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[out] K -*> \verbatim -*> K is INTEGER -*> Contains the number of non-deflated eigenvalues. -*> This is the order of the related secular equation. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in] QSIZ -*> \verbatim -*> QSIZ is INTEGER -*> The dimension of the unitary matrix used to reduce -*> the dense or band matrix to tridiagonal form. -*> QSIZ >= N if ICOMPQ = 1. -*> \endverbatim -*> -*> \param[in,out] Q -*> \verbatim -*> Q is COMPLEX*16 array, dimension (LDQ,N) -*> On entry, Q contains the eigenvectors of the partially solved -*> system which has been previously updated in matrix -*> multiplies with other partially solved eigensystems. -*> On exit, Q contains the trailing (N-K) updated eigenvectors -*> (those which were deflated) in its last N-K columns. -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max( 1, N ). -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, D contains the eigenvalues of the two submatrices to -*> be combined. On exit, D contains the trailing (N-K) updated -*> eigenvalues (those which were deflated) sorted into increasing -*> order. -*> \endverbatim -*> -*> \param[in,out] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> Contains the off diagonal element associated with the rank-1 -*> cut which originally split the two submatrices which are now -*> being recombined. RHO is modified during the computation to -*> the value required by DLAED3. -*> \endverbatim -*> -*> \param[in] CUTPNT -*> \verbatim -*> CUTPNT is INTEGER -*> Contains the location of the last eigenvalue in the leading -*> sub-matrix. MIN(1,N) <= CUTPNT <= N. -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (N) -*> On input this vector contains the updating vector (the last -*> row of the first sub-eigenvector matrix and the first row of -*> the second sub-eigenvector matrix). The contents of Z are -*> destroyed during the updating process. -*> \endverbatim -*> -*> \param[out] DLAMDA -*> \verbatim -*> DLAMDA is DOUBLE PRECISION array, dimension (N) -*> Contains a copy of the first K eigenvalues which will be used -*> by DLAED3 to form the secular equation. -*> \endverbatim -*> -*> \param[out] Q2 -*> \verbatim -*> Q2 is COMPLEX*16 array, dimension (LDQ2,N) -*> If ICOMPQ = 0, Q2 is not referenced. Otherwise, -*> Contains a copy of the first K eigenvectors which will be used -*> by DLAED7 in a matrix multiply (DGEMM) to update the new -*> eigenvectors. -*> \endverbatim -*> -*> \param[in] LDQ2 -*> \verbatim -*> LDQ2 is INTEGER -*> The leading dimension of the array Q2. LDQ2 >= max( 1, N ). -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (N) -*> This will hold the first k values of the final -*> deflation-altered z-vector and will be passed to DLAED3. -*> \endverbatim -*> -*> \param[out] INDXP -*> \verbatim -*> INDXP 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 INDXP(1:K) -*> points to the nondeflated D-values and INDXP(K+1:N) -*> points to the deflated eigenvalues. -*> \endverbatim -*> -*> \param[out] INDX -*> \verbatim -*> INDX is INTEGER array, dimension (N) -*> This will contain the permutation used to sort the contents of -*> D into ascending order. -*> \endverbatim -*> -*> \param[in] INDXQ -*> \verbatim -*> INDXQ is INTEGER array, dimension (N) -*> This contains the permutation which separately sorts the two -*> sub-problems in D into ascending order. Note that elements in -*> the second half of this permutation must first have CUTPNT -*> added to their values in order to be accurate. -*> \endverbatim -*> -*> \param[out] PERM -*> \verbatim -*> PERM is INTEGER array, dimension (N) -*> Contains the permutations (from deflation and sorting) to be -*> applied to each eigenblock. -*> \endverbatim -*> -*> \param[out] GIVPTR -*> \verbatim -*> GIVPTR is INTEGER -*> Contains the number of Givens rotations which took place in -*> this subproblem. -*> \endverbatim -*> -*> \param[out] GIVCOL -*> \verbatim -*> GIVCOL is INTEGER array, dimension (2, N) -*> Each pair of numbers indicates a pair of columns to take place -*> in a Givens rotation. -*> \endverbatim -*> -*> \param[out] GIVNUM -*> \verbatim -*> GIVNUM is DOUBLE PRECISION array, dimension (2, N) -*> Each number indicates the S value to be used in the -*> corresponding Givens rotation. -*> \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. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, - $ Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, - $ GIVCOL, GIVNUM, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER CUTPNT, GIVPTR, INFO, K, LDQ, LDQ2, N, QSIZ - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ), - $ INDXQ( * ), PERM( * ) - DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), W( * ), - $ Z( * ) - COMPLEX*16 Q( LDQ, * ), Q2( LDQ2, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT - PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0, - $ TWO = 2.0D0, EIGHT = 8.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2 - DOUBLE PRECISION C, EPS, S, T, TAU, TOL -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DLAPY2 - EXTERNAL IDAMAX, DLAMCH, DLAPY2 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLAMRG, DSCAL, XERBLA, ZCOPY, ZDROT, - $ ZLACPY -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( QSIZ.LT.N ) THEN - INFO = -3 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN - INFO = -8 - ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN - INFO = -12 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZLAED8', -INFO ) - RETURN - 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 -* (or at least some IWORK entries which used in *laed7 for GIVPTR). -* - GIVPTR = 0 -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - N1 = CUTPNT - N2 = N - N1 - N1P1 = N1 + 1 -* - IF( RHO.LT.ZERO ) THEN - CALL DSCAL( N2, MONE, Z( N1P1 ), 1 ) - END IF -* -* Normalize z so that norm(z) = 1 -* - T = ONE / SQRT( TWO ) - DO 10 J = 1, N - INDX( J ) = J - 10 CONTINUE - CALL DSCAL( N, T, Z, 1 ) - RHO = ABS( TWO*RHO ) -* -* Sort the eigenvalues into increasing order -* - DO 20 I = CUTPNT + 1, N - INDXQ( I ) = INDXQ( I ) + CUTPNT - 20 CONTINUE - DO 30 I = 1, N - DLAMDA( I ) = D( INDXQ( I ) ) - W( I ) = Z( INDXQ( I ) ) - 30 CONTINUE - I = 1 - J = CUTPNT + 1 - CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDX ) - DO 40 I = 1, N - D( I ) = DLAMDA( INDX( I ) ) - Z( I ) = W( INDX( I ) ) - 40 CONTINUE -* -* Calculate the allowable deflation tolerance -* - IMAX = IDAMAX( N, Z, 1 ) - JMAX = IDAMAX( N, D, 1 ) - EPS = DLAMCH( 'Epsilon' ) - TOL = EIGHT*EPS*ABS( D( JMAX ) ) -* -* If the rank-1 modifier is small enough, no more needs to be done -* -- except to reorganize Q so that its columns correspond with the -* elements in D. -* - IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN - K = 0 - DO 50 J = 1, N - PERM( J ) = INDXQ( INDX( J ) ) - CALL ZCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) - 50 CONTINUE - CALL ZLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ), LDQ ) - RETURN - END IF -* -* If there are multiple eigenvalues then the problem deflates. Here -* the number of equal eigenvalues are found. As each equal -* eigenvalue is found, an elementary reflector is computed to rotate -* the corresponding eigensubspace so that the corresponding -* components of Z are zero in this new basis. -* - K = 0 - K2 = N + 1 - DO 60 J = 1, N - IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN -* -* Deflate due to small z component. -* - K2 = K2 - 1 - INDXP( K2 ) = J - IF( J.EQ.N ) - $ GO TO 100 - ELSE - JLAM = J - GO TO 70 - END IF - 60 CONTINUE - 70 CONTINUE - J = J + 1 - IF( J.GT.N ) - $ GO TO 90 - IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN -* -* Deflate due to small z component. -* - K2 = K2 - 1 - INDXP( K2 ) = J - ELSE -* -* Check if eigenvalues are close enough to allow deflation. -* - S = Z( JLAM ) - C = Z( J ) -* -* Find sqrt(a**2+b**2) without overflow or -* destructive underflow. -* - TAU = DLAPY2( C, S ) - T = D( J ) - D( JLAM ) - C = C / TAU - S = -S / TAU - IF( ABS( T*C*S ).LE.TOL ) THEN -* -* Deflation is possible. -* - Z( J ) = TAU - Z( JLAM ) = ZERO -* -* Record the appropriate Givens rotation -* - GIVPTR = GIVPTR + 1 - GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) ) - GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) ) - GIVNUM( 1, GIVPTR ) = C - GIVNUM( 2, GIVPTR ) = S - CALL ZDROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1, - $ Q( 1, INDXQ( INDX( J ) ) ), 1, C, S ) - T = D( JLAM )*C*C + D( J )*S*S - D( J ) = D( JLAM )*S*S + D( J )*C*C - D( JLAM ) = T - K2 = K2 - 1 - I = 1 - 80 CONTINUE - IF( K2+I.LE.N ) THEN - IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN - INDXP( K2+I-1 ) = INDXP( K2+I ) - INDXP( K2+I ) = JLAM - I = I + 1 - GO TO 80 - ELSE - INDXP( K2+I-1 ) = JLAM - END IF - ELSE - INDXP( K2+I-1 ) = JLAM - END IF - JLAM = J - ELSE - K = K + 1 - W( K ) = Z( JLAM ) - DLAMDA( K ) = D( JLAM ) - INDXP( K ) = JLAM - JLAM = J - END IF - END IF - GO TO 70 - 90 CONTINUE -* -* Record the last eigenvalue. -* - K = K + 1 - W( K ) = Z( JLAM ) - DLAMDA( K ) = D( JLAM ) - INDXP( K ) = JLAM -* - 100 CONTINUE -* -* Sort the eigenvalues and corresponding eigenvectors into DLAMDA -* and Q2 respectively. The eigenvalues/vectors which were not -* deflated go into the first K slots of DLAMDA and Q2 respectively, -* while those which were deflated go into the last N - K slots. -* - DO 110 J = 1, N - JP = INDXP( J ) - DLAMDA( J ) = D( JP ) - PERM( J ) = INDXQ( INDX( JP ) ) - CALL ZCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) - 110 CONTINUE -* -* The deflated eigenvalues and their corresponding vectors go back -* into the last N - K slots of D and Q respectively. -* - IF( K.LT.N ) THEN - CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 ) - CALL ZLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2, Q( 1, K+1 ), - $ LDQ ) - END IF -* - RETURN -* -* End of ZLAED8 -* - END diff --git a/lib/linalg/fortran/zlanhe.f b/lib/linalg/fortran/zlanhe.f deleted file mode 100644 index bbb4843ffd..0000000000 --- a/lib/linalg/fortran/zlanhe.f +++ /dev/null @@ -1,255 +0,0 @@ -*> \brief \b ZLANHE returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a complex Hermitian matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLANHE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) -* -* .. Scalar Arguments .. -* CHARACTER NORM, UPLO -* INTEGER LDA, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION WORK( * ) -* COMPLEX*16 A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLANHE returns the value of the one norm, or the Frobenius norm, or -*> the infinity norm, or the element of largest absolute value of a -*> complex hermitian matrix A. -*> \endverbatim -*> -*> \return ZLANHE -*> \verbatim -*> -*> ZLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm' -*> ( -*> ( norm1(A), NORM = '1', 'O' or 'o' -*> ( -*> ( normI(A), NORM = 'I' or 'i' -*> ( -*> ( normF(A), NORM = 'F', 'f', 'E' or 'e' -*> -*> where norm1 denotes the one norm of a matrix (maximum column sum), -*> normI denotes the infinity norm of a matrix (maximum row sum) and -*> normF denotes the Frobenius norm of a matrix (square root of sum of -*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] NORM -*> \verbatim -*> NORM is CHARACTER*1 -*> Specifies the value to be returned in ZLANHE as described -*> above. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies whether the upper or lower triangular part of the -*> hermitian matrix A is to be referenced. -*> = 'U': Upper triangular part of A is referenced -*> = 'L': Lower triangular part of A is referenced -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. When N = 0, ZLANHE is -*> set to zero. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> The hermitian matrix A. If UPLO = 'U', the leading n by n -*> upper triangular part of A contains the upper triangular part -*> of the matrix A, and the strictly lower triangular part of A -*> is not referenced. If UPLO = 'L', the leading n by n lower -*> triangular part of A contains the lower triangular part of -*> the matrix A, and the strictly upper triangular part of A is -*> not referenced. Note that the imaginary parts of the diagonal -*> elements need not be set and are assumed to be zero. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(N,1). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), -*> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, -*> WORK is not referenced. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16HEauxiliary -* -* ===================================================================== - DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER NORM, UPLO - INTEGER LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION WORK( * ) - COMPLEX*16 A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION ABSA, SCALE, SUM, VALUE -* .. -* .. External Functions .. - LOGICAL LSAME, DISNAN - EXTERNAL LSAME, DISNAN -* .. -* .. External Subroutines .. - EXTERNAL ZLASSQ -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, SQRT -* .. -* .. Executable Statements .. -* - IF( N.EQ.0 ) THEN - VALUE = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, J - 1 - SUM = ABS( A( I, J ) ) - IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM - 10 CONTINUE - SUM = ABS( DBLE( A( J, J ) ) ) - IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM - 20 CONTINUE - ELSE - DO 40 J = 1, N - SUM = ABS( DBLE( A( J, J ) ) ) - IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM - DO 30 I = J + 1, N - SUM = ABS( A( I, J ) ) - IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM - 30 CONTINUE - 40 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. - $ ( NORM.EQ.'1' ) ) THEN -* -* Find normI(A) ( = norm1(A), since A is hermitian). -* - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - DO 60 J = 1, N - SUM = ZERO - DO 50 I = 1, J - 1 - ABSA = ABS( A( I, J ) ) - SUM = SUM + ABSA - WORK( I ) = WORK( I ) + ABSA - 50 CONTINUE - WORK( J ) = SUM + ABS( DBLE( A( J, J ) ) ) - 60 CONTINUE - DO 70 I = 1, N - SUM = WORK( I ) - IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM - 70 CONTINUE - ELSE - DO 80 I = 1, N - WORK( I ) = ZERO - 80 CONTINUE - DO 100 J = 1, N - SUM = WORK( J ) + ABS( DBLE( A( J, J ) ) ) - DO 90 I = J + 1, N - ABSA = ABS( A( I, J ) ) - SUM = SUM + ABSA - WORK( I ) = WORK( I ) + ABSA - 90 CONTINUE - IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM - 100 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - IF( LSAME( UPLO, 'U' ) ) THEN - DO 110 J = 2, N - CALL ZLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) - 110 CONTINUE - ELSE - DO 120 J = 1, N - 1 - CALL ZLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) - 120 CONTINUE - END IF - SUM = 2*SUM - DO 130 I = 1, N - IF( DBLE( A( I, I ) ).NE.ZERO ) THEN - ABSA = ABS( DBLE( A( I, I ) ) ) - IF( SCALE.LT.ABSA ) THEN - SUM = ONE + SUM*( SCALE / ABSA )**2 - SCALE = ABSA - ELSE - SUM = SUM + ( ABSA / SCALE )**2 - END IF - END IF - 130 CONTINUE - VALUE = SCALE*SQRT( SUM ) - END IF -* - ZLANHE = VALUE - RETURN -* -* End of ZLANHE -* - END diff --git a/lib/linalg/fortran/zlarf.f b/lib/linalg/fortran/zlarf.f deleted file mode 100644 index e555d18ecd..0000000000 --- a/lib/linalg/fortran/zlarf.f +++ /dev/null @@ -1,229 +0,0 @@ -*> \brief \b ZLARF applies an elementary reflector to a general rectangular matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLARF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE -* INTEGER INCV, LDC, M, N -* COMPLEX*16 TAU -* .. -* .. Array Arguments .. -* COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLARF applies a complex elementary reflector H to a complex M-by-N -*> matrix C, from either the left or the right. H is represented in the -*> form -*> -*> H = I - tau * v * v**H -*> -*> where tau is a complex scalar and v is a complex vector. -*> -*> If tau = 0, then H is taken to be the unit matrix. -*> -*> To apply H**H, supply conjg(tau) instead -*> tau. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': form H * C -*> = 'R': form C * H -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. -*> \endverbatim -*> -*> \param[in] V -*> \verbatim -*> V is COMPLEX*16 array, dimension -*> (1 + (M-1)*abs(INCV)) if SIDE = 'L' -*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' -*> The vector v in the representation of H. V is not used if -*> TAU = 0. -*> \endverbatim -*> -*> \param[in] INCV -*> \verbatim -*> INCV is INTEGER -*> The increment between elements of v. INCV <> 0. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 -*> The value tau in the representation of H. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is COMPLEX*16 array, dimension (LDC,N) -*> On entry, the M-by-N matrix C. -*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', -*> or C * H if SIDE = 'R'. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension -*> (N) if SIDE = 'L' -*> or (M) if SIDE = 'R' -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE - INTEGER INCV, LDC, M, N - COMPLEX*16 TAU -* .. -* .. Array Arguments .. - COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL APPLYLEFT - INTEGER I, LASTV, LASTC -* .. -* .. External Subroutines .. - EXTERNAL ZGEMV, ZGERC -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAZLR, ILAZLC - EXTERNAL LSAME, ILAZLR, ILAZLC -* .. -* .. Executable Statements .. -* - APPLYLEFT = LSAME( SIDE, 'L' ) - LASTV = 0 - LASTC = 0 - IF( TAU.NE.ZERO ) THEN -* Set up variables for scanning V. LASTV begins pointing to the end -* of V. - IF( APPLYLEFT ) THEN - LASTV = M - ELSE - LASTV = N - END IF - IF( INCV.GT.0 ) THEN - I = 1 + (LASTV-1) * INCV - ELSE - I = 1 - END IF -* Look for the last non-zero row in V. - DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) - LASTV = LASTV - 1 - I = I - INCV - END DO - IF( APPLYLEFT ) THEN -* Scan for the last non-zero column in C(1:lastv,:). - LASTC = ILAZLC(LASTV, N, C, LDC) - ELSE -* Scan for the last non-zero row in C(:,1:lastv). - LASTC = ILAZLR(M, LASTV, C, LDC) - END IF - END IF -* Note that lastc.eq.0 renders the BLAS operations null; no special -* case is needed at this level. - IF( APPLYLEFT ) THEN -* -* Form H * C -* - IF( LASTV.GT.0 ) THEN -* -* w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1) -* - CALL ZGEMV( 'Conjugate transpose', LASTV, LASTC, ONE, - $ C, LDC, V, INCV, ZERO, WORK, 1 ) -* -* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**H -* - CALL ZGERC( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) - END IF - ELSE -* -* Form C * H -* - IF( LASTV.GT.0 ) THEN -* -* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) -* - CALL ZGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, - $ V, INCV, ZERO, WORK, 1 ) -* -* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**H -* - CALL ZGERC( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) - END IF - END IF - RETURN -* -* End of ZLARF -* - END diff --git a/lib/linalg/fortran/zlarfb.f b/lib/linalg/fortran/zlarfb.f deleted file mode 100644 index c5f424db31..0000000000 --- a/lib/linalg/fortran/zlarfb.f +++ /dev/null @@ -1,730 +0,0 @@ -*> \brief \b ZLARFB applies a block reflector or its conjugate-transpose to a general rectangular matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLARFB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, -* T, LDT, C, LDC, WORK, LDWORK ) -* -* .. Scalar Arguments .. -* CHARACTER DIRECT, SIDE, STOREV, TRANS -* INTEGER K, LDC, LDT, LDV, LDWORK, M, N -* .. -* .. Array Arguments .. -* COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), -* $ WORK( LDWORK, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLARFB applies a complex block reflector H or its transpose H**H to a -*> complex M-by-N matrix C, from either the left or the right. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply H or H**H from the Left -*> = 'R': apply H or H**H from the Right -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': apply H (No transpose) -*> = 'C': apply H**H (Conjugate transpose) -*> \endverbatim -*> -*> \param[in] DIRECT -*> \verbatim -*> DIRECT is CHARACTER*1 -*> Indicates how H is formed from a product of elementary -*> reflectors -*> = 'F': H = H(1) H(2) . . . H(k) (Forward) -*> = 'B': H = H(k) . . . H(2) H(1) (Backward) -*> \endverbatim -*> -*> \param[in] STOREV -*> \verbatim -*> STOREV is CHARACTER*1 -*> Indicates how the vectors which define the elementary -*> reflectors are stored: -*> = 'C': Columnwise -*> = 'R': Rowwise -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The order of the matrix T (= the number of elementary -*> reflectors whose product defines the block reflector). -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] V -*> \verbatim -*> V is COMPLEX*16 array, dimension -*> (LDV,K) if STOREV = 'C' -*> (LDV,M) if STOREV = 'R' and SIDE = 'L' -*> (LDV,N) if STOREV = 'R' and SIDE = 'R' -*> See Further Details. -*> \endverbatim -*> -*> \param[in] LDV -*> \verbatim -*> LDV is INTEGER -*> The leading dimension of the array V. -*> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); -*> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); -*> if STOREV = 'R', LDV >= K. -*> \endverbatim -*> -*> \param[in] T -*> \verbatim -*> T is COMPLEX*16 array, dimension (LDT,K) -*> The triangular K-by-K matrix T in the representation of the -*> block reflector. -*> \endverbatim -*> -*> \param[in] LDT -*> \verbatim -*> LDT is INTEGER -*> The leading dimension of the array T. LDT >= K. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is COMPLEX*16 array, dimension (LDC,N) -*> On entry, the M-by-N matrix C. -*> On exit, C is overwritten by H*C or H**H*C or C*H or C*H**H. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (LDWORK,K) -*> \endverbatim -*> -*> \param[in] LDWORK -*> \verbatim -*> LDWORK is INTEGER -*> The leading dimension of the array WORK. -*> If SIDE = 'L', LDWORK >= max(1,N); -*> if SIDE = 'R', LDWORK >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The shape of the matrix V and the storage of the vectors which define -*> the H(i) is best illustrated by the following example with n = 5 and -*> k = 3. The elements equal to 1 are not stored; the corresponding -*> array elements are modified but restored on exit. The rest of the -*> array is not used. -*> -*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -*> -*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -*> ( v1 1 ) ( 1 v2 v2 v2 ) -*> ( v1 v2 1 ) ( 1 v3 v3 ) -*> ( v1 v2 v3 ) -*> ( v1 v2 v3 ) -*> -*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -*> -*> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -*> ( v1 v2 v3 ) ( v2 v2 v2 1 ) -*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -*> ( 1 v3 ) -*> ( 1 ) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, - $ T, LDT, C, LDC, WORK, LDWORK ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, SIDE, STOREV, TRANS - INTEGER K, LDC, LDT, LDV, LDWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), - $ WORK( LDWORK, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - CHARACTER TRANST - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - IF( LSAME( TRANS, 'N' ) ) THEN - TRANST = 'C' - ELSE - TRANST = 'N' - END IF -* - IF( LSAME( STOREV, 'C' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 ) (first K rows) -* ( V2 ) -* where V1 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**H * C where C = ( C1 ) -* ( C2 ) -* -* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) -* -* W := C1**H -* - DO 10 J = 1, K - 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', N, - $ K, ONE, V, LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C2**H * V2 -* - 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', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W**H -* - IF( M.GT.K ) THEN -* -* C2 := C2 - V2 * W**H -* - CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ 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', N, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W**H -* - DO 30 J = 1, K - DO 20 I = 1, N - C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**H where C = ( C1 C2 ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C1 -* - DO 40 J = 1, K - CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) - 40 CONTINUE -* -* W := W * V1 -* - 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', 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', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V**H -* - IF( N.GT.K ) THEN -* -* C2 := C2 - W * V2**H -* - 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', M, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 60 J = 1, K - DO 50 I = 1, M - C( I, J ) = C( I, J ) - WORK( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF -* - ELSE -* -* Let V = ( V1 ) -* ( V2 ) (last K rows) -* where V2 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**H * C where C = ( C1 ) -* ( C2 ) -* -* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) -* -* W := C2**H -* - DO 70 J = 1, K - 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', N, - $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C1**H * V1 -* - 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', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W**H -* - IF( M.GT.K ) THEN -* -* C1 := C1 - V1 * W**H -* - CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ 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', N, K, ONE, V( M-K+1, 1 ), LDV, WORK, - $ LDWORK ) -* -* C2 := C2 - W**H -* - DO 90 J = 1, K - DO 80 I = 1, N - C( M-K+J, I ) = C( M-K+J, I ) - - $ DCONJG( WORK( I, J ) ) - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**H where C = ( C1 C2 ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C2 -* - DO 100 J = 1, K - 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', 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', 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', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V**H -* - IF( N.GT.K ) THEN -* -* C1 := C1 - W * V1**H -* - 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', M, K, ONE, V( N-K+1, 1 ), LDV, WORK, - $ LDWORK ) -* -* C2 := C2 - W -* - DO 120 J = 1, K - DO 110 I = 1, M - C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) - 110 CONTINUE - 120 CONTINUE - END IF - END IF -* - ELSE IF( LSAME( STOREV, 'R' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 V2 ) (V1: first K columns) -* where V1 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**H * C where C = ( C1 ) -* ( C2 ) -* -* 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( 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', N, K, ONE, V, LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C2**H * V2**H -* - CALL ZGEMM( 'Conjugate transpose', - $ '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', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V**H * W**H -* - IF( M.GT.K ) THEN -* -* C2 := C2 - V2**H * W**H -* - CALL ZGEMM( 'Conjugate transpose', - $ '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', N, - $ K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W**H -* - DO 150 J = 1, K - DO 140 I = 1, N - C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) - 140 CONTINUE - 150 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**H where C = ( C1 C2 ) -* -* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) -* -* W := C1 -* - DO 160 J = 1, K - CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) - 160 CONTINUE -* -* W := W * V1**H -* - CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C2 * V2**H -* - 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', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( N.GT.K ) THEN -* -* C2 := C2 - W * V2 -* - 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', M, - $ K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 180 J = 1, K - DO 170 I = 1, M - C( I, J ) = C( I, J ) - WORK( I, J ) - 170 CONTINUE - 180 CONTINUE -* - END IF -* - ELSE -* -* Let V = ( V1 V2 ) (V2: last K columns) -* where V2 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**H * C where C = ( C1 ) -* ( C2 ) -* -* 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( 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', 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', 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', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V**H * W**H -* - IF( M.GT.K ) THEN -* -* C1 := C1 - V1**H * W**H -* - CALL ZGEMM( 'Conjugate transpose', - $ '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', N, - $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) -* -* C2 := C2 - W**H -* - DO 210 J = 1, K - DO 200 I = 1, N - C( M-K+J, I ) = C( M-K+J, I ) - - $ DCONJG( WORK( I, J ) ) - 200 CONTINUE - 210 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**H where C = ( C1 C2 ) -* -* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) -* -* W := C2 -* - DO 220 J = 1, K - 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', 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', 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', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( N.GT.K ) THEN -* -* C1 := C1 - W * V1 -* - 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', M, - $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 240 J = 1, K - DO 230 I = 1, M - C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) - 230 CONTINUE - 240 CONTINUE -* - END IF -* - END IF - END IF -* - RETURN -* -* End of ZLARFB -* - END diff --git a/lib/linalg/fortran/zlarfg.f b/lib/linalg/fortran/zlarfg.f deleted file mode 100644 index d69796cadc..0000000000 --- a/lib/linalg/fortran/zlarfg.f +++ /dev/null @@ -1,200 +0,0 @@ -*> \brief \b ZLARFG generates an elementary reflector (Householder matrix). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLARFG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) -* -* .. Scalar Arguments .. -* INTEGER INCX, N -* COMPLEX*16 ALPHA, TAU -* .. -* .. Array Arguments .. -* COMPLEX*16 X( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLARFG generates a complex elementary reflector H of order n, such -*> that -*> -*> H**H * ( alpha ) = ( beta ), H**H * H = I. -*> ( x ) ( 0 ) -*> -*> where alpha and beta are scalars, with beta real, and x is an -*> (n-1)-element complex vector. H is represented in the form -*> -*> H = I - tau * ( 1 ) * ( 1 v**H ) , -*> ( v ) -*> -*> where tau is a complex scalar and v is a complex (n-1)-element -*> vector. Note that H is not hermitian. -*> -*> If the elements of x are all zero and alpha is real, then tau = 0 -*> and H is taken to be the unit matrix. -*> -*> Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the elementary reflector. -*> \endverbatim -*> -*> \param[in,out] ALPHA -*> \verbatim -*> ALPHA is COMPLEX*16 -*> On entry, the value alpha. -*> On exit, it is overwritten with the value beta. -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is COMPLEX*16 array, dimension -*> (1+(N-2)*abs(INCX)) -*> On entry, the vector x. -*> On exit, it is overwritten with the vector v. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> The increment between elements of X. INCX > 0. -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is COMPLEX*16 -*> The value tau. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX, N - COMPLEX*16 ALPHA, TAU -* .. -* .. Array Arguments .. - COMPLEX*16 X( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER J, KNT - DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2 - COMPLEX*16 ZLADIV - EXTERNAL DLAMCH, DLAPY3, DZNRM2, ZLADIV -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCMPLX, DIMAG, SIGN -* .. -* .. External Subroutines .. - EXTERNAL ZDSCAL, ZSCAL -* .. -* .. Executable Statements .. -* - IF( N.LE.0 ) THEN - TAU = ZERO - RETURN - END IF -* - XNORM = DZNRM2( N-1, X, INCX ) - ALPHR = DBLE( ALPHA ) - ALPHI = DIMAG( ALPHA ) -* - IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN -* -* H = I -* - TAU = ZERO - ELSE -* -* general case -* - BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) - SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) - RSAFMN = ONE / SAFMIN -* - KNT = 0 - IF( ABS( BETA ).LT.SAFMIN ) THEN -* -* XNORM, BETA may be inaccurate; scale X and recompute them -* - 10 CONTINUE - KNT = KNT + 1 - CALL ZDSCAL( N-1, RSAFMN, X, INCX ) - BETA = BETA*RSAFMN - ALPHI = ALPHI*RSAFMN - ALPHR = ALPHR*RSAFMN - IF( (ABS( BETA ).LT.SAFMIN) .AND. (KNT .LT. 20) ) - $ GO TO 10 -* -* New BETA is at most 1, at least SAFMIN -* - XNORM = DZNRM2( N-1, X, INCX ) - ALPHA = DCMPLX( ALPHR, ALPHI ) - BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) - END IF - TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA ) - ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA ) - CALL ZSCAL( N-1, ALPHA, X, INCX ) -* -* If ALPHA is subnormal, it may lose relative accuracy -* - DO 20 J = 1, KNT - BETA = BETA*SAFMIN - 20 CONTINUE - ALPHA = BETA - END IF -* - RETURN -* -* End of ZLARFG -* - END diff --git a/lib/linalg/fortran/zlarft.f b/lib/linalg/fortran/zlarft.f deleted file mode 100644 index 5ad0996fab..0000000000 --- a/lib/linalg/fortran/zlarft.f +++ /dev/null @@ -1,324 +0,0 @@ -*> \brief \b ZLARFT forms the triangular factor T of a block reflector H = I - vtvH -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLARFT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* -* .. Scalar Arguments .. -* CHARACTER DIRECT, STOREV -* INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. -* COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLARFT forms the triangular factor T of a complex block reflector H -*> of order n, which is defined as a product of k elementary reflectors. -*> -*> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; -*> -*> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. -*> -*> If STOREV = 'C', the vector which defines the elementary reflector -*> H(i) is stored in the i-th column of the array V, and -*> -*> H = I - V * T * V**H -*> -*> If STOREV = 'R', the vector which defines the elementary reflector -*> H(i) is stored in the i-th row of the array V, and -*> -*> H = I - V**H * T * V -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] DIRECT -*> \verbatim -*> DIRECT is CHARACTER*1 -*> Specifies the order in which the elementary reflectors are -*> multiplied to form the block reflector: -*> = 'F': H = H(1) H(2) . . . H(k) (Forward) -*> = 'B': H = H(k) . . . H(2) H(1) (Backward) -*> \endverbatim -*> -*> \param[in] STOREV -*> \verbatim -*> STOREV is CHARACTER*1 -*> Specifies how the vectors which define the elementary -*> reflectors are stored (see also Further Details): -*> = 'C': columnwise -*> = 'R': rowwise -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the block reflector H. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The order of the triangular factor T (= the number of -*> elementary reflectors). K >= 1. -*> \endverbatim -*> -*> \param[in] V -*> \verbatim -*> V is COMPLEX*16 array, dimension -*> (LDV,K) if STOREV = 'C' -*> (LDV,N) if STOREV = 'R' -*> The matrix V. See further details. -*> \endverbatim -*> -*> \param[in] LDV -*> \verbatim -*> LDV is INTEGER -*> The leading dimension of the array V. -*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i). -*> \endverbatim -*> -*> \param[out] T -*> \verbatim -*> T is COMPLEX*16 array, dimension (LDT,K) -*> The k by k triangular factor T of the block reflector. -*> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is -*> lower triangular. The rest of the array is not used. -*> \endverbatim -*> -*> \param[in] LDT -*> \verbatim -*> LDT is INTEGER -*> The leading dimension of the array T. LDT >= K. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The shape of the matrix V and the storage of the vectors which define -*> the H(i) is best illustrated by the following example with n = 5 and -*> k = 3. The elements equal to 1 are not stored. -*> -*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -*> -*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -*> ( v1 1 ) ( 1 v2 v2 v2 ) -*> ( v1 v2 1 ) ( 1 v3 v3 ) -*> ( v1 v2 v3 ) -*> ( v1 v2 v3 ) -*> -*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -*> -*> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -*> ( v1 v2 v3 ) ( v2 v2 v2 1 ) -*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -*> ( 1 v3 ) -*> ( 1 ) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, STOREV - INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. - COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, J, PREVLASTV, LASTV -* .. -* .. External Subroutines .. - EXTERNAL ZGEMV, ZTRMV, ZGEMM -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( LSAME( DIRECT, 'F' ) ) THEN - PREVLASTV = N - DO I = 1, K - PREVLASTV = MAX( PREVLASTV, I ) - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = 1, I - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * CONJG( V( I , J ) ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i) -* - CALL ZGEMV( 'Conjugate transpose', J-I, I-1, - $ -TAU( I ), V( I+1, 1 ), LDV, - $ V( I+1, I ), 1, ONE, T( 1, I ), 1 ) - ELSE -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * V( J , I ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H -* - CALL ZGEMM( 'N', 'C', I-1, 1, J-I, -TAU( I ), - $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, - $ ONE, T( 1, I ), LDT ) - END IF -* -* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) -* - CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, - $ LDT, T( 1, I ), 1 ) - T( I, I ) = TAU( I ) - IF( I.GT.1 ) THEN - PREVLASTV = MAX( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - END DO - ELSE - PREVLASTV = 1 - DO I = K, 1, -1 - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = I, K - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( I.LT.K ) THEN - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - DO J = I+1, K - T( J, I ) = -TAU( I ) * CONJG( V( N-K+I , J ) ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i) -* - CALL ZGEMV( 'Conjugate transpose', N-K+I-J, K-I, - $ -TAU( I ), V( J, I+1 ), LDV, V( J, I ), - $ 1, ONE, T( I+1, I ), 1 ) - ELSE -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - DO J = I+1, K - T( J, I ) = -TAU( I ) * V( J, N-K+I ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H -* - CALL ZGEMM( 'N', 'C', K-I, 1, N-K+I-J, -TAU( I ), - $ V( I+1, J ), LDV, V( I, J ), LDV, - $ ONE, T( I+1, I ), LDT ) - END IF -* -* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) -* - CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, - $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) - IF( I.GT.1 ) THEN - PREVLASTV = MIN( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - T( I, I ) = TAU( I ) - END IF - END DO - END IF - RETURN -* -* End of ZLARFT -* - END diff --git a/lib/linalg/fortran/zlascl.f b/lib/linalg/fortran/zlascl.f deleted file mode 100644 index 4cce5ff5e0..0000000000 --- a/lib/linalg/fortran/zlascl.f +++ /dev/null @@ -1,367 +0,0 @@ -*> \brief \b ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLASCL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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 -* DOUBLE PRECISION CFROM, CTO -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLASCL multiplies the M by N complex matrix A by the real scalar -*> CTO/CFROM. This is done without over/underflow as long as the final -*> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that -*> A may be full, upper triangular, lower triangular, upper Hessenberg, -*> or banded. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] TYPE -*> \verbatim -*> TYPE is CHARACTER*1 -*> TYPE indices the storage type of the input matrix. -*> = 'G': A is a full matrix. -*> = 'L': A is a lower triangular matrix. -*> = 'U': A is an upper triangular matrix. -*> = 'H': A is an upper Hessenberg matrix. -*> = 'B': A is a symmetric band matrix with lower bandwidth KL -*> and upper bandwidth KU and with the only the lower -*> half stored. -*> = 'Q': A is a symmetric band matrix with lower bandwidth KL -*> and upper bandwidth KU and with the only the upper -*> half stored. -*> = 'Z': A is a band matrix with lower bandwidth KL and upper -*> bandwidth KU. See ZGBTRF for storage details. -*> \endverbatim -*> -*> \param[in] KL -*> \verbatim -*> KL is INTEGER -*> The lower bandwidth of A. Referenced only if TYPE = 'B', -*> 'Q' or 'Z'. -*> \endverbatim -*> -*> \param[in] KU -*> \verbatim -*> KU is INTEGER -*> The upper bandwidth of A. Referenced only if TYPE = 'B', -*> 'Q' or 'Z'. -*> \endverbatim -*> -*> \param[in] CFROM -*> \verbatim -*> CFROM is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] CTO -*> \verbatim -*> CTO is DOUBLE PRECISION -*> -*> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed -*> without over/underflow if the final result CTO*A(I,J)/CFROM -*> can be represented without over/underflow. CFROM must be -*> nonzero. -*> \endverbatim -*> -*> \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 COMPLEX*16 array, dimension (LDA,N) -*> The matrix to be multiplied by CTO/CFROM. See TYPE for the -*> storage type. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> 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 -*> \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. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER TYPE - INTEGER INFO, KL, KU, LDA, M, N - DOUBLE PRECISION CFROM, CTO -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL DONE - INTEGER I, ITYPE, J, K1, K2, K3, K4 - DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME, DISNAN - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, DLAMCH, DISNAN -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 -* - IF( LSAME( TYPE, 'G' ) ) THEN - ITYPE = 0 - ELSE IF( LSAME( TYPE, 'L' ) ) THEN - ITYPE = 1 - ELSE IF( LSAME( TYPE, 'U' ) ) THEN - ITYPE = 2 - ELSE IF( LSAME( TYPE, 'H' ) ) THEN - ITYPE = 3 - ELSE IF( LSAME( TYPE, 'B' ) ) THEN - ITYPE = 4 - ELSE IF( LSAME( TYPE, 'Q' ) ) THEN - ITYPE = 5 - ELSE IF( LSAME( TYPE, 'Z' ) ) THEN - ITYPE = 6 - ELSE - ITYPE = -1 - END IF -* - IF( ITYPE.EQ.-1 ) THEN - INFO = -1 - ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN - INFO = -4 - ELSE IF( DISNAN(CTO) ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. - $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN - INFO = -7 - ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( ITYPE.GE.4 ) THEN - IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN - INFO = -2 - ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. - $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) - $ THEN - INFO = -3 - ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. - $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. - $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN - INFO = -9 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZLASCL', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -* -* Get machine parameters -* - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM -* - CFROMC = CFROM - CTOC = CTO -* - 10 CONTINUE - CFROM1 = CFROMC*SMLNUM - IF( CFROM1.EQ.CFROMC ) THEN -! CFROMC is an inf. Multiply by a correctly signed zero for -! finite CTOC, or a NaN if CTOC is infinite. - MUL = CTOC / CFROMC - DONE = .TRUE. - CTO1 = CTOC - ELSE - CTO1 = CTOC / BIGNUM - IF( CTO1.EQ.CTOC ) THEN -! CTOC is either 0 or an inf. In both cases, CTOC itself -! serves as the correct multiplication factor. - MUL = CTOC - DONE = .TRUE. - CFROMC = ONE - ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN - MUL = SMLNUM - DONE = .FALSE. - CFROMC = CFROM1 - ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN - MUL = BIGNUM - DONE = .FALSE. - CTOC = CTO1 - ELSE - MUL = CTOC / CFROMC - DONE = .TRUE. - IF (MUL .EQ. ONE) - $ RETURN - END IF - END IF -* - IF( ITYPE.EQ.0 ) THEN -* -* Full matrix -* - DO 30 J = 1, N - DO 20 I = 1, M - A( I, J ) = A( I, J )*MUL - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( ITYPE.EQ.1 ) THEN -* -* Lower triangular matrix -* - DO 50 J = 1, N - DO 40 I = J, M - A( I, J ) = A( I, J )*MUL - 40 CONTINUE - 50 CONTINUE -* - ELSE IF( ITYPE.EQ.2 ) THEN -* -* Upper triangular matrix -* - DO 70 J = 1, N - DO 60 I = 1, MIN( J, M ) - A( I, J ) = A( I, J )*MUL - 60 CONTINUE - 70 CONTINUE -* - ELSE IF( ITYPE.EQ.3 ) THEN -* -* Upper Hessenberg matrix -* - DO 90 J = 1, N - DO 80 I = 1, MIN( J+1, M ) - A( I, J ) = A( I, J )*MUL - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( ITYPE.EQ.4 ) THEN -* -* Lower half of a symmetric band matrix -* - K3 = KL + 1 - K4 = N + 1 - DO 110 J = 1, N - DO 100 I = 1, MIN( K3, K4-J ) - A( I, J ) = A( I, J )*MUL - 100 CONTINUE - 110 CONTINUE -* - ELSE IF( ITYPE.EQ.5 ) THEN -* -* Upper half of a symmetric band matrix -* - K1 = KU + 2 - K3 = KU + 1 - DO 130 J = 1, N - DO 120 I = MAX( K1-J, 1 ), K3 - A( I, J ) = A( I, J )*MUL - 120 CONTINUE - 130 CONTINUE -* - ELSE IF( ITYPE.EQ.6 ) THEN -* -* Band matrix -* - K1 = KL + KU + 2 - K2 = KL + 1 - K3 = 2*KL + KU + 1 - K4 = KL + KU + 1 + M - DO 150 J = 1, N - DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) - A( I, J ) = A( I, J )*MUL - 140 CONTINUE - 150 CONTINUE -* - END IF -* - IF( .NOT.DONE ) - $ GO TO 10 -* - RETURN -* -* End of ZLASCL -* - END diff --git a/lib/linalg/fortran/zlaset.f b/lib/linalg/fortran/zlaset.f deleted file mode 100644 index 00f5f595fc..0000000000 --- a/lib/linalg/fortran/zlaset.f +++ /dev/null @@ -1,181 +0,0 @@ -*> \brief \b ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLASET + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER LDA, M, N -* COMPLEX*16 ALPHA, BETA -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLASET initializes a 2-D array A to BETA on the diagonal and -*> ALPHA on the offdiagonals. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies the part of the matrix A to be set. -*> = 'U': Upper triangular part is set. The lower triangle -*> is unchanged. -*> = 'L': Lower triangular part is set. The upper triangle -*> is unchanged. -*> Otherwise: All of the matrix A is set. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of A. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of A. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is COMPLEX*16 -*> All the offdiagonal array elements are set to ALPHA. -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is COMPLEX*16 -*> All the diagonal array elements are set to BETA. -*> \endverbatim -*> -*> \param[out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> On entry, the m by n matrix A. -*> On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j; -*> A(i,i) = BETA , 1 <= i <= min(m,n) -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, M, N - COMPLEX*16 ALPHA, BETA -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Set the diagonal to BETA and the strictly upper triangular -* part of the array to ALPHA. -* - DO 20 J = 2, N - DO 10 I = 1, MIN( J-1, M ) - A( I, J ) = ALPHA - 10 CONTINUE - 20 CONTINUE - DO 30 I = 1, MIN( N, M ) - A( I, I ) = BETA - 30 CONTINUE -* - ELSE IF( LSAME( UPLO, 'L' ) ) THEN -* -* Set the diagonal to BETA and the strictly lower triangular -* part of the array to ALPHA. -* - DO 50 J = 1, MIN( M, N ) - DO 40 I = J + 1, M - A( I, J ) = ALPHA - 40 CONTINUE - 50 CONTINUE - DO 60 I = 1, MIN( N, M ) - A( I, I ) = BETA - 60 CONTINUE -* - ELSE -* -* Set the array to BETA on the diagonal and ALPHA on the -* offdiagonal. -* - DO 80 J = 1, N - DO 70 I = 1, M - A( I, J ) = ALPHA - 70 CONTINUE - 80 CONTINUE - DO 90 I = 1, MIN( M, N ) - A( I, I ) = BETA - 90 CONTINUE - END IF -* - RETURN -* -* End of ZLASET -* - END diff --git a/lib/linalg/fortran/zlasr.f b/lib/linalg/fortran/zlasr.f deleted file mode 100644 index 07c91329c4..0000000000 --- a/lib/linalg/fortran/zlasr.f +++ /dev/null @@ -1,436 +0,0 @@ -*> \brief \b ZLASR applies a sequence of plane rotations to a general rectangular matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLASR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) -* -* .. Scalar Arguments .. -* CHARACTER DIRECT, PIVOT, SIDE -* INTEGER LDA, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION C( * ), S( * ) -* COMPLEX*16 A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLASR applies a sequence of real plane rotations to a complex 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 ) -*> ( c(k) s(k) ) -*> ( -s(k) c(k) ) -*> ( 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 ) -*> ( ... ) -*> ( 1 ) -*> ( -s(k) c(k) ) -*> ( 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 ) -*> ( c(k) s(k) ) -*> ( 1 ) -*> ( ... ) -*> ( 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 -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> Specifies whether the plane rotation matrix P is applied to -*> A on the left or the right. -*> = 'L': Left, compute A := P*A -*> = 'R': Right, compute A:= A*P**T -*> \endverbatim -*> -*> \param[in] PIVOT -*> \verbatim -*> PIVOT is CHARACTER*1 -*> Specifies the plane for which P(k) is a plane rotation -*> matrix. -*> = 'V': Variable pivot, the plane (k,k+1) -*> = 'T': Top pivot, the plane (1,k+1) -*> = 'B': Bottom pivot, the plane (k,z) -*> \endverbatim -*> -*> \param[in] DIRECT -*> \verbatim -*> DIRECT is CHARACTER*1 -*> Specifies whether P is a forward or backward sequence of -*> plane rotations. -*> = 'F': Forward, P = P(z-1)*...*P(2)*P(1) -*> = 'B': Backward, P = P(1)*P(2)*...*P(z-1) -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. If m <= 1, an immediate -*> return is effected. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. If n <= 1, an -*> immediate return is effected. -*> \endverbatim -*> -*> \param[in] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension -*> (M-1) if SIDE = 'L' -*> (N-1) if SIDE = 'R' -*> The cosines c(k) of the plane rotations. -*> \endverbatim -*> -*> \param[in] S -*> \verbatim -*> S is DOUBLE PRECISION array, dimension -*> (M-1) if SIDE = 'L' -*> (N-1) if SIDE = 'R' -*> The sines s(k) of the plane rotations. The 2-by-2 plane -*> rotation part of the matrix P(k), R(k), has the form -*> R(k) = ( c(k) s(k) ) -*> ( -s(k) c(k) ). -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> The M-by-N matrix A. On exit, A is overwritten by P*A if -*> SIDE = 'R' or by A*P**T if SIDE = 'L'. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, PIVOT, SIDE - INTEGER LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( * ), S( * ) - COMPLEX*16 A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, INFO, J - DOUBLE PRECISION CTEMP, STEMP - COMPLEX*16 TEMP -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN - INFO = 1 - ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, - $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN - INFO = 2 - ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) - $ THEN - INFO = 3 - ELSE IF( M.LT.0 ) THEN - INFO = 4 - ELSE IF( N.LT.0 ) THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = 9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZLASR ', INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) - $ RETURN - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form P * A -* - IF( LSAME( PIVOT, 'V' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 20 J = 1, M - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 10 I = 1, N - TEMP = A( J+1, I ) - A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) - A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 40 J = M - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 30 I = 1, N - TEMP = A( J+1, I ) - A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) - A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) - 30 CONTINUE - END IF - 40 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'T' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 60 J = 2, M - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 50 I = 1, N - TEMP = A( J, I ) - A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) - A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 80 J = M, 2, -1 - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 70 I = 1, N - TEMP = A( J, I ) - A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) - A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) - 70 CONTINUE - END IF - 80 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'B' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 100 J = 1, M - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 90 I = 1, N - TEMP = A( J, I ) - A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP - A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP - 90 CONTINUE - END IF - 100 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 120 J = M - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 110 I = 1, N - TEMP = A( J, I ) - A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP - A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP - 110 CONTINUE - END IF - 120 CONTINUE - END IF - END IF - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form A * P**T -* - IF( LSAME( PIVOT, 'V' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 140 J = 1, N - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 130 I = 1, M - TEMP = A( I, J+1 ) - A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) - A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) - 130 CONTINUE - END IF - 140 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 160 J = N - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 150 I = 1, M - TEMP = A( I, J+1 ) - A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) - A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) - 150 CONTINUE - END IF - 160 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'T' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 180 J = 2, N - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 170 I = 1, M - TEMP = A( I, J ) - A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) - A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) - 170 CONTINUE - END IF - 180 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 200 J = N, 2, -1 - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 190 I = 1, M - TEMP = A( I, J ) - A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) - A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) - 190 CONTINUE - END IF - 200 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'B' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 220 J = 1, N - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 210 I = 1, M - TEMP = A( I, J ) - A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP - A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP - 210 CONTINUE - END IF - 220 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 240 J = N - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 230 I = 1, M - TEMP = A( I, J ) - A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP - A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP - 230 CONTINUE - END IF - 240 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZLASR -* - END diff --git a/lib/linalg/fortran/zlassq.f b/lib/linalg/fortran/zlassq.f deleted file mode 100644 index fd13811bd9..0000000000 --- a/lib/linalg/fortran/zlassq.f +++ /dev/null @@ -1,168 +0,0 @@ -*> \brief \b ZLASSQ updates a sum of squares represented in scaled form. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLASSQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) -* -* .. Scalar Arguments .. -* INTEGER INCX, N -* DOUBLE PRECISION SCALE, SUMSQ -* .. -* .. Array Arguments .. -* COMPLEX*16 X( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLASSQ returns the values scl and ssq such that -*> -*> ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, -*> -*> where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is -*> assumed to be at least unity and the value of ssq will then satisfy -*> -*> 1.0 .le. ssq .le. ( sumsq + 2*n ). -*> -*> scale is assumed to be non-negative and scl returns the value -*> -*> scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ), -*> i -*> -*> scale and sumsq must be supplied in SCALE and SUMSQ respectively. -*> SCALE and SUMSQ are overwritten by scl and ssq respectively. -*> -*> The routine makes only one pass through the vector X. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of elements to be used from the vector X. -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is COMPLEX*16 array, dimension (N) -*> The vector x as described above. -*> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> The increment between successive values of the vector X. -*> INCX > 0. -*> \endverbatim -*> -*> \param[in,out] SCALE -*> \verbatim -*> SCALE is DOUBLE PRECISION -*> On entry, the value scale in the equation above. -*> On exit, SCALE is overwritten with the value scl . -*> \endverbatim -*> -*> \param[in,out] SUMSQ -*> \verbatim -*> SUMSQ is DOUBLE PRECISION -*> On entry, the value sumsq in the equation above. -*> On exit, SUMSQ is overwritten with the value ssq . -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date December 2016 -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) -* -* -- 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 INCX, N - DOUBLE PRECISION SCALE, SUMSQ -* .. -* .. Array Arguments .. - COMPLEX*16 X( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER IX - DOUBLE PRECISION TEMP1 -* .. -* .. External Functions .. - LOGICAL DISNAN - EXTERNAL DISNAN -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DIMAG -* .. -* .. Executable Statements .. -* - IF( N.GT.0 ) THEN - DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX - TEMP1 = ABS( DBLE( X( IX ) ) ) - IF( TEMP1.GT.ZERO.OR.DISNAN( TEMP1 ) ) THEN - IF( SCALE.LT.TEMP1 ) THEN - SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 - SCALE = TEMP1 - ELSE - SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 - END IF - END IF - TEMP1 = ABS( DIMAG( X( IX ) ) ) - IF( TEMP1.GT.ZERO.OR.DISNAN( TEMP1 ) ) THEN - IF( SCALE.LT.TEMP1 ) THEN - SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 - SCALE = TEMP1 - ELSE - SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 - END IF - END IF - 10 CONTINUE - END IF -* - RETURN -* -* End of ZLASSQ -* - END diff --git a/lib/linalg/fortran/zlatrd.f b/lib/linalg/fortran/zlatrd.f deleted file mode 100644 index ee2a484723..0000000000 --- a/lib/linalg/fortran/zlatrd.f +++ /dev/null @@ -1,355 +0,0 @@ -*> \brief \b ZLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiagonal form by an unitary similarity transformation. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLATRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER LDA, LDW, N, NB -* .. -* .. Array Arguments .. -* DOUBLE PRECISION E( * ) -* COMPLEX*16 A( LDA, * ), TAU( * ), W( LDW, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to -*> Hermitian tridiagonal form by a unitary similarity -*> transformation Q**H * A * Q, and returns the matrices V and W which are -*> needed to apply the transformation to the unreduced part of A. -*> -*> If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a -*> matrix, of which the upper triangle is supplied; -*> if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a -*> matrix, of which the lower triangle is supplied. -*> -*> This is an auxiliary routine called by ZHETRD. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies whether the upper or lower triangular part of the -*> Hermitian matrix A is stored: -*> = 'U': Upper triangular -*> = 'L': Lower triangular -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. -*> \endverbatim -*> -*> \param[in] NB -*> \verbatim -*> NB is INTEGER -*> The number of rows and columns to be reduced. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading -*> n-by-n upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading n-by-n lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> On exit: -*> if UPLO = 'U', the last NB columns have been reduced to -*> tridiagonal form, with the diagonal elements overwriting -*> the diagonal elements of A; the elements above the diagonal -*> with the array TAU, represent the unitary matrix Q as a -*> product of elementary reflectors; -*> if UPLO = 'L', the first NB columns have been reduced to -*> tridiagonal form, with the diagonal elements overwriting -*> the diagonal elements of A; the elements below the diagonal -*> with the array TAU, represent the unitary matrix Q as a -*> product of elementary reflectors. -*> See Further Details. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal -*> elements of the last NB columns of the reduced matrix; -*> if UPLO = 'L', E(1:nb) contains the subdiagonal elements of -*> the first NB columns of the reduced matrix. -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (N-1) -*> The scalar factors of the elementary reflectors, stored in -*> TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. -*> See Further Details. -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is COMPLEX*16 array, dimension (LDW,NB) -*> The n-by-nb matrix W required to update the unreduced part -*> of A. -*> \endverbatim -*> -*> \param[in] LDW -*> \verbatim -*> LDW is INTEGER -*> The leading dimension of the array W. LDW >= max(1,N). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> If UPLO = 'U', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(n) H(n-1) . . . H(n-nb+1). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**H -*> -*> where tau is a complex scalar, and v is a complex vector with -*> v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), -*> and tau in TAU(i-1). -*> -*> If UPLO = 'L', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(1) H(2) . . . H(nb). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**H -*> -*> where tau is a complex scalar, and v is a complex vector with -*> v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), -*> and tau in TAU(i). -*> -*> The elements of the vectors v together form the n-by-nb matrix V -*> which is needed, with W, to apply the transformation to the unreduced -*> part of the matrix, using a Hermitian rank-2k update of the form: -*> A := A - V*W**H - W*V**H. -*> -*> The contents of A on exit are illustrated by the following examples -*> with n = 5 and nb = 2: -*> -*> if UPLO = 'U': if UPLO = 'L': -*> -*> ( a a a v4 v5 ) ( d ) -*> ( a a v4 v5 ) ( 1 d ) -*> ( a 1 v5 ) ( v1 1 a ) -*> ( d 1 ) ( v1 v2 a a ) -*> ( d ) ( v1 v2 a a a ) -*> -*> where d denotes a diagonal element of the reduced matrix, a denotes -*> an element of the original matrix that is unchanged, and vi denotes -*> an element of the vector defining H(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDW, N, NB -* .. -* .. Array Arguments .. - DOUBLE PRECISION E( * ) - COMPLEX*16 A( LDA, * ), TAU( * ), W( LDW, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO, ONE, HALF - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), - $ ONE = ( 1.0D+0, 0.0D+0 ), - $ HALF = ( 0.5D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, IW - COMPLEX*16 ALPHA -* .. -* .. External Subroutines .. - EXTERNAL ZAXPY, ZGEMV, ZHEMV, ZLACGV, ZLARFG, ZSCAL -* .. -* .. External Functions .. - LOGICAL LSAME - COMPLEX*16 ZDOTC - EXTERNAL LSAME, ZDOTC -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MIN -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Reduce last NB columns of upper triangle -* - DO 10 I = N, N - NB + 1, -1 - IW = I - N + NB - IF( I.LT.N ) THEN -* -* Update A(1:i,i) -* - A( I, I ) = DBLE( A( I, I ) ) - CALL ZLACGV( N-I, W( I, IW+1 ), LDW ) - CALL ZGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ), - $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 ) - CALL ZLACGV( N-I, W( I, IW+1 ), LDW ) - CALL ZLACGV( N-I, A( I, I+1 ), LDA ) - CALL ZGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ), - $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 ) - CALL ZLACGV( N-I, A( I, I+1 ), LDA ) - A( I, I ) = DBLE( A( I, I ) ) - END IF - IF( I.GT.1 ) THEN -* -* Generate elementary reflector H(i) to annihilate -* A(1:i-2,i) -* - ALPHA = A( I-1, I ) - CALL ZLARFG( I-1, ALPHA, A( 1, I ), 1, TAU( I-1 ) ) - E( I-1 ) = DBLE( ALPHA ) - A( I-1, I ) = ONE -* -* Compute W(1:i-1,i) -* - CALL ZHEMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1, - $ ZERO, W( 1, IW ), 1 ) - IF( I.LT.N ) THEN - CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE, - $ W( 1, IW+1 ), LDW, A( 1, I ), 1, ZERO, - $ W( I+1, IW ), 1 ) - CALL ZGEMV( 'No transpose', I-1, N-I, -ONE, - $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, - $ W( 1, IW ), 1 ) - CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE, - $ A( 1, I+1 ), LDA, A( 1, I ), 1, ZERO, - $ W( I+1, IW ), 1 ) - CALL ZGEMV( 'No transpose', I-1, N-I, -ONE, - $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, - $ W( 1, IW ), 1 ) - END IF - CALL ZSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 ) - ALPHA = -HALF*TAU( I-1 )*ZDOTC( I-1, W( 1, IW ), 1, - $ A( 1, I ), 1 ) - CALL ZAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 ) - END IF -* - 10 CONTINUE - ELSE -* -* Reduce first NB columns of lower triangle -* - DO 20 I = 1, NB -* -* Update A(i:n,i) -* - A( I, I ) = DBLE( A( I, I ) ) - CALL ZLACGV( I-1, W( I, 1 ), LDW ) - CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ), - $ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 ) - CALL ZLACGV( I-1, W( I, 1 ), LDW ) - CALL ZLACGV( I-1, A( I, 1 ), LDA ) - CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ), - $ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 ) - CALL ZLACGV( I-1, A( I, 1 ), LDA ) - A( I, I ) = DBLE( A( I, I ) ) - IF( I.LT.N ) THEN -* -* Generate elementary reflector H(i) to annihilate -* A(i+2:n,i) -* - ALPHA = A( I+1, I ) - CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, - $ TAU( I ) ) - E( I ) = DBLE( ALPHA ) - A( I+1, I ) = ONE -* -* Compute W(i+1:n,i) -* - CALL ZHEMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA, - $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 ) - CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE, - $ W( I+1, 1 ), LDW, A( I+1, I ), 1, ZERO, - $ W( 1, I ), 1 ) - CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ), - $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) - CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE, - $ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO, - $ W( 1, I ), 1 ) - CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ), - $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) - CALL ZSCAL( N-I, TAU( I ), W( I+1, I ), 1 ) - ALPHA = -HALF*TAU( I )*ZDOTC( N-I, W( I+1, I ), 1, - $ A( I+1, I ), 1 ) - CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 ) - END IF -* - 20 CONTINUE - END IF -* - RETURN -* -* End of ZLATRD -* - END diff --git a/lib/linalg/fortran/zpptrf.f b/lib/linalg/fortran/zpptrf.f deleted file mode 100644 index a34d639131..0000000000 --- a/lib/linalg/fortran/zpptrf.f +++ /dev/null @@ -1,238 +0,0 @@ -*> \brief \b ZPPTRF -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZPPTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZPPTRF( UPLO, N, AP, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, N -* .. -* .. Array Arguments .. -* COMPLEX*16 AP( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZPPTRF computes the Cholesky factorization of a complex Hermitian -*> positive definite matrix A stored in packed format. -*> -*> The factorization has the form -*> A = U**H * U, if UPLO = 'U', or -*> A = L * L**H, if UPLO = 'L', -*> where U is an upper triangular matrix and L is lower triangular. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] AP -*> \verbatim -*> AP is COMPLEX*16 array, dimension (N*(N+1)/2) -*> On entry, the upper or lower triangle of the Hermitian matrix -*> A, packed columnwise in a linear array. The j-th column of A -*> is stored in the array AP as follows: -*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; -*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. -*> See below for further details. -*> -*> On exit, if INFO = 0, the triangular factor U or L from the -*> Cholesky factorization A = U**H*U or A = L*L**H, in the same -*> storage format as A. -*> \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, the leading minor of order i is not -*> positive definite, and the factorization could not be -*> completed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The packed storage scheme is illustrated by the following example -*> when N = 4, UPLO = 'U': -*> -*> Two-dimensional storage of the Hermitian matrix A: -*> -*> a11 a12 a13 a14 -*> a22 a23 a24 -*> a33 a34 (aij = conjg(aji)) -*> a44 -*> -*> Packed storage of the upper triangle of A: -*> -*> AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZPPTRF( UPLO, N, AP, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, N -* .. -* .. Array Arguments .. - COMPLEX*16 AP( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J, JC, JJ - DOUBLE PRECISION AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - COMPLEX*16 ZDOTC - EXTERNAL LSAME, ZDOTC -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZDSCAL, ZHPR, ZTPSV -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZPPTRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U**H * U. -* - JJ = 0 - DO 10 J = 1, N - JC = JJ + 1 - JJ = JJ + J -* -* Compute elements 1:J-1 of column J. -* - IF( J.GT.1 ) - $ CALL ZTPSV( 'Upper', 'Conjugate transpose', 'Non-unit', - $ J-1, AP, AP( JC ), 1 ) -* -* Compute U(J,J) and test for non-positive-definiteness. -* - AJJ = DBLE( AP( JJ ) ) - DBLE( ZDOTC( J-1, - $ AP( JC ), 1, AP( JC ), 1 ) ) - IF( AJJ.LE.ZERO ) THEN - AP( JJ ) = AJJ - GO TO 30 - END IF - AP( JJ ) = SQRT( AJJ ) - 10 CONTINUE - ELSE -* -* Compute the Cholesky factorization A = L * L**H. -* - JJ = 1 - DO 20 J = 1, N -* -* Compute L(J,J) and test for non-positive-definiteness. -* - AJJ = DBLE( AP( JJ ) ) - IF( AJJ.LE.ZERO ) THEN - AP( JJ ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - AP( JJ ) = AJJ -* -* Compute elements J+1:N of column J and update the trailing -* submatrix. -* - IF( J.LT.N ) THEN - CALL ZDSCAL( N-J, ONE / AJJ, AP( JJ+1 ), 1 ) - CALL ZHPR( 'Lower', N-J, -ONE, AP( JJ+1 ), 1, - $ AP( JJ+N-J+1 ) ) - JJ = JJ + N - J + 1 - END IF - 20 CONTINUE - END IF - GO TO 40 -* - 30 CONTINUE - INFO = J -* - 40 CONTINUE - RETURN -* -* End of ZPPTRF -* - END diff --git a/lib/linalg/fortran/zpptri.f b/lib/linalg/fortran/zpptri.f deleted file mode 100644 index a74466eb80..0000000000 --- a/lib/linalg/fortran/zpptri.f +++ /dev/null @@ -1,187 +0,0 @@ -*> \brief \b ZPPTRI -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZPPTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZPPTRI( UPLO, N, AP, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, N -* .. -* .. Array Arguments .. -* COMPLEX*16 AP( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZPPTRI computes the inverse of a complex Hermitian positive definite -*> matrix A using the Cholesky factorization A = U**H*U or A = L*L**H -*> computed by ZPPTRF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangular factor is stored in AP; -*> = 'L': Lower triangular factor is stored in AP. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] AP -*> \verbatim -*> AP is COMPLEX*16 array, dimension (N*(N+1)/2) -*> On entry, the triangular factor U or L from the Cholesky -*> factorization A = U**H*U or A = L*L**H, packed columnwise as -*> a linear array. The j-th column of U or L is stored in the -*> array AP as follows: -*> if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; -*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. -*> -*> On exit, the upper or lower triangle of the (Hermitian) -*> inverse of A, overwriting the input factor U or L. -*> \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, the (i,i) element of the factor U or L is -*> zero, and the inverse could not be computed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZPPTRI( UPLO, N, AP, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, N -* .. -* .. Array Arguments .. - COMPLEX*16 AP( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J, JC, JJ, JJN - DOUBLE PRECISION AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - COMPLEX*16 ZDOTC - EXTERNAL LSAME, ZDOTC -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZDSCAL, ZHPR, ZTPMV, ZTPTRI -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZPPTRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Invert the triangular Cholesky factor U or L. -* - CALL ZTPTRI( UPLO, 'Non-unit', N, AP, INFO ) - IF( INFO.GT.0 ) - $ RETURN - IF( UPPER ) THEN -* -* Compute the product inv(U) * inv(U)**H. -* - JJ = 0 - DO 10 J = 1, N - JC = JJ + 1 - JJ = JJ + J - IF( J.GT.1 ) - $ CALL ZHPR( 'Upper', J-1, ONE, AP( JC ), 1, AP ) - AJJ = DBLE( AP( JJ ) ) - CALL ZDSCAL( J, AJJ, AP( JC ), 1 ) - 10 CONTINUE -* - ELSE -* -* Compute the product inv(L)**H * inv(L). -* - JJ = 1 - DO 20 J = 1, N - JJN = JJ + N - J + 1 - AP( JJ ) = DBLE( ZDOTC( N-J+1, AP( JJ ), 1, AP( JJ ), 1 ) ) - IF( J.LT.N ) - $ CALL ZTPMV( 'Lower', 'Conjugate transpose', 'Non-unit', - $ N-J, AP( JJN ), AP( JJ+1 ), 1 ) - JJ = JJN - 20 CONTINUE - END IF -* - RETURN -* -* End of ZPPTRI -* - END diff --git a/lib/linalg/fortran/zscal.f b/lib/linalg/fortran/zscal.f deleted file mode 100644 index 8b8c2c8ab5..0000000000 --- a/lib/linalg/fortran/zscal.f +++ /dev/null @@ -1,121 +0,0 @@ -*> \brief \b ZSCAL -* -* =========== DOCUMENTATION =========== -* -* 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 -* .. -* .. Array Arguments .. -* COMPLEX*16 ZX(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> 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. -* -*> \ingroup complex16_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, 3/11/78. -*> modified 3/93 to return if incx .le. 0. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZSCAL(N,ZA,ZX,INCX) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 ZA - INTEGER INCX,N -* .. -* .. Array Arguments .. - COMPLEX*16 ZX(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,NINCX -* .. -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER (ONE= (1.0D+0,0.0D+0)) -* .. - IF (N.LE.0 .OR. INCX.LE.0 .OR. ZA.EQ.ONE) RETURN - IF (INCX.EQ.1) THEN -* -* code for increment equal to 1 -* - DO I = 1,N - ZX(I) = ZA*ZX(I) - END DO - ELSE -* -* code for increment not equal to 1 -* - NINCX = N*INCX - DO I = 1,NINCX,INCX - ZX(I) = ZA*ZX(I) - END DO - END IF - RETURN -* -* End of ZSCAL -* - END diff --git a/lib/linalg/fortran/zstedc.f b/lib/linalg/fortran/zstedc.f deleted file mode 100644 index 74d390af7e..0000000000 --- a/lib/linalg/fortran/zstedc.f +++ /dev/null @@ -1,483 +0,0 @@ -*> \brief \b ZSTEDC -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZSTEDC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, -* LRWORK, IWORK, LIWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER COMPZ -* INTEGER INFO, LDZ, LIWORK, LRWORK, LWORK, N -* .. -* .. Array Arguments .. -* INTEGER IWORK( * ) -* DOUBLE PRECISION D( * ), E( * ), RWORK( * ) -* COMPLEX*16 WORK( * ), Z( LDZ, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZSTEDC computes all eigenvalues and, optionally, eigenvectors of a -*> symmetric tridiagonal matrix using the divide and conquer method. -*> The eigenvectors of a full or band complex Hermitian matrix can also -*> be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this -*> matrix to tridiagonal form. -*> -*> 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 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. See DLAED3 for details. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] COMPZ -*> \verbatim -*> COMPZ is CHARACTER*1 -*> = 'N': Compute eigenvalues only. -*> = 'I': Compute eigenvectors of tridiagonal matrix also. -*> = 'V': Compute eigenvectors of original Hermitian matrix -*> also. On entry, Z contains the unitary matrix used -*> to reduce the original matrix to tridiagonal form. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the diagonal elements of the tridiagonal matrix. -*> On exit, if INFO = 0, the eigenvalues in ascending order. -*> \endverbatim -*> -*> \param[in,out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> On entry, the subdiagonal elements of the tridiagonal matrix. -*> On exit, E has been destroyed. -*> \endverbatim -*> -*> \param[in,out] Z -*> \verbatim -*> Z is COMPLEX*16 array, dimension (LDZ,N) -*> On entry, if COMPZ = 'V', then Z contains the unitary -*> matrix used in the reduction to tridiagonal form. -*> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the -*> orthonormal eigenvectors of the original Hermitian matrix, -*> and if COMPZ = 'I', Z contains the orthonormal eigenvectors -*> of the symmetric tridiagonal matrix. -*> If COMPZ = 'N', then Z is not referenced. -*> \endverbatim -*> -*> \param[in] LDZ -*> \verbatim -*> LDZ is INTEGER -*> The leading dimension of the array Z. LDZ >= 1. -*> If eigenvectors are desired, then LDZ >= max(1,N). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 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. -*> If COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1. -*> If COMPZ = 'V' and N > 1, LWORK must be at least N*N. -*> Note that for COMPZ = 'V', then if N is less than or -*> equal to the minimum divide size, usually 25, then LWORK need -*> only be 1. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal sizes of the WORK, RWORK and -*> IWORK arrays, returns these values as the first entries of -*> the WORK, RWORK and IWORK arrays, and no error message -*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] RWORK -*> \verbatim -*> RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK)) -*> On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. -*> \endverbatim -*> -*> \param[in] LRWORK -*> \verbatim -*> LRWORK is INTEGER -*> The dimension of the array RWORK. -*> If COMPZ = 'N' or N <= 1, LRWORK must be at least 1. -*> If COMPZ = 'V' and N > 1, LRWORK must be at least -*> 1 + 3*N + 2*N*lg N + 4*N**2 , -*> where lg( N ) = smallest integer k such -*> that 2**k >= N. -*> If COMPZ = 'I' and N > 1, LRWORK must be at least -*> 1 + 4*N + 2*N**2 . -*> Note that for COMPZ = 'I' or 'V', then if N is less than or -*> equal to the minimum divide size, usually 25, then LRWORK -*> need only be max(1,2*(N-1)). -*> -*> If LRWORK = -1, then a workspace query is assumed; the -*> routine only calculates the optimal sizes of the WORK, RWORK -*> and IWORK arrays, returns these values as the first entries -*> of the WORK, RWORK and IWORK arrays, and no error message -*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) -*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. -*> \endverbatim -*> -*> \param[in] LIWORK -*> \verbatim -*> LIWORK is INTEGER -*> The dimension of the array IWORK. -*> If COMPZ = 'N' or N <= 1, LIWORK must be at least 1. -*> If COMPZ = 'V' or N > 1, LIWORK must be at least -*> 6 + 6*N + 5*N*lg N. -*> If COMPZ = 'I' or N > 1, LIWORK must be at least -*> 3 + 5*N . -*> Note that for COMPZ = 'I' or 'V', then if N is less than or -*> equal to the minimum divide size, usually 25, then LIWORK -*> need only be 1. -*> -*> If LIWORK = -1, then a workspace query is assumed; the -*> routine only calculates the optimal sizes of the WORK, RWORK -*> and IWORK arrays, returns these values as the first entries -*> of the WORK, RWORK and IWORK arrays, and no error message -*> related to LWORK or LRWORK or LIWORK 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 failed to compute an eigenvalue 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. -* -*> \ingroup complex16OTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA -* -* ===================================================================== - SUBROUTINE ZSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, - $ LRWORK, IWORK, LIWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER COMPZ - INTEGER INFO, LDZ, LIWORK, LRWORK, LWORK, N -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION D( * ), E( * ), RWORK( * ) - COMPLEX*16 WORK( * ), Z( LDZ, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN, LL, - $ LRWMIN, LWMIN, M, SMLSIZ, START - DOUBLE PRECISION EPS, ORGNRM, P, TINY -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANST - EXTERNAL LSAME, ILAENV, DLAMCH, DLANST -* .. -* .. External Subroutines .. - EXTERNAL DLASCL, DLASET, DSTEDC, DSTEQR, DSTERF, XERBLA, - $ ZLACPY, ZLACRM, ZLAED0, ZSTEQR, ZSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, LOG, MAX, MOD, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) -* - IF( LSAME( COMPZ, 'N' ) ) THEN - ICOMPZ = 0 - ELSE IF( LSAME( COMPZ, 'V' ) ) THEN - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ICOMPZ = 2 - ELSE - ICOMPZ = -1 - END IF - IF( ICOMPZ.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( ( LDZ.LT.1 ) .OR. - $ ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, N ) ) ) THEN - INFO = -6 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Compute the workspace requirements -* - SMLSIZ = ILAENV( 9, 'ZSTEDC', ' ', 0, 0, 0, 0 ) - IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN - LWMIN = 1 - LIWMIN = 1 - LRWMIN = 1 - ELSE IF( N.LE.SMLSIZ ) THEN - LWMIN = 1 - LIWMIN = 1 - LRWMIN = 2*( N - 1 ) - ELSE IF( ICOMPZ.EQ.1 ) THEN - LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) ) - IF( 2**LGN.LT.N ) - $ LGN = LGN + 1 - IF( 2**LGN.LT.N ) - $ LGN = LGN + 1 - LWMIN = N*N - LRWMIN = 1 + 3*N + 2*N*LGN + 4*N**2 - LIWMIN = 6 + 6*N + 5*N*LGN - ELSE IF( ICOMPZ.EQ.2 ) THEN - LWMIN = 1 - LRWMIN = 1 + 4*N + 2*N**2 - LIWMIN = 3 + 5*N - END IF - WORK( 1 ) = LWMIN - RWORK( 1 ) = LRWMIN - IWORK( 1 ) = LIWMIN -* - IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN - INFO = -8 - ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN - INFO = -10 - ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZSTEDC', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN - IF( N.EQ.1 ) THEN - IF( ICOMPZ.NE.0 ) - $ Z( 1, 1 ) = ONE - RETURN - END IF -* -* If the following conditional clause is removed, then the routine -* will use the Divide and Conquer routine to compute only the -* eigenvalues, which requires (3N + 3N**2) real workspace and -* (2 + 5N + 2N lg(N)) integer workspace. -* Since on many architectures DSTERF is much faster than any other -* algorithm for finding eigenvalues only, it is used here -* as the default. If the conditional clause is removed, then -* information on the size of workspace needs to be changed. -* -* If COMPZ = 'N', use DSTERF to compute the eigenvalues. -* - IF( ICOMPZ.EQ.0 ) THEN - CALL DSTERF( N, D, E, INFO ) - GO TO 70 - END IF -* -* If N is smaller than the minimum divide size (SMLSIZ+1), then -* solve the problem with another solver. -* - IF( N.LE.SMLSIZ ) THEN -* - CALL ZSTEQR( COMPZ, N, D, E, Z, LDZ, RWORK, INFO ) -* - ELSE -* -* If COMPZ = 'I', we simply call DSTEDC instead. -* - IF( ICOMPZ.EQ.2 ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, RWORK, N ) - LL = N*N + 1 - CALL DSTEDC( 'I', N, D, E, RWORK, N, - $ RWORK( LL ), LRWORK-LL+1, IWORK, LIWORK, INFO ) - DO 20 J = 1, N - DO 10 I = 1, N - Z( I, J ) = RWORK( ( J-1 )*N+I ) - 10 CONTINUE - 20 CONTINUE - GO TO 70 - END IF -* -* From now on, only option left to be handled is COMPZ = 'V', -* i.e. ICOMPZ = 1. -* -* Scale. -* - ORGNRM = DLANST( 'M', N, D, E ) - IF( ORGNRM.EQ.ZERO ) - $ GO TO 70 -* - EPS = DLAMCH( 'Epsilon' ) -* - START = 1 -* -* while ( START <= N ) -* - 30 CONTINUE - IF( START.LE.N ) THEN -* -* Let FINISH be the position of the next subdiagonal entry -* such that E( FINISH ) <= TINY or FINISH = N if no such -* subdiagonal exists. The matrix identified by the elements -* between START and FINISH constitutes an independent -* sub-problem. -* - FINISH = START - 40 CONTINUE - IF( FINISH.LT.N ) THEN - TINY = EPS*SQRT( ABS( D( FINISH ) ) )* - $ SQRT( ABS( D( FINISH+1 ) ) ) - IF( ABS( E( FINISH ) ).GT.TINY ) THEN - FINISH = FINISH + 1 - GO TO 40 - END IF - END IF -* -* (Sub) Problem determined. Compute its size and solve it. -* - M = FINISH - START + 1 - IF( M.GT.SMLSIZ ) THEN -* -* Scale. -* - ORGNRM = DLANST( 'M', M, D( START ), E( START ) ) - CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ), - $ M-1, INFO ) -* - CALL ZLAED0( N, M, D( START ), E( START ), Z( 1, START ), - $ LDZ, WORK, N, RWORK, IWORK, INFO ) - IF( INFO.GT.0 ) THEN - INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) + - $ MOD( INFO, ( M+1 ) ) + START - 1 - GO TO 70 - END IF -* -* Scale back. -* - CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M, - $ INFO ) -* - ELSE - CALL DSTEQR( 'I', M, D( START ), E( START ), RWORK, M, - $ RWORK( M*M+1 ), INFO ) - CALL ZLACRM( N, M, Z( 1, START ), LDZ, RWORK, M, WORK, N, - $ RWORK( M*M+1 ) ) - CALL ZLACPY( 'A', N, M, WORK, N, Z( 1, START ), LDZ ) - IF( INFO.GT.0 ) THEN - INFO = START*( N+1 ) + FINISH - GO TO 70 - END IF - END IF -* - START = FINISH + 1 - GO TO 30 - END IF -* -* endwhile -* -* -* Use Selection Sort to minimize swaps of eigenvectors -* - DO 60 II = 2, N - I = II - 1 - K = I - P = D( I ) - DO 50 J = II, N - IF( D( J ).LT.P ) THEN - K = J - P = D( J ) - END IF - 50 CONTINUE - IF( K.NE.I ) THEN - D( K ) = D( I ) - D( I ) = P - CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) - END IF - 60 CONTINUE - END IF -* - 70 CONTINUE - WORK( 1 ) = LWMIN - RWORK( 1 ) = LRWMIN - IWORK( 1 ) = LIWMIN -* - RETURN -* -* End of ZSTEDC -* - END diff --git a/lib/linalg/fortran/zsteqr.f b/lib/linalg/fortran/zsteqr.f deleted file mode 100644 index 47f4004e8d..0000000000 --- a/lib/linalg/fortran/zsteqr.f +++ /dev/null @@ -1,573 +0,0 @@ -*> \brief \b ZSTEQR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZSTEQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER COMPZ -* INTEGER INFO, LDZ, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ), E( * ), WORK( * ) -* COMPLEX*16 Z( LDZ, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a -*> symmetric tridiagonal matrix using the implicit QL or QR method. -*> The eigenvectors of a full or band complex Hermitian matrix can also -*> be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this -*> matrix to tridiagonal form. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] COMPZ -*> \verbatim -*> COMPZ is CHARACTER*1 -*> = 'N': Compute eigenvalues only. -*> = 'V': Compute eigenvalues and eigenvectors of the original -*> Hermitian matrix. On entry, Z must contain the -*> unitary matrix used to reduce the original matrix -*> to tridiagonal form. -*> = 'I': Compute eigenvalues and eigenvectors of the -*> tridiagonal matrix. Z is initialized to the identity -*> matrix. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix. N >= 0. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the diagonal elements of the tridiagonal matrix. -*> On exit, if INFO = 0, the eigenvalues in ascending order. -*> \endverbatim -*> -*> \param[in,out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> On entry, the (n-1) subdiagonal elements of the tridiagonal -*> matrix. -*> On exit, E has been destroyed. -*> \endverbatim -*> -*> \param[in,out] Z -*> \verbatim -*> Z is COMPLEX*16 array, dimension (LDZ, N) -*> On entry, if COMPZ = 'V', then Z contains the unitary -*> matrix used in the reduction to tridiagonal form. -*> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the -*> orthonormal eigenvectors of the original Hermitian matrix, -*> and if COMPZ = 'I', Z contains the orthonormal eigenvectors -*> of the symmetric tridiagonal matrix. -*> If COMPZ = 'N', then Z is not referenced. -*> \endverbatim -*> -*> \param[in] LDZ -*> \verbatim -*> LDZ is INTEGER -*> The leading dimension of the array Z. LDZ >= 1, and if -*> eigenvectors are desired, then LDZ >= max(1,N). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (max(1,2*N-2)) -*> If COMPZ = 'N', then WORK is not referenced. -*> \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 has failed to find all the eigenvalues in -*> a total of 30*N iterations; if INFO = i, then i -*> elements of E have not converged to zero; on exit, D -*> and E contain the elements of a symmetric tridiagonal -*> matrix which is unitarily similar to the original -*> matrix. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER COMPZ - INTEGER INFO, LDZ, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ), WORK( * ) - COMPLEX*16 Z( LDZ, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) - COMPLEX*16 CZERO, CONE - PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), - $ CONE = ( 1.0D0, 0.0D0 ) ) - INTEGER MAXIT - PARAMETER ( MAXIT = 30 ) -* .. -* .. Local Scalars .. - INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, - $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, - $ NM1, NMAXIT - DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, - $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 - EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 -* .. -* .. External Subroutines .. - EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASRT, XERBLA, - $ ZLASET, ZLASR, ZSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( LSAME( COMPZ, 'N' ) ) THEN - ICOMPZ = 0 - ELSE IF( LSAME( COMPZ, 'V' ) ) THEN - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ICOMPZ = 2 - ELSE - ICOMPZ = -1 - END IF - IF( ICOMPZ.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, - $ N ) ) ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZSTEQR', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( N.EQ.1 ) THEN - IF( ICOMPZ.EQ.2 ) - $ Z( 1, 1 ) = CONE - RETURN - END IF -* -* Determine the unit roundoff and over/underflow thresholds. -* - EPS = DLAMCH( 'E' ) - EPS2 = EPS**2 - SAFMIN = DLAMCH( 'S' ) - SAFMAX = ONE / SAFMIN - SSFMAX = SQRT( SAFMAX ) / THREE - SSFMIN = SQRT( SAFMIN ) / EPS2 -* -* Compute the eigenvalues and eigenvectors of the tridiagonal -* matrix. -* - IF( ICOMPZ.EQ.2 ) - $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ ) -* - NMAXIT = N*MAXIT - JTOT = 0 -* -* Determine where the matrix splits and choose QL or QR iteration -* for each block, according to whether top or bottom diagonal -* element is smaller. -* - L1 = 1 - NM1 = N - 1 -* - 10 CONTINUE - IF( L1.GT.N ) - $ GO TO 160 - IF( L1.GT.1 ) - $ E( L1-1 ) = ZERO - IF( L1.LE.NM1 ) THEN - DO 20 M = L1, NM1 - TST = ABS( E( M ) ) - IF( TST.EQ.ZERO ) - $ GO TO 30 - IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ - $ 1 ) ) ) )*EPS ) THEN - E( M ) = ZERO - GO TO 30 - END IF - 20 CONTINUE - END IF - M = N -* - 30 CONTINUE - L = L1 - LSV = L - LEND = M - LENDSV = LEND - L1 = M + 1 - IF( LEND.EQ.L ) - $ GO TO 10 -* -* Scale submatrix in rows and columns L to LEND -* - ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) - ISCALE = 0 - IF( ANORM.EQ.ZERO ) - $ GO TO 10 - IF( ANORM.GT.SSFMAX ) THEN - ISCALE = 1 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, - $ INFO ) - ELSE IF( ANORM.LT.SSFMIN ) THEN - ISCALE = 2 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, - $ INFO ) - END IF -* -* Choose between QL and QR iteration -* - IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN - LEND = LSV - L = LENDSV - END IF -* - IF( LEND.GT.L ) THEN -* -* QL Iteration -* -* Look for small subdiagonal element. -* - 40 CONTINUE - IF( L.NE.LEND ) THEN - LENDM1 = LEND - 1 - DO 50 M = L, LENDM1 - TST = ABS( E( M ) )**2 - IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ - $ SAFMIN )GO TO 60 - 50 CONTINUE - END IF -* - M = LEND -* - 60 CONTINUE - IF( M.LT.LEND ) - $ E( M ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 80 -* -* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 -* to compute its eigensystem. -* - IF( M.EQ.L+1 ) THEN - IF( ICOMPZ.GT.0 ) THEN - CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) - WORK( L ) = C - WORK( N-1+L ) = S - CALL ZLASR( 'R', 'V', 'B', N, 2, WORK( L ), - $ WORK( N-1+L ), Z( 1, L ), LDZ ) - ELSE - CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) - END IF - D( L ) = RT1 - D( L+1 ) = RT2 - E( L ) = ZERO - L = L + 2 - IF( L.LE.LEND ) - $ GO TO 40 - GO TO 140 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 140 - JTOT = JTOT + 1 -* -* Form shift. -* - G = ( D( L+1 )-P ) / ( TWO*E( L ) ) - R = DLAPY2( G, ONE ) - G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) -* - S = ONE - C = ONE - P = ZERO -* -* Inner loop -* - MM1 = M - 1 - DO 70 I = MM1, L, -1 - F = S*E( I ) - B = C*E( I ) - CALL DLARTG( G, F, C, S, R ) - IF( I.NE.M-1 ) - $ E( I+1 ) = R - G = D( I+1 ) - P - R = ( D( I )-G )*S + TWO*C*B - P = S*R - D( I+1 ) = G + P - G = C*R - B -* -* If eigenvectors are desired, then save rotations. -* - IF( ICOMPZ.GT.0 ) THEN - WORK( I ) = C - WORK( N-1+I ) = -S - END IF -* - 70 CONTINUE -* -* If eigenvectors are desired, then apply saved rotations. -* - IF( ICOMPZ.GT.0 ) THEN - MM = M - L + 1 - CALL ZLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), - $ Z( 1, L ), LDZ ) - END IF -* - D( L ) = D( L ) - P - E( L ) = G - GO TO 40 -* -* Eigenvalue found. -* - 80 CONTINUE - D( L ) = P -* - L = L + 1 - IF( L.LE.LEND ) - $ GO TO 40 - GO TO 140 -* - ELSE -* -* QR Iteration -* -* Look for small superdiagonal element. -* - 90 CONTINUE - IF( L.NE.LEND ) THEN - LENDP1 = LEND + 1 - DO 100 M = L, LENDP1, -1 - TST = ABS( E( M-1 ) )**2 - IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ - $ SAFMIN )GO TO 110 - 100 CONTINUE - END IF -* - M = LEND -* - 110 CONTINUE - IF( M.GT.LEND ) - $ E( M-1 ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 130 -* -* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 -* to compute its eigensystem. -* - IF( M.EQ.L-1 ) THEN - IF( ICOMPZ.GT.0 ) THEN - CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) - WORK( M ) = C - WORK( N-1+M ) = S - CALL ZLASR( 'R', 'V', 'F', N, 2, WORK( M ), - $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) - ELSE - CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) - END IF - D( L-1 ) = RT1 - D( L ) = RT2 - E( L-1 ) = ZERO - L = L - 2 - IF( L.GE.LEND ) - $ GO TO 90 - GO TO 140 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 140 - JTOT = JTOT + 1 -* -* Form shift. -* - G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) - R = DLAPY2( G, ONE ) - G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) -* - S = ONE - C = ONE - P = ZERO -* -* Inner loop -* - LM1 = L - 1 - DO 120 I = M, LM1 - F = S*E( I ) - B = C*E( I ) - CALL DLARTG( G, F, C, S, R ) - IF( I.NE.M ) - $ E( I-1 ) = R - G = D( I ) - P - R = ( D( I+1 )-G )*S + TWO*C*B - P = S*R - D( I ) = G + P - G = C*R - B -* -* If eigenvectors are desired, then save rotations. -* - IF( ICOMPZ.GT.0 ) THEN - WORK( I ) = C - WORK( N-1+I ) = S - END IF -* - 120 CONTINUE -* -* If eigenvectors are desired, then apply saved rotations. -* - IF( ICOMPZ.GT.0 ) THEN - MM = L - M + 1 - CALL ZLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), - $ Z( 1, M ), LDZ ) - END IF -* - D( L ) = D( L ) - P - E( LM1 ) = G - GO TO 90 -* -* Eigenvalue found. -* - 130 CONTINUE - D( L ) = P -* - L = L - 1 - IF( L.GE.LEND ) - $ GO TO 90 - GO TO 140 -* - END IF -* -* Undo scaling if necessary -* - 140 CONTINUE - IF( ISCALE.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) - CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), - $ N, INFO ) - ELSE IF( ISCALE.EQ.2 ) THEN - CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) - CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), - $ N, INFO ) - END IF -* -* Check for no convergence to an eigenvalue after a total -* of N*MAXIT iterations. -* - IF( JTOT.EQ.NMAXIT ) THEN - DO 150 I = 1, N - 1 - IF( E( I ).NE.ZERO ) - $ INFO = INFO + 1 - 150 CONTINUE - RETURN - END IF - GO TO 10 -* -* Order eigenvalues and eigenvectors. -* - 160 CONTINUE - IF( ICOMPZ.EQ.0 ) THEN -* -* Use Quick Sort -* - CALL DLASRT( 'I', N, D, INFO ) -* - ELSE -* -* Use Selection Sort to minimize swaps of eigenvectors -* - DO 180 II = 2, N - I = II - 1 - K = I - P = D( I ) - DO 170 J = II, N - IF( D( J ).LT.P ) THEN - K = J - P = D( J ) - END IF - 170 CONTINUE - IF( K.NE.I ) THEN - D( K ) = D( I ) - D( I ) = P - CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) - END IF - 180 CONTINUE - END IF - RETURN -* -* End of ZSTEQR -* - END diff --git a/lib/linalg/fortran/zswap.f b/lib/linalg/fortran/zswap.f deleted file mode 100644 index 93f8fc52d0..0000000000 --- a/lib/linalg/fortran/zswap.f +++ /dev/null @@ -1,129 +0,0 @@ -*> \brief \b ZSWAP -* -* =========== DOCUMENTATION =========== -* -* 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: -* ============= -*> -*> \verbatim -*> -*> 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. -* -*> \ingroup complex16_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, 3/11/78. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - COMPLEX*16 ZX(*),ZY(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - COMPLEX*16 ZTEMP - INTEGER I,IX,IY -* .. - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 - DO I = 1,N - ZTEMP = ZX(I) - ZX(I) = ZY(I) - ZY(I) = ZTEMP - END DO - ELSE -* -* code for unequal increments or equal increments not equal -* to 1 -* - IX = 1 - IY = 1 - IF (INCX.LT.0) IX = (-N+1)*INCX + 1 - IF (INCY.LT.0) IY = (-N+1)*INCY + 1 - DO I = 1,N - ZTEMP = ZX(IX) - ZX(IX) = ZY(IY) - ZY(IY) = ZTEMP - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN -* -* End of ZSWAP -* - END diff --git a/lib/linalg/fortran/ztpmv.f b/lib/linalg/fortran/ztpmv.f deleted file mode 100644 index 363fd5a2ac..0000000000 --- a/lib/linalg/fortran/ztpmv.f +++ /dev/null @@ -1,385 +0,0 @@ -*> \brief \b ZTPMV -* -* =========== DOCUMENTATION =========== -* -* 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 -* .. -* .. Array Arguments .. -* COMPLEX*16 AP(*),X(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZTPMV performs one of the matrix-vector operations -*> -*> x := A*x, or x := A**T*x, or x := A**H*x, -*> -*> where x is an n element vector and A is an n by n unit, or non-unit, -*> upper or lower triangular matrix, supplied in packed form. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the matrix is an upper or -*> lower triangular matrix as follows: -*> -*> UPLO = 'U' or 'u' A is an upper triangular matrix. -*> -*> UPLO = 'L' or 'l' A is a lower triangular matrix. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the operation to be performed as -*> follows: -*> -*> TRANS = 'N' or 'n' x := A*x. -*> -*> TRANS = 'T' or 't' x := A**T*x. -*> -*> TRANS = 'C' or 'c' x := A**H*x. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> On entry, DIAG specifies whether or not A is unit -*> triangular as follows: -*> -*> DIAG = 'U' or 'u' A is assumed to be unit triangular. -*> -*> DIAG = 'N' or 'n' A is not assumed to be unit -*> triangular. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] AP -*> \verbatim -*> AP is COMPLEX*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, -*> column by column, so that AP( 1 ) contains a( 1, 1 ), -*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -*> respectively, and so on. -*> Before entry with UPLO = 'L' or 'l', the array AP must -*> contain the lower triangular matrix packed sequentially, -*> column by column, so that AP( 1 ) contains a( 1, 1 ), -*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -*> respectively, and so on. -*> Note that when DIAG = 'U' or 'u', the diagonal elements of -*> A are not referenced, but are assumed to be unity. -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is COMPLEX*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 -*> transformed vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> The vector and matrix arguments are not referenced when N = 0, or M = 0 -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,N - CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. - COMPLEX*16 AP(*),X(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I,INFO,IX,J,JX,K,KK,KX - LOGICAL NOCONJ,NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 2 - ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (INCX.EQ.0) THEN - INFO = 7 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZTPMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOCONJ = LSAME(TRANS,'T') - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of AP are -* accessed sequentially with one pass through AP. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x:= A*x. -* - IF (LSAME(UPLO,'U')) THEN - KK = 1 - IF (INCX.EQ.1) THEN - DO 20 J = 1,N - IF (X(J).NE.ZERO) THEN - TEMP = X(J) - K = KK - DO 10 I = 1,J - 1 - X(I) = X(I) + TEMP*AP(K) - K = K + 1 - 10 CONTINUE - IF (NOUNIT) X(J) = X(J)*AP(KK+J-1) - END IF - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = X(JX) - IX = KX - DO 30 K = KK,KK + J - 2 - X(IX) = X(IX) + TEMP*AP(K) - IX = IX + INCX - 30 CONTINUE - IF (NOUNIT) X(JX) = X(JX)*AP(KK+J-1) - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE - KK = (N* (N+1))/2 - IF (INCX.EQ.1) THEN - DO 60 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - TEMP = X(J) - K = KK - DO 50 I = N,J + 1,-1 - X(I) = X(I) + TEMP*AP(K) - K = K - 1 - 50 CONTINUE - IF (NOUNIT) X(J) = X(J)*AP(KK-N+J) - END IF - KK = KK - (N-J+1) - 60 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 80 J = N,1,-1 - IF (X(JX).NE.ZERO) THEN - TEMP = X(JX) - IX = KX - DO 70 K = KK,KK - (N- (J+1)),-1 - X(IX) = X(IX) + TEMP*AP(K) - IX = IX - INCX - 70 CONTINUE - IF (NOUNIT) X(JX) = X(JX)*AP(KK-N+J) - END IF - JX = JX - INCX - KK = KK - (N-J+1) - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A**T*x or x := A**H*x. -* - IF (LSAME(UPLO,'U')) THEN - KK = (N* (N+1))/2 - IF (INCX.EQ.1) THEN - DO 110 J = N,1,-1 - TEMP = X(J) - K = KK - 1 - IF (NOCONJ) THEN - IF (NOUNIT) TEMP = TEMP*AP(KK) - DO 90 I = J - 1,1,-1 - TEMP = TEMP + AP(K)*X(I) - K = K - 1 - 90 CONTINUE - ELSE - IF (NOUNIT) TEMP = TEMP*DCONJG(AP(KK)) - DO 100 I = J - 1,1,-1 - TEMP = TEMP + DCONJG(AP(K))*X(I) - K = K - 1 - 100 CONTINUE - END IF - X(J) = TEMP - KK = KK - J - 110 CONTINUE - ELSE - JX = KX + (N-1)*INCX - DO 140 J = N,1,-1 - TEMP = X(JX) - IX = JX - IF (NOCONJ) THEN - IF (NOUNIT) TEMP = TEMP*AP(KK) - DO 120 K = KK - 1,KK - J + 1,-1 - IX = IX - INCX - TEMP = TEMP + AP(K)*X(IX) - 120 CONTINUE - ELSE - IF (NOUNIT) TEMP = TEMP*DCONJG(AP(KK)) - DO 130 K = KK - 1,KK - J + 1,-1 - IX = IX - INCX - TEMP = TEMP + DCONJG(AP(K))*X(IX) - 130 CONTINUE - END IF - X(JX) = TEMP - JX = JX - INCX - KK = KK - J - 140 CONTINUE - END IF - ELSE - KK = 1 - IF (INCX.EQ.1) THEN - DO 170 J = 1,N - TEMP = X(J) - K = KK + 1 - IF (NOCONJ) THEN - IF (NOUNIT) TEMP = TEMP*AP(KK) - DO 150 I = J + 1,N - TEMP = TEMP + AP(K)*X(I) - K = K + 1 - 150 CONTINUE - ELSE - IF (NOUNIT) TEMP = TEMP*DCONJG(AP(KK)) - DO 160 I = J + 1,N - TEMP = TEMP + DCONJG(AP(K))*X(I) - K = K + 1 - 160 CONTINUE - END IF - X(J) = TEMP - KK = KK + (N-J+1) - 170 CONTINUE - ELSE - JX = KX - DO 200 J = 1,N - TEMP = X(JX) - IX = JX - IF (NOCONJ) THEN - IF (NOUNIT) TEMP = TEMP*AP(KK) - DO 180 K = KK + 1,KK + N - J - IX = IX + INCX - TEMP = TEMP + AP(K)*X(IX) - 180 CONTINUE - ELSE - IF (NOUNIT) TEMP = TEMP*DCONJG(AP(KK)) - DO 190 K = KK + 1,KK + N - J - IX = IX + INCX - TEMP = TEMP + DCONJG(AP(K))*X(IX) - 190 CONTINUE - END IF - X(JX) = TEMP - JX = JX + INCX - KK = KK + (N-J+1) - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTPMV -* - END diff --git a/lib/linalg/fortran/ztpsv.f b/lib/linalg/fortran/ztpsv.f deleted file mode 100644 index c6f24d0b27..0000000000 --- a/lib/linalg/fortran/ztpsv.f +++ /dev/null @@ -1,387 +0,0 @@ -*> \brief \b ZTPSV -* -* =========== DOCUMENTATION =========== -* -* 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 -* .. -* .. Array Arguments .. -* COMPLEX*16 AP(*),X(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZTPSV solves one of the systems of equations -*> -*> A*x = b, or A**T*x = b, or A**H*x = b, -*> -*> where b and x are n element vectors and A is an n by n unit, or -*> non-unit, upper or lower triangular matrix, supplied in packed form. -*> -*> No test for singularity or near-singularity is included in this -*> routine. Such tests must be performed before calling this routine. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the matrix is an upper or -*> lower triangular matrix as follows: -*> -*> UPLO = 'U' or 'u' A is an upper triangular matrix. -*> -*> UPLO = 'L' or 'l' A is a lower triangular matrix. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the equations to be solved as -*> follows: -*> -*> TRANS = 'N' or 'n' A*x = b. -*> -*> TRANS = 'T' or 't' A**T*x = b. -*> -*> TRANS = 'C' or 'c' A**H*x = b. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> On entry, DIAG specifies whether or not A is unit -*> triangular as follows: -*> -*> DIAG = 'U' or 'u' A is assumed to be unit triangular. -*> -*> DIAG = 'N' or 'n' A is not assumed to be unit -*> triangular. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] AP -*> \verbatim -*> AP is COMPLEX*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, -*> column by column, so that AP( 1 ) contains a( 1, 1 ), -*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -*> respectively, and so on. -*> Before entry with UPLO = 'L' or 'l', the array AP must -*> contain the lower triangular matrix packed sequentially, -*> column by column, so that AP( 1 ) contains a( 1, 1 ), -*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -*> respectively, and so on. -*> Note that when DIAG = 'U' or 'u', the diagonal elements of -*> A are not referenced, but are assumed to be unity. -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is COMPLEX*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 -*> with the solution vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,N - CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. - COMPLEX*16 AP(*),X(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I,INFO,IX,J,JX,K,KK,KX - LOGICAL NOCONJ,NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 2 - ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (INCX.EQ.0) THEN - INFO = 7 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZTPSV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOCONJ = LSAME(TRANS,'T') - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of AP are -* accessed sequentially with one pass through AP. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x := inv( A )*x. -* - IF (LSAME(UPLO,'U')) THEN - KK = (N* (N+1))/2 - IF (INCX.EQ.1) THEN - DO 20 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - IF (NOUNIT) X(J) = X(J)/AP(KK) - TEMP = X(J) - K = KK - 1 - DO 10 I = J - 1,1,-1 - X(I) = X(I) - TEMP*AP(K) - K = K - 1 - 10 CONTINUE - END IF - KK = KK - J - 20 CONTINUE - ELSE - JX = KX + (N-1)*INCX - DO 40 J = N,1,-1 - IF (X(JX).NE.ZERO) THEN - IF (NOUNIT) X(JX) = X(JX)/AP(KK) - TEMP = X(JX) - IX = JX - DO 30 K = KK - 1,KK - J + 1,-1 - IX = IX - INCX - X(IX) = X(IX) - TEMP*AP(K) - 30 CONTINUE - END IF - JX = JX - INCX - KK = KK - J - 40 CONTINUE - END IF - ELSE - KK = 1 - IF (INCX.EQ.1) THEN - DO 60 J = 1,N - IF (X(J).NE.ZERO) THEN - IF (NOUNIT) X(J) = X(J)/AP(KK) - TEMP = X(J) - K = KK + 1 - DO 50 I = J + 1,N - X(I) = X(I) - TEMP*AP(K) - K = K + 1 - 50 CONTINUE - END IF - KK = KK + (N-J+1) - 60 CONTINUE - ELSE - JX = KX - DO 80 J = 1,N - IF (X(JX).NE.ZERO) THEN - IF (NOUNIT) X(JX) = X(JX)/AP(KK) - TEMP = X(JX) - IX = JX - DO 70 K = KK + 1,KK + N - J - IX = IX + INCX - X(IX) = X(IX) - TEMP*AP(K) - 70 CONTINUE - END IF - JX = JX + INCX - KK = KK + (N-J+1) - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A**T )*x or x := inv( A**H )*x. -* - IF (LSAME(UPLO,'U')) THEN - KK = 1 - IF (INCX.EQ.1) THEN - DO 110 J = 1,N - TEMP = X(J) - K = KK - IF (NOCONJ) THEN - DO 90 I = 1,J - 1 - TEMP = TEMP - AP(K)*X(I) - K = K + 1 - 90 CONTINUE - IF (NOUNIT) TEMP = TEMP/AP(KK+J-1) - ELSE - DO 100 I = 1,J - 1 - TEMP = TEMP - DCONJG(AP(K))*X(I) - K = K + 1 - 100 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(AP(KK+J-1)) - END IF - X(J) = TEMP - KK = KK + J - 110 CONTINUE - ELSE - JX = KX - DO 140 J = 1,N - TEMP = X(JX) - IX = KX - IF (NOCONJ) THEN - DO 120 K = KK,KK + J - 2 - TEMP = TEMP - AP(K)*X(IX) - IX = IX + INCX - 120 CONTINUE - IF (NOUNIT) TEMP = TEMP/AP(KK+J-1) - ELSE - DO 130 K = KK,KK + J - 2 - TEMP = TEMP - DCONJG(AP(K))*X(IX) - IX = IX + INCX - 130 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(AP(KK+J-1)) - END IF - X(JX) = TEMP - JX = JX + INCX - KK = KK + J - 140 CONTINUE - END IF - ELSE - KK = (N* (N+1))/2 - IF (INCX.EQ.1) THEN - DO 170 J = N,1,-1 - TEMP = X(J) - K = KK - IF (NOCONJ) THEN - DO 150 I = N,J + 1,-1 - TEMP = TEMP - AP(K)*X(I) - K = K - 1 - 150 CONTINUE - IF (NOUNIT) TEMP = TEMP/AP(KK-N+J) - ELSE - DO 160 I = N,J + 1,-1 - TEMP = TEMP - DCONJG(AP(K))*X(I) - K = K - 1 - 160 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(AP(KK-N+J)) - END IF - X(J) = TEMP - KK = KK - (N-J+1) - 170 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 200 J = N,1,-1 - TEMP = X(JX) - IX = KX - IF (NOCONJ) THEN - DO 180 K = KK,KK - (N- (J+1)),-1 - TEMP = TEMP - AP(K)*X(IX) - IX = IX - INCX - 180 CONTINUE - IF (NOUNIT) TEMP = TEMP/AP(KK-N+J) - ELSE - DO 190 K = KK,KK - (N- (J+1)),-1 - TEMP = TEMP - DCONJG(AP(K))*X(IX) - IX = IX - INCX - 190 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(AP(KK-N+J)) - END IF - X(JX) = TEMP - JX = JX - INCX - KK = KK - (N-J+1) - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTPSV -* - END diff --git a/lib/linalg/fortran/ztptri.f b/lib/linalg/fortran/ztptri.f deleted file mode 100644 index 31284ad637..0000000000 --- a/lib/linalg/fortran/ztptri.f +++ /dev/null @@ -1,239 +0,0 @@ -*> \brief \b ZTPTRI -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZTPTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZTPTRI( UPLO, DIAG, N, AP, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER DIAG, UPLO -* INTEGER INFO, N -* .. -* .. Array Arguments .. -* COMPLEX*16 AP( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZTPTRI computes the inverse of a complex upper or lower triangular -*> matrix A stored in packed format. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': A is upper triangular; -*> = 'L': A is lower triangular. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> = 'N': A is non-unit triangular; -*> = 'U': A is unit triangular. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] AP -*> \verbatim -*> AP is COMPLEX*16 array, dimension (N*(N+1)/2) -*> On entry, the upper or lower triangular matrix A, stored -*> columnwise in a linear array. The j-th column of A is stored -*> in the array AP as follows: -*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; -*> if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n. -*> See below for further details. -*> On exit, the (triangular) inverse of the original matrix, in -*> the same packed storage format. -*> \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, A(i,i) is exactly zero. The triangular -*> matrix is singular and its inverse can not be computed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> A triangular matrix A can be transferred to packed storage using one -*> of the following program segments: -*> -*> UPLO = 'U': UPLO = 'L': -*> -*> JC = 1 JC = 1 -*> DO 2 J = 1, N DO 2 J = 1, N -*> DO 1 I = 1, J DO 1 I = J, N -*> AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) -*> 1 CONTINUE 1 CONTINUE -*> JC = JC + J JC = JC + N - J + 1 -*> 2 CONTINUE 2 CONTINUE -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZTPTRI( UPLO, DIAG, N, AP, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, N -* .. -* .. Array Arguments .. - COMPLEX*16 AP( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J, JC, JCLAST, JJ - COMPLEX*16 AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZSCAL, ZTPMV -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZTPTRI', -INFO ) - RETURN - END IF -* -* Check for singularity if non-unit. -* - IF( NOUNIT ) THEN - IF( UPPER ) THEN - JJ = 0 - DO 10 INFO = 1, N - JJ = JJ + INFO - IF( AP( JJ ).EQ.ZERO ) - $ RETURN - 10 CONTINUE - ELSE - JJ = 1 - DO 20 INFO = 1, N - IF( AP( JJ ).EQ.ZERO ) - $ RETURN - JJ = JJ + N - INFO + 1 - 20 CONTINUE - END IF - INFO = 0 - END IF -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix. -* - JC = 1 - DO 30 J = 1, N - IF( NOUNIT ) THEN - AP( JC+J-1 ) = ONE / AP( JC+J-1 ) - AJJ = -AP( JC+J-1 ) - ELSE - AJJ = -ONE - END IF -* -* Compute elements 1:j-1 of j-th column. -* - CALL ZTPMV( 'Upper', 'No transpose', DIAG, J-1, AP, - $ AP( JC ), 1 ) - CALL ZSCAL( J-1, AJJ, AP( JC ), 1 ) - JC = JC + J - 30 CONTINUE -* - ELSE -* -* Compute inverse of lower triangular matrix. -* - JC = N*( N+1 ) / 2 - DO 40 J = N, 1, -1 - IF( NOUNIT ) THEN - AP( JC ) = ONE / AP( JC ) - AJJ = -AP( JC ) - ELSE - AJJ = -ONE - END IF - IF( J.LT.N ) THEN -* -* Compute elements j+1:n of j-th column. -* - CALL ZTPMV( 'Lower', 'No transpose', DIAG, N-J, - $ AP( JCLAST ), AP( JC+1 ), 1 ) - CALL ZSCAL( N-J, AJJ, AP( JC+1 ), 1 ) - END IF - JCLAST = JC - JC = JC - N + J - 2 - 40 CONTINUE - END IF -* - RETURN -* -* End of ZTPTRI -* - END diff --git a/lib/linalg/fortran/ztrmm.f b/lib/linalg/fortran/ztrmm.f deleted file mode 100644 index c59c367cee..0000000000 --- a/lib/linalg/fortran/ztrmm.f +++ /dev/null @@ -1,449 +0,0 @@ -*> \brief \b ZTRMM -* -* =========== DOCUMENTATION =========== -* -* 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 -* CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. -* COMPLEX*16 A(LDA,*),B(LDB,*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZTRMM performs one of the matrix-matrix operations -*> -*> B := alpha*op( A )*B, or B := alpha*B*op( A ) -*> -*> where alpha is a scalar, B is an m by n matrix, A is a unit, or -*> non-unit, upper or lower triangular matrix and op( A ) is one of -*> -*> op( A ) = A or op( A ) = A**T or op( A ) = A**H. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> On entry, SIDE specifies whether op( A ) multiplies B from -*> the left or right as follows: -*> -*> SIDE = 'L' or 'l' B := alpha*op( A )*B. -*> -*> SIDE = 'R' or 'r' B := alpha*B*op( A ). -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the matrix A is an upper or -*> lower triangular matrix as follows: -*> -*> UPLO = 'U' or 'u' A is an upper triangular matrix. -*> -*> UPLO = 'L' or 'l' A is a lower triangular matrix. -*> \endverbatim -*> -*> \param[in] TRANSA -*> \verbatim -*> TRANSA is CHARACTER*1 -*> On entry, TRANSA specifies the form of op( A ) to be used in -*> the matrix multiplication as follows: -*> -*> TRANSA = 'N' or 'n' op( A ) = A. -*> -*> TRANSA = 'T' or 't' op( A ) = A**T. -*> -*> TRANSA = 'C' or 'c' op( A ) = A**H. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> On entry, DIAG specifies whether or not A is unit triangular -*> as follows: -*> -*> DIAG = 'U' or 'u' A is assumed to be unit triangular. -*> -*> DIAG = 'N' or 'n' A is not assumed to be unit -*> triangular. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of B. M must be at -*> least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of B. N must be -*> at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is COMPLEX*16 -*> On entry, ALPHA specifies the scalar alpha. When alpha is -*> zero then A is not referenced and B need not be set before -*> entry. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*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 -*> triangular matrix and the strictly lower triangular part of -*> A is not referenced. -*> Before entry with UPLO = 'L' or 'l', the leading k by k -*> lower triangular part of the array A must contain the lower -*> triangular matrix and the strictly upper triangular part of -*> A is not referenced. -*> Note that when DIAG = 'U' or 'u', the diagonal elements of -*> A are not referenced either, but are assumed to be unity. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. When SIDE = 'L' or 'l' then -*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -*> then LDA must be at least max( 1, n ). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is COMPLEX*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. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> On entry, LDB specifies the first dimension of B as declared -*> in the calling (sub) program. LDB must be at least -*> max( 1, m ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level3 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 3 Blas routine. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* -* -- Reference BLAS level3 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - INTEGER LDA,LDB,M,N - CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. - COMPLEX*16 A(LDA,*),B(LDB,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG,MAX -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I,INFO,J,K,NROWA - LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER -* .. -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER (ONE= (1.0D+0,0.0D+0)) - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* -* Test the input parameters. -* - LSIDE = LSAME(SIDE,'L') - IF (LSIDE) THEN - NROWA = M - ELSE - NROWA = N - END IF - NOCONJ = LSAME(TRANSA,'T') - NOUNIT = LSAME(DIAG,'N') - UPPER = LSAME(UPLO,'U') -* - INFO = 0 - IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN - INFO = 1 - ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 2 - ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. - + (.NOT.LSAME(TRANSA,'T')) .AND. - + (.NOT.LSAME(TRANSA,'C'))) THEN - INFO = 3 - ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN - INFO = 4 - ELSE IF (M.LT.0) THEN - INFO = 5 - ELSE IF (N.LT.0) THEN - INFO = 6 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 9 - ELSE IF (LDB.LT.MAX(1,M)) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZTRMM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (M.EQ.0 .OR. N.EQ.0) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - B(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF (LSIDE) THEN - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*A*B. -* - IF (UPPER) THEN - DO 50 J = 1,N - DO 40 K = 1,M - IF (B(K,J).NE.ZERO) THEN - TEMP = ALPHA*B(K,J) - DO 30 I = 1,K - 1 - B(I,J) = B(I,J) + TEMP*A(I,K) - 30 CONTINUE - IF (NOUNIT) TEMP = TEMP*A(K,K) - B(K,J) = TEMP - END IF - 40 CONTINUE - 50 CONTINUE - ELSE - DO 80 J = 1,N - DO 70 K = M,1,-1 - IF (B(K,J).NE.ZERO) THEN - TEMP = ALPHA*B(K,J) - B(K,J) = TEMP - IF (NOUNIT) B(K,J) = B(K,J)*A(K,K) - DO 60 I = K + 1,M - B(I,J) = B(I,J) + TEMP*A(I,K) - 60 CONTINUE - END IF - 70 CONTINUE - 80 CONTINUE - END IF - ELSE -* -* Form B := alpha*A**T*B or B := alpha*A**H*B. -* - IF (UPPER) THEN - DO 120 J = 1,N - DO 110 I = M,1,-1 - TEMP = B(I,J) - IF (NOCONJ) THEN - IF (NOUNIT) TEMP = TEMP*A(I,I) - DO 90 K = 1,I - 1 - TEMP = TEMP + A(K,I)*B(K,J) - 90 CONTINUE - ELSE - IF (NOUNIT) TEMP = TEMP*DCONJG(A(I,I)) - DO 100 K = 1,I - 1 - TEMP = TEMP + DCONJG(A(K,I))*B(K,J) - 100 CONTINUE - END IF - B(I,J) = ALPHA*TEMP - 110 CONTINUE - 120 CONTINUE - ELSE - DO 160 J = 1,N - DO 150 I = 1,M - TEMP = B(I,J) - IF (NOCONJ) THEN - IF (NOUNIT) TEMP = TEMP*A(I,I) - DO 130 K = I + 1,M - TEMP = TEMP + A(K,I)*B(K,J) - 130 CONTINUE - ELSE - IF (NOUNIT) TEMP = TEMP*DCONJG(A(I,I)) - DO 140 K = I + 1,M - TEMP = TEMP + DCONJG(A(K,I))*B(K,J) - 140 CONTINUE - END IF - B(I,J) = ALPHA*TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*B*A. -* - IF (UPPER) THEN - DO 200 J = N,1,-1 - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 170 I = 1,M - B(I,J) = TEMP*B(I,J) - 170 CONTINUE - DO 190 K = 1,J - 1 - IF (A(K,J).NE.ZERO) THEN - TEMP = ALPHA*A(K,J) - DO 180 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 180 CONTINUE - END IF - 190 CONTINUE - 200 CONTINUE - ELSE - DO 240 J = 1,N - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 210 I = 1,M - B(I,J) = TEMP*B(I,J) - 210 CONTINUE - DO 230 K = J + 1,N - IF (A(K,J).NE.ZERO) THEN - TEMP = ALPHA*A(K,J) - DO 220 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 220 CONTINUE - END IF - 230 CONTINUE - 240 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*A**T or B := alpha*B*A**H. -* - IF (UPPER) THEN - DO 280 K = 1,N - DO 260 J = 1,K - 1 - IF (A(J,K).NE.ZERO) THEN - IF (NOCONJ) THEN - TEMP = ALPHA*A(J,K) - ELSE - TEMP = ALPHA*DCONJG(A(J,K)) - END IF - DO 250 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 250 CONTINUE - END IF - 260 CONTINUE - TEMP = ALPHA - IF (NOUNIT) THEN - IF (NOCONJ) THEN - TEMP = TEMP*A(K,K) - ELSE - TEMP = TEMP*DCONJG(A(K,K)) - END IF - END IF - IF (TEMP.NE.ONE) THEN - DO 270 I = 1,M - B(I,K) = TEMP*B(I,K) - 270 CONTINUE - END IF - 280 CONTINUE - ELSE - DO 320 K = N,1,-1 - DO 300 J = K + 1,N - IF (A(J,K).NE.ZERO) THEN - IF (NOCONJ) THEN - TEMP = ALPHA*A(J,K) - ELSE - TEMP = ALPHA*DCONJG(A(J,K)) - END IF - DO 290 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 290 CONTINUE - END IF - 300 CONTINUE - TEMP = ALPHA - IF (NOUNIT) THEN - IF (NOCONJ) THEN - TEMP = TEMP*A(K,K) - ELSE - TEMP = TEMP*DCONJG(A(K,K)) - END IF - END IF - IF (TEMP.NE.ONE) THEN - DO 310 I = 1,M - B(I,K) = TEMP*B(I,K) - 310 CONTINUE - END IF - 320 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTRMM -* - END diff --git a/lib/linalg/fortran/ztrmv.f b/lib/linalg/fortran/ztrmv.f deleted file mode 100644 index e8314facb7..0000000000 --- a/lib/linalg/fortran/ztrmv.f +++ /dev/null @@ -1,370 +0,0 @@ -*> \brief \b ZTRMV -* -* =========== DOCUMENTATION =========== -* -* 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 -* .. -* .. Array Arguments .. -* COMPLEX*16 A(LDA,*),X(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZTRMV performs one of the matrix-vector operations -*> -*> x := A*x, or x := A**T*x, or x := A**H*x, -*> -*> where x is an n element vector and A is an n by n unit, or non-unit, -*> upper or lower triangular matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the matrix is an upper or -*> lower triangular matrix as follows: -*> -*> UPLO = 'U' or 'u' A is an upper triangular matrix. -*> -*> UPLO = 'L' or 'l' A is a lower triangular matrix. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the operation to be performed as -*> follows: -*> -*> TRANS = 'N' or 'n' x := A*x. -*> -*> TRANS = 'T' or 't' x := A**T*x. -*> -*> TRANS = 'C' or 'c' x := A**H*x. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> On entry, DIAG specifies whether or not A is unit -*> triangular as follows: -*> -*> DIAG = 'U' or 'u' A is assumed to be unit triangular. -*> -*> DIAG = 'N' or 'n' A is not assumed to be unit -*> triangular. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*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 -*> A is not referenced. -*> Before entry with UPLO = 'L' or 'l', the leading n by n -*> lower triangular part of the array A must contain the lower -*> triangular matrix and the strictly upper triangular part of -*> A is not referenced. -*> Note that when DIAG = 'U' or 'u', the diagonal elements of -*> A are not referenced either, but are assumed to be unity. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, n ). -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is COMPLEX*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 -*> transformed vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> The vector and matrix arguments are not referenced when N = 0, or M = 0 -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,LDA,N - CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. - COMPLEX*16 A(LDA,*),X(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I,INFO,IX,J,JX,KX - LOGICAL NOCONJ,NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG,MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 2 - ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (LDA.LT.MAX(1,N)) THEN - INFO = 6 - ELSE IF (INCX.EQ.0) THEN - INFO = 8 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZTRMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOCONJ = LSAME(TRANS,'T') - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x := A*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 20 J = 1,N - IF (X(J).NE.ZERO) THEN - TEMP = X(J) - DO 10 I = 1,J - 1 - X(I) = X(I) + TEMP*A(I,J) - 10 CONTINUE - IF (NOUNIT) X(J) = X(J)*A(J,J) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = X(JX) - IX = KX - DO 30 I = 1,J - 1 - X(IX) = X(IX) + TEMP*A(I,J) - IX = IX + INCX - 30 CONTINUE - IF (NOUNIT) X(JX) = X(JX)*A(J,J) - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 60 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - TEMP = X(J) - DO 50 I = N,J + 1,-1 - X(I) = X(I) + TEMP*A(I,J) - 50 CONTINUE - IF (NOUNIT) X(J) = X(J)*A(J,J) - END IF - 60 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 80 J = N,1,-1 - IF (X(JX).NE.ZERO) THEN - TEMP = X(JX) - IX = KX - DO 70 I = N,J + 1,-1 - X(IX) = X(IX) + TEMP*A(I,J) - IX = IX - INCX - 70 CONTINUE - IF (NOUNIT) X(JX) = X(JX)*A(J,J) - END IF - JX = JX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A**T*x or x := A**H*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 110 J = N,1,-1 - TEMP = X(J) - IF (NOCONJ) THEN - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 90 I = J - 1,1,-1 - TEMP = TEMP + A(I,J)*X(I) - 90 CONTINUE - ELSE - IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) - DO 100 I = J - 1,1,-1 - TEMP = TEMP + DCONJG(A(I,J))*X(I) - 100 CONTINUE - END IF - X(J) = TEMP - 110 CONTINUE - ELSE - JX = KX + (N-1)*INCX - DO 140 J = N,1,-1 - TEMP = X(JX) - IX = JX - IF (NOCONJ) THEN - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 120 I = J - 1,1,-1 - IX = IX - INCX - TEMP = TEMP + A(I,J)*X(IX) - 120 CONTINUE - ELSE - IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) - DO 130 I = J - 1,1,-1 - IX = IX - INCX - TEMP = TEMP + DCONJG(A(I,J))*X(IX) - 130 CONTINUE - END IF - X(JX) = TEMP - JX = JX - INCX - 140 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 170 J = 1,N - TEMP = X(J) - IF (NOCONJ) THEN - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 150 I = J + 1,N - TEMP = TEMP + A(I,J)*X(I) - 150 CONTINUE - ELSE - IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) - DO 160 I = J + 1,N - TEMP = TEMP + DCONJG(A(I,J))*X(I) - 160 CONTINUE - END IF - X(J) = TEMP - 170 CONTINUE - ELSE - JX = KX - DO 200 J = 1,N - TEMP = X(JX) - IX = JX - IF (NOCONJ) THEN - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 180 I = J + 1,N - IX = IX + INCX - TEMP = TEMP + A(I,J)*X(IX) - 180 CONTINUE - ELSE - IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) - DO 190 I = J + 1,N - IX = IX + INCX - TEMP = TEMP + DCONJG(A(I,J))*X(IX) - 190 CONTINUE - END IF - X(JX) = TEMP - JX = JX + INCX - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTRMV -* - END diff --git a/lib/linalg/fortran/zung2l.f b/lib/linalg/fortran/zung2l.f deleted file mode 100644 index add5cb946b..0000000000 --- a/lib/linalg/fortran/zung2l.f +++ /dev/null @@ -1,196 +0,0 @@ -*> \brief \b ZUNG2L generates all or part of the unitary matrix Q from a QL factorization determined by cgeqlf (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNG2L + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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: -* ============= -*> -*> \verbatim -*> -*> ZUNG2L generates an m by n complex matrix Q with orthonormal columns, -*> which is defined as the last n columns of a product of k elementary -*> reflectors of order m -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by ZGEQLF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. M >= N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. N >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> On entry, the (n-k+i)-th column must contain the vector which -*> defines the elementary reflector H(i), for i = 1,2,...,k, as -*> returned by ZGEQLF in the last k columns of its array -*> argument A. -*> On exit, the m-by-n matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZGEQLF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (N) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, II, J, L -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARF, ZSCAL -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNG2L', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* -* Initialise columns 1:n-k to columns of the unit matrix -* - DO 20 J = 1, N - K - DO 10 L = 1, M - A( L, J ) = ZERO - 10 CONTINUE - A( M-N+J, J ) = ONE - 20 CONTINUE -* - DO 40 I = 1, K - II = N - K + I -* -* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left -* - A( M-N+II, II ) = ONE - CALL ZLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, - $ LDA, WORK ) - CALL ZSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) - A( M-N+II, II ) = ONE - TAU( I ) -* -* Set A(m-k+i+1:m,n-k+i) to zero -* - DO 30 L = M - N + II + 1, M - A( L, II ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of ZUNG2L -* - END diff --git a/lib/linalg/fortran/zung2r.f b/lib/linalg/fortran/zung2r.f deleted file mode 100644 index 2823b7ebdd..0000000000 --- a/lib/linalg/fortran/zung2r.f +++ /dev/null @@ -1,198 +0,0 @@ -*> \brief \b ZUNG2R -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNG2R + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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: -* ============= -*> -*> \verbatim -*> -*> ZUNG2R generates an m by n complex matrix Q with orthonormal columns, -*> which is defined as the first n columns of a product of k elementary -*> reflectors of order m -*> -*> Q = H(1) H(2) . . . H(k) -*> -*> as returned by ZGEQRF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. M >= N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. N >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> On entry, the i-th column must contain the vector which -*> defines the elementary reflector H(i), for i = 1,2,...,k, as -*> returned by ZGEQRF in the first k columns of its array -*> argument A. -*> On exit, the m by n matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZGEQRF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (N) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, J, L -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARF, ZSCAL -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNG2R', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* -* Initialise columns k+1:n to columns of the unit matrix -* - DO 20 J = K + 1, N - DO 10 L = 1, M - A( L, J ) = ZERO - 10 CONTINUE - A( J, J ) = ONE - 20 CONTINUE -* - DO 40 I = K, 1, -1 -* -* Apply H(i) to A(i:m,i:n) from the left -* - IF( I.LT.N ) THEN - A( I, I ) = ONE - CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - END IF - IF( I.LT.M ) - $ CALL ZSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) - A( I, I ) = ONE - TAU( I ) -* -* Set A(1:i-1,i) to zero -* - DO 30 L = 1, I - 1 - A( L, I ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of ZUNG2R -* - END diff --git a/lib/linalg/fortran/zungl2.f b/lib/linalg/fortran/zungl2.f deleted file mode 100644 index e7a0b59603..0000000000 --- a/lib/linalg/fortran/zungl2.f +++ /dev/null @@ -1,204 +0,0 @@ -*> \brief \b ZUNGL2 generates all or part of the unitary matrix Q from an LQ factorization determined by cgelqf (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNGL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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: -* ============= -*> -*> \verbatim -*> -*> ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows, -*> which is defined as the first m rows of a product of k elementary -*> reflectors of order n -*> -*> Q = H(k)**H . . . H(2)**H H(1)**H -*> -*> as returned by ZGELQF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. N >= M. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. M >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> On entry, the i-th row must contain the vector which defines -*> the elementary reflector H(i), for i = 1,2,...,k, as returned -*> by ZGELQF in the first k rows of its array argument A. -*> On exit, the m by n matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZGELQF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (M) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, J, L -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLACGV, ZLARF, ZSCAL -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.M ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNGL2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 ) - $ RETURN -* - IF( K.LT.M ) THEN -* -* Initialise rows k+1:m to rows of the unit matrix -* - DO 20 J = 1, N - DO 10 L = K + 1, M - A( L, J ) = ZERO - 10 CONTINUE - IF( J.GT.K .AND. J.LE.M ) - $ A( J, J ) = ONE - 20 CONTINUE - END IF -* - DO 40 I = K, 1, -1 -* -* Apply H(i)**H to A(i:m,i:n) from the right -* - IF( I.LT.N ) THEN - CALL ZLACGV( N-I, A( I, I+1 ), LDA ) - IF( I.LT.M ) THEN - A( I, I ) = ONE - CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ DCONJG( TAU( I ) ), A( I+1, I ), LDA, WORK ) - END IF - CALL ZSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) - CALL ZLACGV( N-I, A( I, I+1 ), LDA ) - END IF - A( I, I ) = ONE - DCONJG( TAU( I ) ) -* -* Set A(i,1:i-1) to zero -* - DO 30 L = 1, I - 1 - A( I, L ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of ZUNGL2 -* - END diff --git a/lib/linalg/fortran/zungql.f b/lib/linalg/fortran/zungql.f deleted file mode 100644 index 1804ca65ff..0000000000 --- a/lib/linalg/fortran/zungql.f +++ /dev/null @@ -1,293 +0,0 @@ -*> \brief \b ZUNGQL -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNGQL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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: -* ============= -*> -*> \verbatim -*> -*> ZUNGQL generates an M-by-N complex matrix Q with orthonormal columns, -*> which is defined as the last N columns of a product of K elementary -*> reflectors of order M -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by ZGEQLF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. M >= N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. N >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> On entry, the (n-k+i)-th column must contain the vector which -*> defines the elementary reflector H(i), for i = 1,2,...,k, as -*> returned by ZGEQLF in the last k columns of its array -*> argument A. -*> On exit, the M-by-N matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZGEQLF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 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 >= max(1,N). -*> For optimum performance LWORK >= N*NB, where NB is the -*> optimal blocksize. -*> -*> 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 has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT, - $ NB, NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2L -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( N.EQ.0 ) THEN - LWKOPT = 1 - ELSE - NB = ILAENV( 1, 'ZUNGQL', ' ', M, N, K, -1 ) - LWKOPT = N*NB - END IF - WORK( 1 ) = LWKOPT -* - IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNGQL', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) THEN - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'ZUNGQL', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQL', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the first block. -* The last kk columns are handled by the block method. -* - KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) -* -* Set A(m-kk+1:m,1:n-kk) to zero. -* - DO 20 J = 1, N - KK - DO 10 I = M - KK + 1, M - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the first or only block. -* - CALL ZUNG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = K - KK + 1, K, NB - IB = MIN( NB, K-I+1 ) - IF( N-K+I.GT.1 ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i+ib-1) . . . H(i+1) H(i) -* - CALL ZLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, - $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left -* - CALL ZLARFB( 'Left', 'No transpose', 'Backward', - $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB, - $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, - $ WORK( IB+1 ), LDWORK ) - END IF -* -* Apply H to rows 1:m-k+i+ib-1 of current block -* - CALL ZUNG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA, - $ TAU( I ), WORK, IINFO ) -* -* Set rows m-k+i+ib:m of current block to zero -* - DO 40 J = N - K + I, N - K + I + IB - 1 - DO 30 L = M - K + I + IB, M - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of ZUNGQL -* - END diff --git a/lib/linalg/fortran/zungqr.f b/lib/linalg/fortran/zungqr.f deleted file mode 100644 index b3f2c4507f..0000000000 --- a/lib/linalg/fortran/zungqr.f +++ /dev/null @@ -1,287 +0,0 @@ -*> \brief \b ZUNGQR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNGQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \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: -* ============= -*> -*> \verbatim -*> -*> ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns, -*> which is defined as the first N columns of a product of K elementary -*> reflectors of order M -*> -*> Q = H(1) H(2) . . . H(k) -*> -*> as returned by ZGEQRF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. M >= N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. N >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> On entry, the i-th column must contain the vector which -*> defines the elementary reflector H(i), for i = 1,2,...,k, as -*> returned by ZGEQRF in the first k columns of its array -*> argument A. -*> On exit, the M-by-N matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZGEQRF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 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 >= max(1,N). -*> For optimum performance LWORK >= N*NB, where NB is the -*> optimal blocksize. -*> -*> 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 has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, - $ LWKOPT, NB, NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2R -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 ) - LWKOPT = MAX( 1, N )*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNGQR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'ZUNGQR', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQR', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the last block. -* The first kk columns are handled by the block method. -* - KI = ( ( K-NX-1 ) / NB )*NB - KK = MIN( K, KI+NB ) -* -* Set A(1:kk,kk+1:n) to zero. -* - DO 20 J = KK + 1, N - DO 10 I = 1, KK - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the last or only block. -* - IF( KK.LT.N ) - $ CALL ZUNG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, - $ TAU( KK+1 ), WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF( I+IB.LE.N ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(i:m,i+ib:n) from the left -* - CALL ZLARFB( 'Left', 'No transpose', 'Forward', - $ 'Columnwise', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), - $ LDA, WORK( IB+1 ), LDWORK ) - END IF -* -* Apply H to rows i:m of current block -* - CALL ZUNG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* -* Set rows 1:i-1 of current block to zero -* - DO 40 J = I, I + IB - 1 - DO 30 L = 1, I - 1 - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of ZUNGQR -* - END diff --git a/lib/linalg/fortran/zungtr.f b/lib/linalg/fortran/zungtr.f deleted file mode 100644 index 01e100a8cd..0000000000 --- a/lib/linalg/fortran/zungtr.f +++ /dev/null @@ -1,253 +0,0 @@ -*> \brief \b ZUNGTR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNGTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZUNGTR generates a complex unitary matrix Q which is defined as the -*> product of n-1 elementary reflectors of order N, as returned by -*> ZHETRD: -*> -*> if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), -*> -*> if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A contains elementary reflectors -*> from ZHETRD; -*> = 'L': Lower triangle of A contains elementary reflectors -*> from ZHETRD. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix Q. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> On entry, the vectors which define the elementary reflectors, -*> as returned by ZHETRD. -*> On exit, the N-by-N unitary matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= N. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (N-1) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZHETRD. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 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 >= N-1. -*> For optimum performance LWORK >= (N-1)*NB, where NB is -*> the optimal blocksize. -*> -*> 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 -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), - $ ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, UPPER - INTEGER I, IINFO, J, LWKOPT, NB -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZUNGQL, ZUNGQR -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN - INFO = -7 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( UPPER ) THEN - NB = ILAENV( 1, 'ZUNGQL', ' ', N-1, N-1, N-1, -1 ) - ELSE - NB = ILAENV( 1, 'ZUNGQR', ' ', N-1, N-1, N-1, -1 ) - END IF - LWKOPT = MAX( 1, N-1 )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNGTR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( UPPER ) THEN -* -* Q was determined by a call to ZHETRD with UPLO = 'U' -* -* Shift the vectors which define the elementary reflectors one -* column to the left, and set the last row and column of Q to -* those of the unit matrix -* - DO 20 J = 1, N - 1 - DO 10 I = 1, J - 1 - A( I, J ) = A( I, J+1 ) - 10 CONTINUE - A( N, J ) = ZERO - 20 CONTINUE - DO 30 I = 1, N - 1 - A( I, N ) = ZERO - 30 CONTINUE - A( N, N ) = ONE -* -* Generate Q(1:n-1,1:n-1) -* - CALL ZUNGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO ) -* - ELSE -* -* Q was determined by a call to ZHETRD with UPLO = 'L'. -* -* Shift the vectors which define the elementary reflectors one -* column to the right, and set the first row and column of Q to -* those of the unit matrix -* - DO 50 J = N, 2, -1 - A( 1, J ) = ZERO - DO 40 I = J + 1, N - A( I, J ) = A( I, J-1 ) - 40 CONTINUE - 50 CONTINUE - A( 1, 1 ) = ONE - DO 60 I = 2, N - A( I, 1 ) = ZERO - 60 CONTINUE - IF( N.GT.1 ) THEN -* -* Generate Q(2:n,2:n) -* - CALL ZUNGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, - $ LWORK, IINFO ) - END IF - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of ZUNGTR -* - END diff --git a/lib/linalg/fortran/zunm2l.f b/lib/linalg/fortran/zunm2l.f deleted file mode 100644 index 48c2dbfc0c..0000000000 --- a/lib/linalg/fortran/zunm2l.f +++ /dev/null @@ -1,278 +0,0 @@ -*> \brief \b ZUNM2L multiplies a general matrix by the unitary matrix from a QL factorization determined by cgeqlf (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNM2L + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, -* WORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE, TRANS -* INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZUNM2L overwrites the general complex m-by-n matrix C with -*> -*> Q * C if SIDE = 'L' and TRANS = 'N', or -*> -*> Q**H* C if SIDE = 'L' and TRANS = 'C', or -*> -*> C * Q if SIDE = 'R' and TRANS = 'N', or -*> -*> C * Q**H if SIDE = 'R' and TRANS = 'C', -*> -*> where Q is a complex unitary matrix defined as the product of k -*> elementary reflectors -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by ZGEQLF. Q is of order m if SIDE = 'L' and of order n -*> if SIDE = 'R'. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**H from the Left -*> = 'R': apply Q or Q**H from the Right -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': apply Q (No transpose) -*> = 'C': apply Q**H (Conjugate transpose) -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines -*> the matrix Q. -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,K) -*> The i-th column must contain the vector which defines the -*> elementary reflector H(i), for i = 1,2,...,k, as returned by -*> ZGEQLF in the last k columns of its array argument A. -*> A is modified by the routine but restored on exit. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> If SIDE = 'L', LDA >= max(1,M); -*> if SIDE = 'R', LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZGEQLF. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is COMPLEX*16 array, dimension (LDC,N) -*> On entry, the m-by-n matrix C. -*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension -*> (N) if SIDE = 'L', -*> (M) if SIDE = 'R' -*> \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. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, MI, NI, NQ - COMPLEX*16 AII, TAUI -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARF -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNM2L', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. NOTRAN .OR. .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - ELSE - MI = M - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) or H(i)**H is applied to C(1:m-k+i,1:n) -* - MI = M - K + I - ELSE -* -* H(i) or H(i)**H is applied to C(1:m,1:n-k+i) -* - NI = N - K + I - END IF -* -* Apply H(i) or H(i)**H -* - IF( NOTRAN ) THEN - TAUI = TAU( I ) - ELSE - TAUI = DCONJG( TAU( I ) ) - END IF - AII = A( NQ-K+I, I ) - A( NQ-K+I, I ) = ONE - CALL ZLARF( SIDE, MI, NI, A( 1, I ), 1, TAUI, C, LDC, WORK ) - A( NQ-K+I, I ) = AII - 10 CONTINUE - RETURN -* -* End of ZUNM2L -* - END diff --git a/lib/linalg/fortran/zunm2r.f b/lib/linalg/fortran/zunm2r.f deleted file mode 100644 index aec5a8bcae..0000000000 --- a/lib/linalg/fortran/zunm2r.f +++ /dev/null @@ -1,283 +0,0 @@ -*> \brief \b ZUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNM2R + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, -* WORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE, TRANS -* INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZUNM2R overwrites the general complex m-by-n matrix C with -*> -*> Q * C if SIDE = 'L' and TRANS = 'N', or -*> -*> Q**H* C if SIDE = 'L' and TRANS = 'C', or -*> -*> C * Q if SIDE = 'R' and TRANS = 'N', or -*> -*> C * Q**H if SIDE = 'R' and TRANS = 'C', -*> -*> where Q is a complex unitary matrix defined as the product of k -*> elementary reflectors -*> -*> Q = H(1) H(2) . . . H(k) -*> -*> as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n -*> if SIDE = 'R'. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**H from the Left -*> = 'R': apply Q or Q**H from the Right -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': apply Q (No transpose) -*> = 'C': apply Q**H (Conjugate transpose) -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines -*> the matrix Q. -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,K) -*> The i-th column must contain the vector which defines the -*> elementary reflector H(i), for i = 1,2,...,k, as returned by -*> ZGEQRF in the first k columns of its array argument A. -*> A is modified by the routine but restored on exit. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> If SIDE = 'L', LDA >= max(1,M); -*> if SIDE = 'R', LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZGEQRF. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is COMPLEX*16 array, dimension (LDC,N) -*> On entry, the m-by-n matrix C. -*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension -*> (N) if SIDE = 'L', -*> (M) if SIDE = 'R' -*> \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. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - COMPLEX*16 AII, TAUI -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARF -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNM2R', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) or H(i)**H is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H(i) or H(i)**H is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H(i) or H(i)**H -* - IF( NOTRAN ) THEN - TAUI = TAU( I ) - ELSE - TAUI = DCONJG( TAU( I ) ) - END IF - AII = A( I, I ) - A( I, I ) = ONE - CALL ZLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC, - $ WORK ) - A( I, I ) = AII - 10 CONTINUE - RETURN -* -* End of ZUNM2R -* - END diff --git a/lib/linalg/fortran/zunmql.f b/lib/linalg/fortran/zunmql.f deleted file mode 100644 index 06353a0c75..0000000000 --- a/lib/linalg/fortran/zunmql.f +++ /dev/null @@ -1,336 +0,0 @@ -*> \brief \b ZUNMQL -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNMQL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZUNMQL( 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 -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZUNMQL overwrites the general complex M-by-N matrix C with -*> -*> SIDE = 'L' SIDE = 'R' -*> TRANS = 'N': Q * C C * Q -*> TRANS = 'C': Q**H * C C * Q**H -*> -*> where Q is a complex unitary matrix defined as the product of k -*> elementary reflectors -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by ZGEQLF. Q is of order M if SIDE = 'L' and of order N -*> if SIDE = 'R'. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**H from the Left; -*> = 'R': apply Q or Q**H from the Right. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': No transpose, apply Q; -*> = 'C': Conjugate transpose, apply Q**H. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines -*> the matrix Q. -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,K) -*> The i-th column must contain the vector which defines the -*> elementary reflector H(i), for i = 1,2,...,k, as returned by -*> ZGEQLF in the last k columns of its array argument A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> If SIDE = 'L', LDA >= max(1,M); -*> if SIDE = 'R', LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZGEQLF. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is COMPLEX*16 array, dimension (LDC,N) -*> On entry, the M-by-N matrix C. -*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (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. -*> If SIDE = 'L', LWORK >= max(1,N); -*> if SIDE = 'R', LWORK >= max(1,M). -*> 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 -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - 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, IWT, LDWORK, LWKOPT, - $ MI, NB, NBMIN, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNM2L -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = MAX( 1, N ) - ELSE - NQ = N - NW = MAX( 1, M ) - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - 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 - NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M, N, - $ K, -1 ) ) - LWKOPT = NW*NB + TSIZE - END IF - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNMQL', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - RETURN - END IF -* - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IF( LWORK.LT.LWKOPT ) THEN - NB = (LWORK-TSIZE) / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQL', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IWT = 1 + NW*NB - IF( ( LEFT .AND. NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - ELSE - MI = M - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i+ib-1) . . . H(i+1) H(i) -* - CALL ZLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB, - $ A( 1, I ), LDA, TAU( I ), WORK( IWT ), LDT ) - IF( LEFT ) THEN -* -* H or H**H is applied to C(1:m-k+i+ib-1,1:n) -* - MI = M - K + I + IB - 1 - ELSE -* -* H or H**H is applied to C(1:m,1:n-k+i+ib-1) -* - NI = N - K + I + IB - 1 - END IF -* -* Apply H or H**H -* - CALL ZLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI, - $ IB, A( 1, I ), LDA, WORK( IWT ), LDT, C, LDC, - $ WORK, LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of ZUNMQL -* - END diff --git a/lib/linalg/fortran/zunmqr.f b/lib/linalg/fortran/zunmqr.f deleted file mode 100644 index 2ae205f4fd..0000000000 --- a/lib/linalg/fortran/zunmqr.f +++ /dev/null @@ -1,337 +0,0 @@ -*> \brief \b ZUNMQR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNMQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZUNMQR( 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 -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZUNMQR overwrites the general complex M-by-N matrix C with -*> -*> SIDE = 'L' SIDE = 'R' -*> TRANS = 'N': Q * C C * Q -*> TRANS = 'C': Q**H * C C * Q**H -*> -*> where Q is a complex unitary matrix defined as the product of k -*> elementary reflectors -*> -*> Q = H(1) H(2) . . . H(k) -*> -*> as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N -*> if SIDE = 'R'. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**H from the Left; -*> = 'R': apply Q or Q**H from the Right. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': No transpose, apply Q; -*> = 'C': Conjugate transpose, apply Q**H. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines -*> the matrix Q. -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,K) -*> The i-th column must contain the vector which defines the -*> elementary reflector H(i), for i = 1,2,...,k, as returned by -*> ZGEQRF in the first k columns of its array argument A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> If SIDE = 'L', LDA >= max(1,M); -*> if SIDE = 'R', LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZGEQRF. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is COMPLEX*16 array, dimension (LDC,N) -*> On entry, the M-by-N matrix C. -*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (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. -*> If SIDE = 'L', LWORK >= max(1,N); -*> if SIDE = 'R', LWORK >= max(1,M). -*> 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 -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - 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, IWT, JC, LDWORK, - $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNM2R -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = MAX( 1, N ) - ELSE - NQ = N - NW = MAX( 1, M ) - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - 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 -* - NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - LWKOPT = NW*NB + TSIZE - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNMQR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IF( LWORK.LT.LWKOPT ) THEN - NB = (LWORK-TSIZE) / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IWT = 1 + NW*NB - IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL ZLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), - $ LDA, TAU( I ), WORK( IWT ), LDT ) - IF( LEFT ) THEN -* -* H or H**H is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H or H**H is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H or H**H -* - CALL ZLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, - $ IB, A( I, I ), LDA, WORK( IWT ), LDT, - $ C( IC, JC ), LDC, WORK, LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of ZUNMQR -* - END diff --git a/lib/linalg/fortran/zunmtr.f b/lib/linalg/fortran/zunmtr.f deleted file mode 100644 index 441a7c2bcc..0000000000 --- a/lib/linalg/fortran/zunmtr.f +++ /dev/null @@ -1,307 +0,0 @@ -*> \brief \b ZUNMTR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNMTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZUNMTR( 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 -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZUNMTR overwrites the general complex M-by-N matrix C with -*> -*> SIDE = 'L' SIDE = 'R' -*> TRANS = 'N': Q * C C * Q -*> TRANS = 'C': Q**H * C C * Q**H -*> -*> where Q is a complex unitary matrix of order nq, with nq = m if -*> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of -*> nq-1 elementary reflectors, as returned by ZHETRD: -*> -*> if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); -*> -*> if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**H from the Left; -*> = 'R': apply Q or Q**H from the Right. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A contains elementary reflectors -*> from ZHETRD; -*> = 'L': Lower triangle of A contains elementary reflectors -*> from ZHETRD. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': No transpose, apply Q; -*> = 'C': Conjugate transpose, apply Q**H. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension -*> (LDA,M) if SIDE = 'L' -*> (LDA,N) if SIDE = 'R' -*> The vectors which define the elementary reflectors, as -*> returned by ZHETRD. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension -*> (M-1) if SIDE = 'L' -*> (N-1) if SIDE = 'R' -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZHETRD. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is COMPLEX*16 array, dimension (LDC,N) -*> On entry, the M-by-N matrix C. -*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (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. -*> 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. -*> -*> 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 -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS, UPLO - INTEGER INFO, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, UPPER - INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZUNMQL, ZUNMQR -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - UPPER = LSAME( UPLO, 'U' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = MAX( 1, N ) - ELSE - NQ = N - NW = MAX( 1, M ) - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) - $ THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - 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 - IF( UPPER ) THEN - IF( LEFT ) THEN - NB = ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M-1, N, M-1, - $ -1 ) - ELSE - NB = ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M, N-1, N-1, - $ -1 ) - END IF - ELSE - IF( LEFT ) THEN - NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M-1, N, M-1, - $ -1 ) - ELSE - NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1, - $ -1 ) - END IF - END IF - LWKOPT = NW*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNMTR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( LEFT ) THEN - MI = M - 1 - NI = N - ELSE - MI = M - NI = N - 1 - END IF -* - IF( UPPER ) THEN -* -* Q was determined by a call to ZHETRD with UPLO = 'U' -* - CALL ZUNMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C, - $ LDC, WORK, LWORK, IINFO ) - ELSE -* -* Q was determined by a call to ZHETRD with UPLO = 'L' -* - IF( LEFT ) THEN - I1 = 2 - I2 = 1 - ELSE - I1 = 1 - I2 = 2 - END IF - CALL ZUNMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, - $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of ZUNMTR -* - END diff --git a/lib/linalg/s_lmp_cmp.cpp b/lib/linalg/s_lmp_cmp.cpp index 73b011a799..51c47167e4 100644 --- a/lib/linalg/s_lmp_cmp.cpp +++ b/lib/linalg/s_lmp_cmp.cpp @@ -7,7 +7,7 @@ extern "C" { integer s_lmp_cmp(char *a0, char *b0, ftnlen la, ftnlen lb) { - register unsigned char *a, *aend, *b, *bend; + unsigned char *a, *aend, *b, *bend; a = (unsigned char *)a0; b = (unsigned char *)b0; aend = a + la; diff --git a/lib/linalg/s_lmp_copy.cpp b/lib/linalg/s_lmp_copy.cpp index 9b432e08ca..5e09459b1b 100644 --- a/lib/linalg/s_lmp_copy.cpp +++ b/lib/linalg/s_lmp_copy.cpp @@ -5,9 +5,9 @@ extern "C" { /* assign strings: a = b */ -void s_lmp_copy(register char *a, register char *b, ftnlen la, ftnlen lb) +void s_lmp_copy(char *a, char *b, ftnlen la, ftnlen lb) { - register char *aend, *bend; + char *aend, *bend; aend = a + la; diff --git a/lib/linalg/static/.clang-format b/lib/linalg/static/.clang-format deleted file mode 100644 index 8856e00947..0000000000 --- a/lib/linalg/static/.clang-format +++ /dev/null @@ -1,23 +0,0 @@ ---- -Language: Cpp -BasedOnStyle: LLVM -AccessModifierOffset: -4 -AlignConsecutiveAssignments: false -AlignEscapedNewlines: Left -AllowShortFunctionsOnASingleLine: Inline -AllowShortLambdasOnASingleLine: None -AllowShortIfStatementsOnASingleLine: WithoutElse -BraceWrapping: - AfterFunction: true -BreakBeforeBraces: Custom -BreakInheritanceList: AfterColon -BreakConstructorInitializers: AfterColon -ColumnLimit: 100 -IndentCaseLabels: true -IndentWidth: 4 -ObjCBlockIndentWidth: 4 -PenaltyBreakAssignment: 4 -Standard: Cpp11 -TabWidth: 4 -UseTab: Never -... diff --git a/lib/linalg/static/README b/lib/linalg/static/README deleted file mode 100644 index 2d0271db7c..0000000000 --- a/lib/linalg/static/README +++ /dev/null @@ -1,8 +0,0 @@ -The C++ files in this folder are either direct C++ implementations of -their Fortran equivalents using the C++ runtime, or they are adapted -copies of functions from the libf2c runtime. The runtime functions -needed to be renamed to avoid conflics with libgfortran which uses -some of the same function names. - -The Fortran files in this folder are modified from their -original versions, so that f2c can correctly translate them. diff --git a/lib/linalg/static/d_lmp_cnjg.cpp b/lib/linalg/static/d_lmp_cnjg.cpp deleted file mode 100644 index 03ca8f98fd..0000000000 --- a/lib/linalg/static/d_lmp_cnjg.cpp +++ /dev/null @@ -1,13 +0,0 @@ - -#include "lmp_f2c.h" - -extern "C" { - -void d_lmp_cnjg(doublecomplex *r, doublecomplex *z) -{ - doublereal zi = z->i; - - r->r = z->r; - r->i = -zi; -} -} diff --git a/lib/linalg/static/d_lmp_imag.cpp b/lib/linalg/static/d_lmp_imag.cpp deleted file mode 100644 index f0443f7828..0000000000 --- a/lib/linalg/static/d_lmp_imag.cpp +++ /dev/null @@ -1,10 +0,0 @@ - -#include "lmp_f2c.h" - -extern "C" { - -double d_lmp_imag(doublecomplex *z) -{ - return (z->i); -} -} diff --git a/lib/linalg/static/d_lmp_lg10.cpp b/lib/linalg/static/d_lmp_lg10.cpp deleted file mode 100644 index ec48c99839..0000000000 --- a/lib/linalg/static/d_lmp_lg10.cpp +++ /dev/null @@ -1,14 +0,0 @@ - -#include "lmp_f2c.h" -#undef abs - -static constexpr double log10e = 0.43429448190325182765; - -#include - -extern "C" { -double d_lmp_lg10(doublereal *x) -{ - return (log10e * log(*x)); -} -} diff --git a/lib/linalg/static/d_lmp_sign.cpp b/lib/linalg/static/d_lmp_sign.cpp deleted file mode 100644 index fb0a1e79ff..0000000000 --- a/lib/linalg/static/d_lmp_sign.cpp +++ /dev/null @@ -1,12 +0,0 @@ - -#include "lmp_f2c.h" - -extern "C" { - -double d_lmp_sign(doublereal *a, doublereal *b) -{ - double x; - x = (*a >= 0 ? *a : -*a); - return (*b >= 0 ? x : -x); -} -} diff --git a/lib/linalg/static/dgetrf2.f b/lib/linalg/static/dgetrf2.f deleted file mode 100644 index e3d2aac299..0000000000 --- a/lib/linalg/static/dgetrf2.f +++ /dev/null @@ -1,269 +0,0 @@ -*> \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. -* -*> \ingroup doubleGEcomputational -* -* ===================================================================== - SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. 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/static/disnan.cpp b/lib/linalg/static/disnan.cpp deleted file mode 100644 index dcdaad77e1..0000000000 --- a/lib/linalg/static/disnan.cpp +++ /dev/null @@ -1,14 +0,0 @@ - -#include - -extern "C" { - -#include "lmp_f2c.h" - -logical disnan_(const doublereal *din) -{ - if (!din) return TRUE_; - - return std::isnan(*din) ? TRUE_ : FALSE_; -} -} diff --git a/lib/linalg/static/dlamc3.f b/lib/linalg/static/dlamc3.f deleted file mode 100644 index 1108297707..0000000000 --- a/lib/linalg/static/dlamc3.f +++ /dev/null @@ -1,45 +0,0 @@ -*> \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.7.0) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2010 -* -* .. Scalar Arguments .. - DOUBLE PRECISION A, B -* .. -* ===================================================================== -* -* .. Executable Statements .. -* - DLAMC3 = A + B -* - RETURN -* -* End of DLAMC3 -* - END -* -************************************************************************ diff --git a/lib/linalg/static/dlamch.cpp b/lib/linalg/static/dlamch.cpp deleted file mode 100644 index 277096e6f3..0000000000 --- a/lib/linalg/static/dlamch.cpp +++ /dev/null @@ -1,45 +0,0 @@ - -#include -#include - -extern "C" { - -#include "lmp_f2c.h" - -// undefine conflicting f2c macros -#undef min -#undef max - -doublereal dlamch_(const char *cmach) -{ - if (!cmach) return 0.0; - char select = toupper(*cmach); - - // BLAS assumes rounding not truncation => epsilon is half - const double eps = 0.5 * std::numeric_limits::epsilon(); - if (select == 'E') return eps; - - double min = std::numeric_limits::min(); - const double max = std::numeric_limits::max(); - double small = 1.0 / max; - if (small >= min) min = small * (1.0 + eps); - if (select == 'S') return min; - - const double radix = std::numeric_limits::radix; - if (select == 'B') return radix; - - if (select == 'P') return eps * radix; - - if (select == 'N') return std::numeric_limits::digits; - - if (select == 'M') return std::numeric_limits::min_exponent; - - if (select == 'U') return min; - - if (select == 'L') return std::numeric_limits::max_exponent; - - if (select == 'O') return max; - - return 0.0; -} -} diff --git a/lib/linalg/static/dlarft.f b/lib/linalg/static/dlarft.f deleted file mode 100644 index e92c927971..0000000000 --- a/lib/linalg/static/dlarft.f +++ /dev/null @@ -1,327 +0,0 @@ -*> \brief \b DLARFT forms the triangular factor T of a block reflector H = I - vtvH -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLARFT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* -* .. Scalar Arguments .. -* CHARACTER DIRECT, STOREV -* INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLARFT forms the triangular factor T of a real block reflector H -*> of order n, which is defined as a product of k elementary reflectors. -*> -*> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; -*> -*> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. -*> -*> If STOREV = 'C', the vector which defines the elementary reflector -*> H(i) is stored in the i-th column of the array V, and -*> -*> H = I - V * T * V**T -*> -*> If STOREV = 'R', the vector which defines the elementary reflector -*> H(i) is stored in the i-th row of the array V, and -*> -*> H = I - V**T * T * V -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] DIRECT -*> \verbatim -*> DIRECT is CHARACTER*1 -*> Specifies the order in which the elementary reflectors are -*> multiplied to form the block reflector: -*> = 'F': H = H(1) H(2) . . . H(k) (Forward) -*> = 'B': H = H(k) . . . H(2) H(1) (Backward) -*> \endverbatim -*> -*> \param[in] STOREV -*> \verbatim -*> STOREV is CHARACTER*1 -*> Specifies how the vectors which define the elementary -*> reflectors are stored (see also Further Details): -*> = 'C': columnwise -*> = 'R': rowwise -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the block reflector H. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The order of the triangular factor T (= the number of -*> elementary reflectors). K >= 1. -*> \endverbatim -*> -*> \param[in] V -*> \verbatim -*> V is DOUBLE PRECISION array, dimension -*> (LDV,K) if STOREV = 'C' -*> (LDV,N) if STOREV = 'R' -*> The matrix V. See further details. -*> \endverbatim -*> -*> \param[in] LDV -*> \verbatim -*> LDV is INTEGER -*> The leading dimension of the array V. -*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i). -*> \endverbatim -*> -*> \param[out] T -*> \verbatim -*> T is DOUBLE PRECISION array, dimension (LDT,K) -*> The k by k triangular factor T of the block reflector. -*> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is -*> lower triangular. The rest of the array is not used. -*> \endverbatim -*> -*> \param[in] LDT -*> \verbatim -*> LDT is INTEGER -*> The leading dimension of the array T. LDT >= K. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The shape of the matrix V and the storage of the vectors which define -*> the H(i) is best illustrated by the following example with n = 5 and -*> k = 3. The elements equal to 1 are not stored. -*> -*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -*> -*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -*> ( v1 1 ) ( 1 v2 v2 v2 ) -*> ( v1 v2 1 ) ( 1 v3 v3 ) -*> ( v1 v2 v3 ) -*> ( v1 v2 v3 ) -*> -*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -*> -*> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -*> ( v1 v2 v3 ) ( v2 v2 v2 1 ) -*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -*> ( 1 v3 ) -*> ( 1 ) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, STOREV - INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, PREVLASTV, LASTV -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DTRMV -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( LSAME( DIRECT, 'F' ) ) THEN - PREVLASTV = N - DO I = 1, K - PREVLASTV = MAX( I, PREVLASTV ) - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = 1, I - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( LASTV, I ).NE.ZERO ) GOTO 219 - END DO - 219 CONTINUE - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * V( I , J ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) -* - CALL DGEMV( 'Transpose', J-I, I-1, -TAU( I ), - $ V( I+1, 1 ), LDV, V( I+1, I ), 1, ONE, - $ T( 1, I ), 1 ) - ELSE -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( I, LASTV ).NE.ZERO ) GOTO 235 - END DO - 235 CONTINUE - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * V( J , I ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T -* - CALL DGEMV( 'No transpose', I-1, J-I, -TAU( I ), - $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, ONE, - $ T( 1, I ), 1 ) - END IF -* -* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) -* - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, - $ LDT, T( 1, I ), 1 ) - T( I, I ) = TAU( I ) - IF( I.GT.1 ) THEN - PREVLASTV = MAX( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - END DO - ELSE - PREVLASTV = 1 - DO I = K, 1, -1 - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = I, K - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( I.LT.K ) THEN - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( LASTV, I ).NE.ZERO ) GOTO 280 - END DO - 280 CONTINUE - DO J = I+1, K - T( J, I ) = -TAU( I ) * V( N-K+I , J ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) -* - CALL DGEMV( 'Transpose', N-K+I-J, K-I, -TAU( I ), - $ V( J, I+1 ), LDV, V( J, I ), 1, ONE, - $ T( I+1, I ), 1 ) - ELSE -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( I, LASTV ).NE.ZERO ) GOTO 296 - END DO - 296 CONTINUE - DO J = I+1, K - T( J, I ) = -TAU( I ) * V( J, N-K+I ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T -* - CALL DGEMV( 'No transpose', K-I, N-K+I-J, - $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, - $ ONE, T( I+1, I ), 1 ) - END IF -* -* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) -* - CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, - $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) - IF( I.GT.1 ) THEN - PREVLASTV = MIN( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - T( I, I ) = TAU( I ) - END IF - END DO - END IF - RETURN -* -* End of DLARFT -* - END diff --git a/lib/linalg/static/dpotrf2.f b/lib/linalg/static/dpotrf2.f deleted file mode 100644 index ba827635a8..0000000000 --- a/lib/linalg/static/dpotrf2.f +++ /dev/null @@ -1,234 +0,0 @@ -*> \brief \b DPOTRF2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* RECURSIVE SUBROUTINE DPOTRF2( UPLO, N, A, LDA, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. -* REAL A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DPOTRF2 computes the Cholesky factorization of a real symmetric -*> positive definite matrix A using the recursive algorithm. -*> -*> The factorization has the form -*> A = U**T * U, if UPLO = 'U', or -*> A = L * L**T, if UPLO = 'L', -*> where U is an upper triangular matrix and L is lower triangular. -*> -*> 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 = n/2 -*> [ A21 | A22 ] n2 = n-n1 -*> -*> The subroutine calls itself to factor A11. Update and scale A21 -*> or A12, update A22 then calls itself to factor A22. -*> -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the leading -*> N-by-N upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading N-by-N lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> -*> On exit, if INFO = 0, the factor U or L from the Cholesky -*> factorization A = U**T*U or A = L*L**T. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,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 = i, the leading minor of order i is not -*> positive definite, and the factorization could not be -*> completed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doublePOcomputational -* -* ===================================================================== - SUBROUTINE DPOTRF2( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER N1, N2, IINFO -* .. -* .. External Functions .. - LOGICAL LSAME, DISNAN - EXTERNAL LSAME, DISNAN -* .. -* .. External Subroutines .. - EXTERNAL DSYRK, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTRF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* N=1 case -* - IF( N.EQ.1 ) THEN -* -* Test for non-positive-definiteness -* - IF( A( 1, 1 ).LE.ZERO.OR.DISNAN( A( 1, 1 ) ) ) THEN - INFO = 1 - RETURN - END IF -* -* Factor -* - A( 1, 1 ) = SQRT( A( 1, 1 ) ) -* -* Use recursive code -* - ELSE - N1 = N/2 - N2 = N-N1 -* -* Factor A11 -* - CALL DPOTRF2( UPLO, N1, A( 1, 1 ), LDA, IINFO ) - IF ( IINFO.NE.0 ) THEN - INFO = IINFO - RETURN - END IF -* -* Compute the Cholesky factorization A = U**T*U -* - IF( UPPER ) THEN -* -* Update and scale A12 -* - CALL DTRSM( 'L', 'U', 'T', 'N', N1, N2, ONE, - $ A( 1, 1 ), LDA, A( 1, N1+1 ), LDA ) -* -* Update and factor A22 -* - CALL DSYRK( UPLO, 'T', N2, N1, -ONE, A( 1, N1+1 ), LDA, - $ ONE, A( N1+1, N1+1 ), LDA ) - CALL DPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO ) - IF ( IINFO.NE.0 ) THEN - INFO = IINFO + N1 - RETURN - END IF -* -* Compute the Cholesky factorization A = L*L**T -* - ELSE -* -* Update and scale A21 -* - CALL DTRSM( 'R', 'L', 'T', 'N', N2, N1, ONE, - $ A( 1, 1 ), LDA, A( N1+1, 1 ), LDA ) -* -* Update and factor A22 -* - CALL DSYRK( UPLO, 'N', N2, N1, -ONE, A( N1+1, 1 ), LDA, - $ ONE, A( N1+1, N1+1 ), LDA ) - CALL DPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO ) - IF ( IINFO.NE.0 ) THEN - INFO = IINFO + N1 - RETURN - END IF - END IF - END IF - RETURN -* -* End of DPOTRF2 -* - END diff --git a/lib/linalg/static/i_lmp_dnnt.cpp b/lib/linalg/static/i_lmp_dnnt.cpp deleted file mode 100644 index 8050697bb9..0000000000 --- a/lib/linalg/static/i_lmp_dnnt.cpp +++ /dev/null @@ -1,12 +0,0 @@ - -#include "lmp_f2c.h" - -#undef abs -#include - -extern "C" { -integer i_lmp_dnnt(doublereal *x) -{ - return (integer)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x)); -} -} diff --git a/lib/linalg/static/i_lmp_len.cpp b/lib/linalg/static/i_lmp_len.cpp deleted file mode 100644 index b6101b29ad..0000000000 --- a/lib/linalg/static/i_lmp_len.cpp +++ /dev/null @@ -1,10 +0,0 @@ - -#include "lmp_f2c.h" - -extern "C" { - -integer i_lmp_len(char *s, ftnlen n) -{ - return (n); -} -} diff --git a/lib/linalg/static/i_lmp_nint.cpp b/lib/linalg/static/i_lmp_nint.cpp deleted file mode 100644 index f41ca6b3eb..0000000000 --- a/lib/linalg/static/i_lmp_nint.cpp +++ /dev/null @@ -1,13 +0,0 @@ - -#include "lmp_f2c.h" -#undef abs - -#include - -extern "C" { - -integer i_lmp_nint(real *x) -{ - return (integer)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x)); -} -} diff --git a/lib/linalg/static/lsame.cpp b/lib/linalg/static/lsame.cpp deleted file mode 100644 index 480ae93bc9..0000000000 --- a/lib/linalg/static/lsame.cpp +++ /dev/null @@ -1,17 +0,0 @@ - -#include - -extern "C" { - -#include "lmp_f2c.h" - -logical lsame_(const char *a, const char *b) -{ - char ua, ub; - if (!a || !b) return FALSE_; - - ua = toupper(*a); - ub = toupper(*b); - return (ua == ub) ? TRUE_ : FALSE_; -} -} diff --git a/lib/linalg/static/pow_lmp_dd.cpp b/lib/linalg/static/pow_lmp_dd.cpp deleted file mode 100644 index 4963b04bbc..0000000000 --- a/lib/linalg/static/pow_lmp_dd.cpp +++ /dev/null @@ -1,12 +0,0 @@ - -#include "lmp_f2c.h" -#undef abs - -#include - -extern "C" { -double pow_lmp_dd(doublereal *ap, doublereal *bp) -{ - return (pow(*ap, *bp)); -} -} diff --git a/lib/linalg/static/pow_lmp_di.cpp b/lib/linalg/static/pow_lmp_di.cpp deleted file mode 100644 index 83a0da1a87..0000000000 --- a/lib/linalg/static/pow_lmp_di.cpp +++ /dev/null @@ -1,31 +0,0 @@ - -#include "lmp_f2c.h" - -extern "C" { - -double pow_lmp_di(doublereal *ap, integer *bp) -{ - double pow, x; - integer n; - unsigned long u; - - pow = 1; - x = *ap; - n = *bp; - - if (n != 0) { - if (n < 0) { - n = -n; - x = 1 / x; - } - for (u = n;;) { - if (u & 01) pow *= x; - if (u >>= 1) - x *= x; - else - break; - } - } - return (pow); -} -} diff --git a/lib/linalg/static/pow_lmp_ii.cpp b/lib/linalg/static/pow_lmp_ii.cpp deleted file mode 100644 index ff28c8fd5a..0000000000 --- a/lib/linalg/static/pow_lmp_ii.cpp +++ /dev/null @@ -1,29 +0,0 @@ - -#include "lmp_f2c.h" - -extern "C" { - -integer pow_lmp_ii(integer *ap, integer *bp) -{ - integer pow, x, n; - unsigned long u; - - x = *ap; - n = *bp; - - if (n <= 0) { - if (n == 0 || x == 1) return 1; - if (x != -1) return x == 0 ? 1 / x : 0; - n = -n; - } - u = n; - for (pow = 1;;) { - if (u & 01) pow *= x; - if (u >>= 1) - x *= x; - else - break; - } - return (pow); -} -} diff --git a/lib/linalg/static/s_lmp_cat.cpp b/lib/linalg/static/s_lmp_cat.cpp deleted file mode 100644 index 323b0b671d..0000000000 --- a/lib/linalg/static/s_lmp_cat.cpp +++ /dev/null @@ -1,23 +0,0 @@ - -#include "lmp_f2c.h" - -// concatenate two strings - -extern "C" { -void s_lmp_cat(char *lp, char *rpp[], ftnint rnp[], ftnint *np, ftnlen ll) -{ - ftnlen i, nc; - char *rp; - ftnlen n = *np; - for (i = 0; i < n; ++i) { - nc = ll; - if (rnp[i] < nc) nc = rnp[i]; - ll -= nc; - rp = rpp[i]; - while (--nc >= 0) - *lp++ = *rp++; - } - while (--ll >= 0) - *lp++ = ' '; -} -} diff --git a/lib/linalg/static/s_lmp_cmp.cpp b/lib/linalg/static/s_lmp_cmp.cpp deleted file mode 100644 index 73b011a799..0000000000 --- a/lib/linalg/static/s_lmp_cmp.cpp +++ /dev/null @@ -1,45 +0,0 @@ - -#include "lmp_f2c.h" - -extern "C" { - -// compare two strings - -integer s_lmp_cmp(char *a0, char *b0, ftnlen la, ftnlen lb) -{ - register unsigned char *a, *aend, *b, *bend; - a = (unsigned char *)a0; - b = (unsigned char *)b0; - aend = a + la; - bend = b + lb; - - if (la <= lb) { - while (a < aend) - if (*a != *b) - return (*a - *b); - else { - ++a; - ++b; - } - - while (b < bend) - if (*b != ' ') - return (' ' - *b); - else - ++b; - } else { - while (b < bend) - if (*a == *b) { - ++a; - ++b; - } else - return (*a - *b); - while (a < aend) - if (*a != ' ') - return (*a - ' '); - else - ++a; - } - return (0); -} -} diff --git a/lib/linalg/static/s_lmp_copy.cpp b/lib/linalg/static/s_lmp_copy.cpp deleted file mode 100644 index 9b432e08ca..0000000000 --- a/lib/linalg/static/s_lmp_copy.cpp +++ /dev/null @@ -1,26 +0,0 @@ - -#include "lmp_f2c.h" - -extern "C" { - -/* assign strings: a = b */ - -void s_lmp_copy(register char *a, register char *b, ftnlen la, ftnlen lb) -{ - register char *aend, *bend; - - aend = a + la; - - if (la <= lb) - while (a < aend) - *a++ = *b++; - - else { - bend = b + lb; - while (b < bend) - *a++ = *b++; - while (a < aend) - *a++ = ' '; - } -} -} diff --git a/lib/linalg/static/xerbla.cpp b/lib/linalg/static/xerbla.cpp deleted file mode 100644 index 6346126c67..0000000000 --- a/lib/linalg/static/xerbla.cpp +++ /dev/null @@ -1,31 +0,0 @@ - -#include "lmp_f2c.h" - -#undef abs -#include -#include -#include - -extern "C" { - -static constexpr int BUFSZ = 1024; - -integer xerbla_(const char *srname, integer *info) -{ - char buf[BUFSZ]; - buf[0] = '\0'; - - strcat(buf, " ** On entry to "); - for (int i = 0; i < BUFSZ - 16; ++i) { - if ((srname[i] == '\0') || (srname[i] == ' ')) { - buf[i + 16] = '\0'; - break; - } - buf[i + 16] = srname[i]; - } - int len = strlen(buf); - snprintf(buf + len, BUFSZ - len, " parameter number %d had an illegal value\n", *info); - exit(1); - return 0; -} -} diff --git a/lib/linalg/static/z_lmp_abs.cpp b/lib/linalg/static/z_lmp_abs.cpp deleted file mode 100644 index 2b79d56457..0000000000 --- a/lib/linalg/static/z_lmp_abs.cpp +++ /dev/null @@ -1,31 +0,0 @@ - -#include "lmp_f2c.h" -#undef abs - -#include - -extern "C" { - -static double f__cabs(double real, double imag) -{ - double temp; - - if (real < 0) real = -real; - if (imag < 0) imag = -imag; - if (imag > real) { - temp = real; - real = imag; - imag = temp; - } - if ((real + imag) == real) return (real); - - temp = imag / real; - temp = real * sqrt(1.0 + temp * temp); /*overflow!!*/ - return (temp); -} - -double z_lmp_abs(doublecomplex *z) -{ - return (f__cabs(z->r, z->i)); -} -} diff --git a/lib/linalg/static/z_lmp_div.cpp b/lib/linalg/static/z_lmp_div.cpp deleted file mode 100644 index 66218f8fc8..0000000000 --- a/lib/linalg/static/z_lmp_div.cpp +++ /dev/null @@ -1,31 +0,0 @@ - -#include "lmp_f2c.h" - -extern "C" { - -void z_lmp_div(doublecomplex *c, doublecomplex *a, doublecomplex *b) -{ - double ratio, den; - double abr, abi, cr; - - if ((abr = b->r) < 0.) abr = -abr; - if ((abi = b->i) < 0.) abi = -abi; - if (abr <= abi) { - if (abi == 0) { - if (a->i != 0 || a->r != 0) abi = 1.; - c->i = c->r = abi / abr; - return; - } - ratio = b->r / b->i; - den = b->i * (1 + ratio * ratio); - cr = (a->r * ratio + a->i) / den; - c->i = (a->i * ratio - a->r) / den; - } else { - ratio = b->i / b->r; - den = b->r * (1 + ratio * ratio); - cr = (a->r + a->i * ratio) / den; - c->i = (a->i - a->r * ratio) / den; - } - c->r = cr; -} -} diff --git a/lib/linalg/static/zlarft.f b/lib/linalg/static/zlarft.f deleted file mode 100644 index b59ba93213..0000000000 --- a/lib/linalg/static/zlarft.f +++ /dev/null @@ -1,328 +0,0 @@ -*> \brief \b ZLARFT forms the triangular factor T of a block reflector H = I - vtvH -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLARFT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* -* .. Scalar Arguments .. -* CHARACTER DIRECT, STOREV -* INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. -* COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLARFT forms the triangular factor T of a complex block reflector H -*> of order n, which is defined as a product of k elementary reflectors. -*> -*> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; -*> -*> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. -*> -*> If STOREV = 'C', the vector which defines the elementary reflector -*> H(i) is stored in the i-th column of the array V, and -*> -*> H = I - V * T * V**H -*> -*> If STOREV = 'R', the vector which defines the elementary reflector -*> H(i) is stored in the i-th row of the array V, and -*> -*> H = I - V**H * T * V -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] DIRECT -*> \verbatim -*> DIRECT is CHARACTER*1 -*> Specifies the order in which the elementary reflectors are -*> multiplied to form the block reflector: -*> = 'F': H = H(1) H(2) . . . H(k) (Forward) -*> = 'B': H = H(k) . . . H(2) H(1) (Backward) -*> \endverbatim -*> -*> \param[in] STOREV -*> \verbatim -*> STOREV is CHARACTER*1 -*> Specifies how the vectors which define the elementary -*> reflectors are stored (see also Further Details): -*> = 'C': columnwise -*> = 'R': rowwise -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the block reflector H. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The order of the triangular factor T (= the number of -*> elementary reflectors). K >= 1. -*> \endverbatim -*> -*> \param[in] V -*> \verbatim -*> V is COMPLEX*16 array, dimension -*> (LDV,K) if STOREV = 'C' -*> (LDV,N) if STOREV = 'R' -*> The matrix V. See further details. -*> \endverbatim -*> -*> \param[in] LDV -*> \verbatim -*> LDV is INTEGER -*> The leading dimension of the array V. -*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i). -*> \endverbatim -*> -*> \param[out] T -*> \verbatim -*> T is COMPLEX*16 array, dimension (LDT,K) -*> The k by k triangular factor T of the block reflector. -*> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is -*> lower triangular. The rest of the array is not used. -*> \endverbatim -*> -*> \param[in] LDT -*> \verbatim -*> LDT is INTEGER -*> The leading dimension of the array T. LDT >= K. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The shape of the matrix V and the storage of the vectors which define -*> the H(i) is best illustrated by the following example with n = 5 and -*> k = 3. The elements equal to 1 are not stored. -*> -*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -*> -*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -*> ( v1 1 ) ( 1 v2 v2 v2 ) -*> ( v1 v2 1 ) ( 1 v3 v3 ) -*> ( v1 v2 v3 ) -*> ( v1 v2 v3 ) -*> -*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -*> -*> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -*> ( v1 v2 v3 ) ( v2 v2 v2 1 ) -*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -*> ( 1 v3 ) -*> ( 1 ) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, STOREV - INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. - COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, J, PREVLASTV, LASTV -* .. -* .. External Subroutines .. - EXTERNAL ZGEMV, ZTRMV, ZGEMM -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( LSAME( DIRECT, 'F' ) ) THEN - PREVLASTV = N - DO I = 1, K - PREVLASTV = MAX( PREVLASTV, I ) - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = 1, I - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( LASTV, I ).NE.ZERO ) GOTO 220 - END DO - 220 CONTINUE - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * CONJG( V( I , J ) ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i) -* - CALL ZGEMV( 'Conjugate transpose', J-I, I-1, - $ -TAU( I ), V( I+1, 1 ), LDV, - $ V( I+1, I ), 1, ONE, T( 1, I ), 1 ) - ELSE -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( I, LASTV ).NE.ZERO ) GOTO 236 - END DO - 236 CONTINUE - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * V( J , I ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H -* - CALL ZGEMM( 'N', 'C', I-1, 1, J-I, -TAU( I ), - $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, - $ ONE, T( 1, I ), LDT ) - END IF -* -* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) -* - CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, - $ LDT, T( 1, I ), 1 ) - T( I, I ) = TAU( I ) - IF( I.GT.1 ) THEN - PREVLASTV = MAX( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - END DO - ELSE - PREVLASTV = 1 - DO I = K, 1, -1 - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = I, K - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( I.LT.K ) THEN - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( LASTV, I ).NE.ZERO ) GOTO 281 - END DO - 281 CONTINUE - DO J = I+1, K - T( J, I ) = -TAU( I ) * CONJG( V( N-K+I , J ) ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i) -* - CALL ZGEMV( 'Conjugate transpose', N-K+I-J, K-I, - $ -TAU( I ), V( J, I+1 ), LDV, V( J, I ), - $ 1, ONE, T( I+1, I ), 1 ) - ELSE -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( I, LASTV ).NE.ZERO ) GOTO 297 - END DO - 297 CONTINUE - DO J = I+1, K - T( J, I ) = -TAU( I ) * V( J, N-K+I ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H -* - CALL ZGEMM( 'N', 'C', K-I, 1, N-K+I-J, -TAU( I ), - $ V( I+1, J ), LDV, V( I, J ), LDV, - $ ONE, T( I+1, I ), LDT ) - END IF -* -* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) -* - CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, - $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) - IF( I.GT.1 ) THEN - PREVLASTV = MIN( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - T( I, I ) = TAU( I ) - END IF - END DO - END IF - RETURN -* -* End of ZLARFT -* - END