From d85c99af0faf38883cbc4501631366fb2e983c75 Mon Sep 17 00:00:00 2001 From: Vincent Vanlaer Date: Thu, 8 Aug 2024 00:50:26 -0400 Subject: [PATCH] mtx: don't vendor lapack It is only used for non-sdk builds, and other required libraries (such as HDF5) are not included for non-sdk builds as well. Furthermore, this prevents the vendored version from being out of date with the SDK version. --- mtx/blas_src/dasum.f | 111 - mtx/blas_src/daxpy.f | 115 - mtx/blas_src/dcopy.f | 115 - mtx/blas_src/ddot.f | 117 - mtx/blas_src/dgbmv.f | 374 --- mtx/blas_src/dgemm.f | 388 ---- mtx/blas_src/dgemv.f | 334 --- mtx/blas_src/dger.f | 227 -- mtx/blas_src/dlamch.f | 857 ------- mtx/blas_src/dscal.f | 110 - mtx/blas_src/dswap.f | 122 - mtx/blas_src/dtbsv.f | 401 ---- mtx/blas_src/dtrsm.f | 443 ---- mtx/blas_src/dtrsv.f | 338 --- mtx/blas_src/idamax.f | 106 - mtx/blas_src/ieeeck.f | 148 -- mtx/blas_src/ilaenv.f | 547 ----- mtx/blas_src/isamax.f | 106 - mtx/blas_src/lsame.f | 125 -- mtx/blas_src/sgemm.f | 388 ---- mtx/blas_src/sger.f | 227 -- mtx/blas_src/slamch.f | 857 ------- mtx/blas_src/sscal.f | 110 - mtx/blas_src/sswap.f | 122 - mtx/blas_src/strsm.f | 443 ---- mtx/blas_src/xerbla.f | 89 - mtx/blas_src/zaxpy.f | 102 - mtx/blas_src/zdotc.f | 101 - mtx/blas_src/zgerc.f | 227 -- mtx/blas_src/zhemv.f | 337 --- mtx/blas_src/zher2.f | 317 --- mtx/blas_src/ztrsv.f | 375 ---- mtx/lapack_src/dbdsqr.f | 850 ------- mtx/lapack_src/dcabs1.f | 16 - mtx/lapack_src/dgbcon.f | 311 --- mtx/lapack_src/dgbequ.f | 324 --- mtx/lapack_src/dgbrfs.f | 464 ---- mtx/lapack_src/dgbsv.f | 223 -- mtx/lapack_src/dgbsvx.f | 642 ------ mtx/lapack_src/dgbtf2.f | 277 --- mtx/lapack_src/dgbtrf.f | 516 ----- mtx/lapack_src/dgbtrs.f | 269 --- mtx/lapack_src/dgebak.f | 268 --- mtx/lapack_src/dgebal.f | 405 ---- mtx/lapack_src/dgebd2.f | 320 --- mtx/lapack_src/dgebrd.f | 353 --- mtx/lapack_src/dgecon.f | 261 --- mtx/lapack_src/dgeequ.f | 304 --- mtx/lapack_src/dgeev.f | 516 ----- mtx/lapack_src/dgehd2.f | 225 -- mtx/lapack_src/dgehrd.f | 352 --- mtx/lapack_src/dgelq2.f | 192 -- mtx/lapack_src/dgelqf.f | 269 --- mtx/lapack_src/dgeqr2.f | 192 -- mtx/lapack_src/dgeqrf.f | 270 --- mtx/lapack_src/dgerfs.f | 438 ---- mtx/lapack_src/dgesv.f | 179 -- mtx/lapack_src/dgesvd.f | 3493 ----------------------------- mtx/lapack_src/dgesvx.f | 602 ----- mtx/lapack_src/dgetf2.f | 213 -- mtx/lapack_src/dgetrf.f | 225 -- mtx/lapack_src/dgetri.f | 261 --- mtx/lapack_src/dgetrs.f | 225 -- mtx/lapack_src/dgtcon.f | 255 --- mtx/lapack_src/dgtrfs.f | 474 ---- mtx/lapack_src/dgtsv.f | 333 --- mtx/lapack_src/dgtsvx.f | 414 ---- mtx/lapack_src/dgttrf.f | 237 -- mtx/lapack_src/dgttrs.f | 223 -- mtx/lapack_src/dgtts2.f | 274 --- mtx/lapack_src/dhseqr.f | 516 ----- mtx/lapack_src/disnan.f | 80 - mtx/lapack_src/dlabad.f | 105 - mtx/lapack_src/dlabrd.f | 381 ---- mtx/lapack_src/dlacn2.f | 294 --- mtx/lapack_src/dlacpy.f | 156 -- mtx/lapack_src/dladiv.f | 128 -- mtx/lapack_src/dlaexc.f | 436 ---- mtx/lapack_src/dlagtm.f | 278 --- mtx/lapack_src/dlahqr.f | 611 ----- mtx/lapack_src/dlahr2.f | 326 --- mtx/lapack_src/dlaisnan.f | 91 - mtx/lapack_src/dlaln2.f | 611 ----- mtx/lapack_src/dlangb.f | 223 -- mtx/lapack_src/dlange.f | 209 -- mtx/lapack_src/dlangt.f | 203 -- mtx/lapack_src/dlantb.f | 356 --- mtx/lapack_src/dlantr.f | 348 --- mtx/lapack_src/dlanv2.f | 289 --- mtx/lapack_src/dlapy2.f | 104 - mtx/lapack_src/dlaqgb.f | 256 --- mtx/lapack_src/dlaqge.f | 236 -- mtx/lapack_src/dlaqr0.f | 740 ------ mtx/lapack_src/dlaqr1.f | 179 -- mtx/lapack_src/dlaqr2.f | 684 ------ mtx/lapack_src/dlaqr3.f | 695 ------ mtx/lapack_src/dlaqr4.f | 739 ------ mtx/lapack_src/dlaqr5.f | 921 -------- mtx/lapack_src/dlarf.f | 227 -- mtx/lapack_src/dlarfb.f | 762 ------- mtx/lapack_src/dlarfg.f | 196 -- mtx/lapack_src/dlarft.f | 326 --- mtx/lapack_src/dlarfx.f | 697 ------ mtx/lapack_src/dlartg.f | 204 -- mtx/lapack_src/dlas2.f | 183 -- mtx/lapack_src/dlascl.f | 364 --- mtx/lapack_src/dlaset.f | 184 -- mtx/lapack_src/dlasq1.f | 224 -- mtx/lapack_src/dlasq2.f | 582 ----- mtx/lapack_src/dlasq3.f | 421 ---- mtx/lapack_src/dlasq4.f | 425 ---- mtx/lapack_src/dlasq5.f | 410 ---- mtx/lapack_src/dlasq6.f | 254 --- mtx/lapack_src/dlasr.f | 436 ---- mtx/lapack_src/dlasrt.f | 303 --- mtx/lapack_src/dlassq.f | 151 -- mtx/lapack_src/dlasv2.f | 325 --- mtx/lapack_src/dlaswp.f | 191 -- mtx/lapack_src/dlasy2.f | 480 ---- mtx/lapack_src/dlatbs.f | 812 ------- mtx/lapack_src/dlatrs.f | 787 ------- mtx/lapack_src/dlazq3.f | 302 --- mtx/lapack_src/dlazq4.f | 330 --- mtx/lapack_src/dnrm2.f | 67 - mtx/lapack_src/dorg2r.f | 200 -- mtx/lapack_src/dorgbr.f | 338 --- mtx/lapack_src/dorghr.f | 240 -- mtx/lapack_src/dorgl2.f | 204 -- mtx/lapack_src/dorglq.f | 289 --- mtx/lapack_src/dorgqr.f | 290 --- mtx/lapack_src/dorm2r.f | 282 --- mtx/lapack_src/dormbr.f | 372 --- mtx/lapack_src/dormhr.f | 294 --- mtx/lapack_src/dorml2.f | 282 --- mtx/lapack_src/dormlq.f | 354 --- mtx/lapack_src/dormqr.f | 347 --- mtx/lapack_src/drot.f | 55 - mtx/lapack_src/drscl.f | 174 -- mtx/lapack_src/dtrevc.f | 1076 --------- mtx/lapack_src/dtrexc.f | 426 ---- mtx/lapack_src/dtrmm.f | 349 --- mtx/lapack_src/dtrmv.f | 282 --- mtx/lapack_src/dtrti2.f | 212 -- mtx/lapack_src/dtrtri.f | 242 -- mtx/lapack_src/dtrtrs.f | 226 -- mtx/lapack_src/icmax1.f | 154 -- mtx/lapack_src/ieeeck.f | 203 -- mtx/lapack_src/ilaclc.f | 118 - mtx/lapack_src/ilaclr.f | 121 - mtx/lapack_src/iladiag.f | 92 - mtx/lapack_src/iladlc.f | 118 - mtx/lapack_src/iladlr.f | 121 - mtx/lapack_src/ilaenv.f | 624 ------ mtx/lapack_src/ilaprec.f | 98 - mtx/lapack_src/ilaslc.f | 118 - mtx/lapack_src/ilaslr.f | 121 - mtx/lapack_src/ilatrans.f | 95 - mtx/lapack_src/ilauplo.f | 92 - mtx/lapack_src/ilaver.f | 66 - mtx/lapack_src/ilazlc.f | 118 - mtx/lapack_src/ilazlr.f | 121 - mtx/lapack_src/iparmq.f | 322 --- mtx/lapack_src/izamax.f | 55 - mtx/lapack_src/izmax1.f | 154 -- mtx/lapack_src/sgesv.f | 179 -- mtx/lapack_src/sgetf2.f | 213 -- mtx/lapack_src/sgetrf.f | 225 -- mtx/lapack_src/sgetrs.f | 225 -- mtx/lapack_src/slaswp.f | 191 -- mtx/lapack_src/zcopy.f | 44 - mtx/lapack_src/zgbtf2.f | 277 --- mtx/lapack_src/zgbtrf.f | 517 ----- mtx/lapack_src/zgbtrs.f | 297 --- mtx/lapack_src/zgemm.f | 415 ---- mtx/lapack_src/zgemv.f | 282 --- mtx/lapack_src/zgeru.f | 160 -- mtx/lapack_src/zgetf2.f | 214 -- mtx/lapack_src/zgetrf.f | 225 -- mtx/lapack_src/zgetrs.f | 225 -- mtx/lapack_src/zgttrf.f | 243 -- mtx/lapack_src/zgttrs.f | 225 -- mtx/lapack_src/zgtts2.f | 349 --- mtx/lapack_src/zlacgv.f | 116 - mtx/lapack_src/zlaswp.f | 191 -- mtx/lapack_src/zscal.f | 41 - mtx/lapack_src/zswap.f | 48 - mtx/lapack_src/ztbsv.f | 368 --- mtx/lapack_src/ztrsm.f | 408 ---- mtx/make/makefile_base | 249 +- utils/makefile_header | 3 - utils/makefile_header_non_mesasdk | 2 - 191 files changed, 2 insertions(+), 59657 deletions(-) delete mode 100644 mtx/blas_src/dasum.f delete mode 100644 mtx/blas_src/daxpy.f delete mode 100644 mtx/blas_src/dcopy.f delete mode 100644 mtx/blas_src/ddot.f delete mode 100644 mtx/blas_src/dgbmv.f delete mode 100644 mtx/blas_src/dgemm.f delete mode 100644 mtx/blas_src/dgemv.f delete mode 100644 mtx/blas_src/dger.f delete mode 100644 mtx/blas_src/dlamch.f delete mode 100644 mtx/blas_src/dscal.f delete mode 100644 mtx/blas_src/dswap.f delete mode 100644 mtx/blas_src/dtbsv.f delete mode 100644 mtx/blas_src/dtrsm.f delete mode 100644 mtx/blas_src/dtrsv.f delete mode 100644 mtx/blas_src/idamax.f delete mode 100644 mtx/blas_src/ieeeck.f delete mode 100644 mtx/blas_src/ilaenv.f delete mode 100644 mtx/blas_src/isamax.f delete mode 100644 mtx/blas_src/lsame.f delete mode 100644 mtx/blas_src/sgemm.f delete mode 100644 mtx/blas_src/sger.f delete mode 100644 mtx/blas_src/slamch.f delete mode 100644 mtx/blas_src/sscal.f delete mode 100644 mtx/blas_src/sswap.f delete mode 100644 mtx/blas_src/strsm.f delete mode 100644 mtx/blas_src/xerbla.f delete mode 100644 mtx/blas_src/zaxpy.f delete mode 100644 mtx/blas_src/zdotc.f delete mode 100644 mtx/blas_src/zgerc.f delete mode 100644 mtx/blas_src/zhemv.f delete mode 100644 mtx/blas_src/zher2.f delete mode 100644 mtx/blas_src/ztrsv.f delete mode 100644 mtx/lapack_src/dbdsqr.f delete mode 100644 mtx/lapack_src/dcabs1.f delete mode 100644 mtx/lapack_src/dgbcon.f delete mode 100644 mtx/lapack_src/dgbequ.f delete mode 100644 mtx/lapack_src/dgbrfs.f delete mode 100644 mtx/lapack_src/dgbsv.f delete mode 100644 mtx/lapack_src/dgbsvx.f delete mode 100644 mtx/lapack_src/dgbtf2.f delete mode 100644 mtx/lapack_src/dgbtrf.f delete mode 100644 mtx/lapack_src/dgbtrs.f delete mode 100644 mtx/lapack_src/dgebak.f delete mode 100644 mtx/lapack_src/dgebal.f delete mode 100644 mtx/lapack_src/dgebd2.f delete mode 100644 mtx/lapack_src/dgebrd.f delete mode 100644 mtx/lapack_src/dgecon.f delete mode 100644 mtx/lapack_src/dgeequ.f delete mode 100644 mtx/lapack_src/dgeev.f delete mode 100644 mtx/lapack_src/dgehd2.f delete mode 100644 mtx/lapack_src/dgehrd.f delete mode 100644 mtx/lapack_src/dgelq2.f delete mode 100644 mtx/lapack_src/dgelqf.f delete mode 100644 mtx/lapack_src/dgeqr2.f delete mode 100644 mtx/lapack_src/dgeqrf.f delete mode 100644 mtx/lapack_src/dgerfs.f delete mode 100644 mtx/lapack_src/dgesv.f delete mode 100644 mtx/lapack_src/dgesvd.f delete mode 100644 mtx/lapack_src/dgesvx.f delete mode 100644 mtx/lapack_src/dgetf2.f delete mode 100644 mtx/lapack_src/dgetrf.f delete mode 100644 mtx/lapack_src/dgetri.f delete mode 100644 mtx/lapack_src/dgetrs.f delete mode 100644 mtx/lapack_src/dgtcon.f delete mode 100644 mtx/lapack_src/dgtrfs.f delete mode 100644 mtx/lapack_src/dgtsv.f delete mode 100644 mtx/lapack_src/dgtsvx.f delete mode 100644 mtx/lapack_src/dgttrf.f delete mode 100644 mtx/lapack_src/dgttrs.f delete mode 100644 mtx/lapack_src/dgtts2.f delete mode 100644 mtx/lapack_src/dhseqr.f delete mode 100644 mtx/lapack_src/disnan.f delete mode 100644 mtx/lapack_src/dlabad.f delete mode 100644 mtx/lapack_src/dlabrd.f delete mode 100644 mtx/lapack_src/dlacn2.f delete mode 100644 mtx/lapack_src/dlacpy.f delete mode 100644 mtx/lapack_src/dladiv.f delete mode 100644 mtx/lapack_src/dlaexc.f delete mode 100644 mtx/lapack_src/dlagtm.f delete mode 100644 mtx/lapack_src/dlahqr.f delete mode 100644 mtx/lapack_src/dlahr2.f delete mode 100644 mtx/lapack_src/dlaisnan.f delete mode 100644 mtx/lapack_src/dlaln2.f delete mode 100644 mtx/lapack_src/dlangb.f delete mode 100644 mtx/lapack_src/dlange.f delete mode 100644 mtx/lapack_src/dlangt.f delete mode 100644 mtx/lapack_src/dlantb.f delete mode 100644 mtx/lapack_src/dlantr.f delete mode 100644 mtx/lapack_src/dlanv2.f delete mode 100644 mtx/lapack_src/dlapy2.f delete mode 100644 mtx/lapack_src/dlaqgb.f delete mode 100644 mtx/lapack_src/dlaqge.f delete mode 100644 mtx/lapack_src/dlaqr0.f delete mode 100644 mtx/lapack_src/dlaqr1.f delete mode 100644 mtx/lapack_src/dlaqr2.f delete mode 100644 mtx/lapack_src/dlaqr3.f delete mode 100644 mtx/lapack_src/dlaqr4.f delete mode 100644 mtx/lapack_src/dlaqr5.f delete mode 100644 mtx/lapack_src/dlarf.f delete mode 100644 mtx/lapack_src/dlarfb.f delete mode 100644 mtx/lapack_src/dlarfg.f delete mode 100644 mtx/lapack_src/dlarft.f delete mode 100644 mtx/lapack_src/dlarfx.f delete mode 100644 mtx/lapack_src/dlartg.f delete mode 100644 mtx/lapack_src/dlas2.f delete mode 100644 mtx/lapack_src/dlascl.f delete mode 100644 mtx/lapack_src/dlaset.f delete mode 100644 mtx/lapack_src/dlasq1.f delete mode 100644 mtx/lapack_src/dlasq2.f delete mode 100644 mtx/lapack_src/dlasq3.f delete mode 100644 mtx/lapack_src/dlasq4.f delete mode 100644 mtx/lapack_src/dlasq5.f delete mode 100644 mtx/lapack_src/dlasq6.f delete mode 100644 mtx/lapack_src/dlasr.f delete mode 100644 mtx/lapack_src/dlasrt.f delete mode 100644 mtx/lapack_src/dlassq.f delete mode 100644 mtx/lapack_src/dlasv2.f delete mode 100644 mtx/lapack_src/dlaswp.f delete mode 100644 mtx/lapack_src/dlasy2.f delete mode 100644 mtx/lapack_src/dlatbs.f delete mode 100644 mtx/lapack_src/dlatrs.f delete mode 100644 mtx/lapack_src/dlazq3.f delete mode 100644 mtx/lapack_src/dlazq4.f delete mode 100644 mtx/lapack_src/dnrm2.f delete mode 100644 mtx/lapack_src/dorg2r.f delete mode 100644 mtx/lapack_src/dorgbr.f delete mode 100644 mtx/lapack_src/dorghr.f delete mode 100644 mtx/lapack_src/dorgl2.f delete mode 100644 mtx/lapack_src/dorglq.f delete mode 100644 mtx/lapack_src/dorgqr.f delete mode 100644 mtx/lapack_src/dorm2r.f delete mode 100644 mtx/lapack_src/dormbr.f delete mode 100644 mtx/lapack_src/dormhr.f delete mode 100644 mtx/lapack_src/dorml2.f delete mode 100644 mtx/lapack_src/dormlq.f delete mode 100644 mtx/lapack_src/dormqr.f delete mode 100644 mtx/lapack_src/drot.f delete mode 100644 mtx/lapack_src/drscl.f delete mode 100644 mtx/lapack_src/dtrevc.f delete mode 100644 mtx/lapack_src/dtrexc.f delete mode 100644 mtx/lapack_src/dtrmm.f delete mode 100644 mtx/lapack_src/dtrmv.f delete mode 100644 mtx/lapack_src/dtrti2.f delete mode 100644 mtx/lapack_src/dtrtri.f delete mode 100644 mtx/lapack_src/dtrtrs.f delete mode 100644 mtx/lapack_src/icmax1.f delete mode 100644 mtx/lapack_src/ieeeck.f delete mode 100644 mtx/lapack_src/ilaclc.f delete mode 100644 mtx/lapack_src/ilaclr.f delete mode 100644 mtx/lapack_src/iladiag.f delete mode 100644 mtx/lapack_src/iladlc.f delete mode 100644 mtx/lapack_src/iladlr.f delete mode 100644 mtx/lapack_src/ilaenv.f delete mode 100644 mtx/lapack_src/ilaprec.f delete mode 100644 mtx/lapack_src/ilaslc.f delete mode 100644 mtx/lapack_src/ilaslr.f delete mode 100644 mtx/lapack_src/ilatrans.f delete mode 100644 mtx/lapack_src/ilauplo.f delete mode 100644 mtx/lapack_src/ilaver.f delete mode 100644 mtx/lapack_src/ilazlc.f delete mode 100644 mtx/lapack_src/ilazlr.f delete mode 100644 mtx/lapack_src/iparmq.f delete mode 100644 mtx/lapack_src/izamax.f delete mode 100644 mtx/lapack_src/izmax1.f delete mode 100644 mtx/lapack_src/sgesv.f delete mode 100644 mtx/lapack_src/sgetf2.f delete mode 100644 mtx/lapack_src/sgetrf.f delete mode 100644 mtx/lapack_src/sgetrs.f delete mode 100644 mtx/lapack_src/slaswp.f delete mode 100644 mtx/lapack_src/zcopy.f delete mode 100644 mtx/lapack_src/zgbtf2.f delete mode 100644 mtx/lapack_src/zgbtrf.f delete mode 100644 mtx/lapack_src/zgbtrs.f delete mode 100644 mtx/lapack_src/zgemm.f delete mode 100644 mtx/lapack_src/zgemv.f delete mode 100644 mtx/lapack_src/zgeru.f delete mode 100644 mtx/lapack_src/zgetf2.f delete mode 100644 mtx/lapack_src/zgetrf.f delete mode 100644 mtx/lapack_src/zgetrs.f delete mode 100644 mtx/lapack_src/zgttrf.f delete mode 100644 mtx/lapack_src/zgttrs.f delete mode 100644 mtx/lapack_src/zgtts2.f delete mode 100644 mtx/lapack_src/zlacgv.f delete mode 100644 mtx/lapack_src/zlaswp.f delete mode 100644 mtx/lapack_src/zscal.f delete mode 100644 mtx/lapack_src/zswap.f delete mode 100644 mtx/lapack_src/ztbsv.f delete mode 100644 mtx/lapack_src/ztrsm.f diff --git a/mtx/blas_src/dasum.f b/mtx/blas_src/dasum.f deleted file mode 100644 index c1bd78ac8..000000000 --- a/mtx/blas_src/dasum.f +++ /dev/null @@ -1,111 +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 -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. 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 diff --git a/mtx/blas_src/daxpy.f b/mtx/blas_src/daxpy.f deleted file mode 100644 index 64a02d68b..000000000 --- a/mtx/blas_src/daxpy.f +++ /dev/null @@ -1,115 +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 -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. 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 diff --git a/mtx/blas_src/dcopy.f b/mtx/blas_src/dcopy.f deleted file mode 100644 index d9d5ac7aa..000000000 --- a/mtx/blas_src/dcopy.f +++ /dev/null @@ -1,115 +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 one. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. 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 diff --git a/mtx/blas_src/ddot.f b/mtx/blas_src/ddot.f deleted file mode 100644 index cc0c1b7a4..000000000 --- a/mtx/blas_src/ddot.f +++ /dev/null @@ -1,117 +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 -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. 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 diff --git a/mtx/blas_src/dgbmv.f b/mtx/blas_src/dgbmv.f deleted file mode 100644 index 4a608bd6a..000000000 --- a/mtx/blas_src/dgbmv.f +++ /dev/null @@ -1,374 +0,0 @@ -*> \brief \b DGBMV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA,BETA -* INTEGER INCX,INCY,KL,KU,LDA,M,N -* CHARACTER TRANS -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGBMV performs one of the matrix-vector operations -*> -*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, -*> -*> where alpha and beta are scalars, x and y are vectors and A is an -*> m by n band matrix, with kl sub-diagonals and ku super-diagonals. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the operation to be performed as -*> follows: -*> -*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -*> -*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. -*> -*> TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of the matrix A. -*> M must be at least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] KL -*> \verbatim -*> KL is INTEGER -*> On entry, KL specifies the number of sub-diagonals of the -*> matrix A. KL must satisfy 0 .le. KL. -*> \endverbatim -*> -*> \param[in] KU -*> \verbatim -*> KU is INTEGER -*> On entry, KU specifies the number of super-diagonals of the -*> matrix A. KU must satisfy 0 .le. KU. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ). -*> Before entry, the leading ( kl + ku + 1 ) by n part of the -*> array A must contain the matrix of coefficients, supplied -*> column by column, with the leading diagonal of the matrix in -*> row ( ku + 1 ) of the array, the first super-diagonal -*> starting at position 2 in row ku, the first sub-diagonal -*> starting at position 1 in row ( ku + 2 ), and so on. -*> Elements in the array A that do not correspond to elements -*> in the band matrix (such as the top left ku by ku triangle) -*> are not referenced. -*> The following program segment will transfer a band matrix -*> from conventional full matrix storage to band storage: -*> -*> DO 20, J = 1, N -*> K = KU + 1 - J -*> DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) -*> A( K + I, J ) = matrix( I, J ) -*> 10 CONTINUE -*> 20 CONTINUE -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> ( kl + ku + 1 ). -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is DOUBLE PRECISION array of 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 of DIMENSION at least -*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -*> and at least -*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -*> Before entry, the incremented array Y must contain the -*> vector y. On exit, Y is overwritten by the updated vector y. -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> On entry, INCY specifies the increment for the elements of -*> Y. INCY must not be zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup double_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> The vector and matrix arguments are not referenced when N = 0, or M = 0 -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* -* -- Reference BLAS level2 routine (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA,BETA - INTEGER INCX,INCY,KL,KU,LDA,M,N - CHARACTER TRANS -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,IY,J,JX,JY,K,KUP1,KX,KY,LENX,LENY -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX,MIN -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 1 - ELSE IF (M.LT.0) THEN - INFO = 2 - ELSE IF (N.LT.0) THEN - INFO = 3 - ELSE IF (KL.LT.0) THEN - INFO = 4 - ELSE IF (KU.LT.0) THEN - INFO = 5 - ELSE IF (LDA.LT. (KL+KU+1)) THEN - INFO = 8 - ELSE IF (INCX.EQ.0) THEN - INFO = 10 - ELSE IF (INCY.EQ.0) THEN - INFO = 13 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DGBMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. - + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF (LSAME(TRANS,'N')) THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (LENX-1)*INCX - END IF - IF (INCY.GT.0) THEN - KY = 1 - ELSE - KY = 1 - (LENY-1)*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the band part of A. -* -* First form y := beta*y. -* - IF (BETA.NE.ONE) THEN - IF (INCY.EQ.1) THEN - IF (BETA.EQ.ZERO) THEN - DO 10 I = 1,LENY - Y(I) = ZERO - 10 CONTINUE - ELSE - DO 20 I = 1,LENY - Y(I) = BETA*Y(I) - 20 CONTINUE - END IF - ELSE - IY = KY - IF (BETA.EQ.ZERO) THEN - DO 30 I = 1,LENY - Y(IY) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40 I = 1,LENY - Y(IY) = BETA*Y(IY) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF (ALPHA.EQ.ZERO) RETURN - KUP1 = KU + 1 - IF (LSAME(TRANS,'N')) THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF (INCY.EQ.1) THEN - DO 60 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = ALPHA*X(JX) - K = KUP1 - J - DO 50 I = MAX(1,J-KU),MIN(M,J+KL) - Y(I) = Y(I) + TEMP*A(K+I,J) - 50 CONTINUE - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = ALPHA*X(JX) - IY = KY - K = KUP1 - J - DO 70 I = MAX(1,J-KU),MIN(M,J+KL) - Y(IY) = Y(IY) + TEMP*A(K+I,J) - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - IF (J.GT.KU) KY = KY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A**T*x + y. -* - JY = KY - IF (INCX.EQ.1) THEN - DO 100 J = 1,N - TEMP = ZERO - K = KUP1 - J - DO 90 I = MAX(1,J-KU),MIN(M,J+KL) - TEMP = TEMP + A(K+I,J)*X(I) - 90 CONTINUE - Y(JY) = Y(JY) + ALPHA*TEMP - JY = JY + INCY - 100 CONTINUE - ELSE - DO 120 J = 1,N - TEMP = ZERO - IX = KX - K = KUP1 - J - DO 110 I = MAX(1,J-KU),MIN(M,J+KL) - TEMP = TEMP + A(K+I,J)*X(IX) - IX = IX + INCX - 110 CONTINUE - Y(JY) = Y(JY) + ALPHA*TEMP - JY = JY + INCY - IF (J.GT.KU) KX = KX + INCX - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGBMV . -* - END diff --git a/mtx/blas_src/dgemm.f b/mtx/blas_src/dgemm.f deleted file mode 100644 index 45d001b7a..000000000 --- a/mtx/blas_src/dgemm.f +++ /dev/null @@ -1,388 +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 of 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 of 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 of 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. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. 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,NCOLA,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, NCOLA and NROWB as the number of rows -* and columns of A and the number of rows of B respectively. -* - NOTA = LSAME(TRANSA,'N') - NOTB = LSAME(TRANSB,'N') - IF (NOTA) THEN - NROWA = M - NCOLA = K - ELSE - NROWA = K - NCOLA = M - 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 - IF (B(L,J).NE.ZERO) THEN - TEMP = ALPHA*B(L,J) - DO 70 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 70 CONTINUE - END IF - 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 - IF (B(J,L).NE.ZERO) THEN - TEMP = ALPHA*B(J,L) - DO 150 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 150 CONTINUE - END IF - 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/mtx/blas_src/dgemv.f b/mtx/blas_src/dgemv.f deleted file mode 100644 index 675257fac..000000000 --- a/mtx/blas_src/dgemv.f +++ /dev/null @@ -1,334 +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 of 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 of 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 of 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. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. 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 - IF (X(JX).NE.ZERO) THEN - TEMP = ALPHA*X(JX) - DO 50 I = 1,M - Y(I) = Y(I) + TEMP*A(I,J) - 50 CONTINUE - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = ALPHA*X(JX) - IY = KY - DO 70 I = 1,M - Y(IY) = Y(IY) + TEMP*A(I,J) - IY = IY + INCY - 70 CONTINUE - END IF - 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/mtx/blas_src/dger.f b/mtx/blas_src/dger.f deleted file mode 100644 index a04248370..000000000 --- a/mtx/blas_src/dger.f +++ /dev/null @@ -1,227 +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 of 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 of 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 of 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. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. 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/mtx/blas_src/dlamch.f b/mtx/blas_src/dlamch.f deleted file mode 100644 index 64ac3becd..000000000 --- a/mtx/blas_src/dlamch.f +++ /dev/null @@ -1,857 +0,0 @@ - DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER CMACH -* .. -* -* Purpose -* ======= -* -* DLAMCH determines double precision machine parameters. -* -* Arguments -* ========= -* -* CMACH (input) CHARACTER*1 -* Specifies the value to be returned by DLAMCH: -* = 'E' or 'e', DLAMCH := eps -* = 'S' or 's , DLAMCH := sfmin -* = 'B' or 'b', DLAMCH := base -* = 'P' or 'p', DLAMCH := eps*base -* = 'N' or 'n', DLAMCH := t -* = 'R' or 'r', DLAMCH := rnd -* = 'M' or 'm', DLAMCH := emin -* = 'U' or 'u', DLAMCH := rmin -* = 'L' or 'l', DLAMCH := emax -* = 'O' or 'o', DLAMCH := rmax -* -* where -* -* eps = relative machine precision -* sfmin = safe minimum, such that 1/sfmin does not overflow -* base = base of the machine -* prec = eps*base -* t = number of (base) digits in the mantissa -* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise -* emin = minimum exponent before (gradual) underflow -* rmin = underflow threshold - base**(emin-1) -* emax = largest exponent before overflow -* rmax = overflow threshold - (base**emax)*(1-eps) -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL FIRST, LRND - INTEGER BETA, IMAX, IMIN, IT - DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, - $ RND, SFMIN, SMALL, T -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLAMC2 -* .. -* .. Save statement .. - SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, - $ EMAX, RMAX, PREC -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / -* .. -* .. Executable Statements .. -* - IF( FIRST ) THEN - FIRST = .FALSE. - CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) - BASE = BETA - T = IT - IF( LRND ) THEN - RND = ONE - EPS = ( BASE**( 1-IT ) ) / 2 - ELSE - RND = ZERO - EPS = BASE**( 1-IT ) - END IF - PREC = EPS*BASE - EMIN = IMIN - EMAX = IMAX - SFMIN = RMIN - SMALL = ONE / RMAX - 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 - END IF -* - IF( LSAME( CMACH, 'E' ) ) THEN - RMACH = EPS - ELSE IF( LSAME( CMACH, 'S' ) ) THEN - RMACH = SFMIN - ELSE IF( LSAME( CMACH, 'B' ) ) THEN - RMACH = BASE - ELSE IF( LSAME( CMACH, 'P' ) ) THEN - RMACH = PREC - ELSE IF( LSAME( CMACH, 'N' ) ) THEN - RMACH = T - ELSE IF( LSAME( CMACH, 'R' ) ) THEN - RMACH = RND - ELSE IF( LSAME( CMACH, 'M' ) ) THEN - RMACH = EMIN - ELSE IF( LSAME( CMACH, 'U' ) ) THEN - RMACH = RMIN - ELSE IF( LSAME( CMACH, 'L' ) ) THEN - RMACH = EMAX - ELSE IF( LSAME( CMACH, 'O' ) ) THEN - RMACH = RMAX - END IF -* - DLAMCH = RMACH - RETURN -* -* End of DLAMCH -* - END -* -************************************************************************ -* - SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - LOGICAL IEEE1, RND - INTEGER BETA, T -* .. -* -* Purpose -* ======= -* -* DLAMC1 determines the machine parameters given by BETA, T, RND, and -* IEEE1. -* -* Arguments -* ========= -* -* BETA (output) INTEGER -* The base of the machine. -* -* T (output) INTEGER -* The number of ( BETA ) digits in the mantissa. -* -* RND (output) LOGICAL -* Specifies whether proper rounding ( RND = .TRUE. ) or -* chopping ( RND = .FALSE. ) occurs in addition. This may not -* be a reliable guide to the way in which the machine performs -* its arithmetic. -* -* IEEE1 (output) LOGICAL -* Specifies whether rounding appears to be done in the IEEE -* 'round to nearest' style. -* -* Further Details -* =============== -* -* The routine is based on the routine ENVRON by Malcolm and -* incorporates suggestions by Gentleman and Marovich. See -* -* Malcolm M. A. (1972) Algorithms to reveal properties of -* floating-point arithmetic. Comms. of the ACM, 15, 949-951. -* -* Gentleman W. M. and Marovich S. B. (1974) More on algorithms -* that reveal properties of floating point arithmetic units. -* Comms. of the ACM, 17, 276-277. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL FIRST, LIEEE1, LRND - INTEGER LBETA, LT - DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2 -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3 - EXTERNAL DLAMC3 -* .. -* .. Save statement .. - SAVE FIRST, LIEEE1, LBETA, LRND, LT -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / -* .. -* .. Executable Statements .. -* - IF( FIRST ) THEN - FIRST = .FALSE. - ONE = 1 -* -* LBETA, LIEEE1, LT and LRND are the local values of BETA, -* IEEE1, T and RND. -* -* Throughout this routine we use the function DLAMC3 to ensure -* that relevant values are stored and not held in registers, or -* are not affected by optimizers. -* -* Compute a = 2.0**m with the smallest positive integer m such -* that -* -* fl( a + 1.0 ) = a. -* - A = 1 - C = 1 -* -*+ WHILE( C.EQ.ONE )LOOP - 10 CONTINUE - IF( C.EQ.ONE ) THEN - A = 2*A - C = DLAMC3( A, ONE ) - C = DLAMC3( C, -A ) - GO TO 10 - END IF -*+ END WHILE -* -* Now compute b = 2.0**m with the smallest positive integer m -* such that -* -* fl( a + b ) .gt. a. -* - B = 1 - C = DLAMC3( A, B ) -* -*+ WHILE( C.EQ.A )LOOP - 20 CONTINUE - IF( C.EQ.A ) THEN - B = 2*B - C = DLAMC3( A, B ) - GO TO 20 - END IF -*+ END WHILE -* -* Now compute the base. a and c are neighbouring floating point -* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so -* their difference is beta. Adding 0.25 to c is to ensure that it -* is truncated to beta and not ( beta - 1 ). -* - QTR = ONE / 4 - SAVEC = C - C = DLAMC3( C, -A ) - LBETA = C + QTR -* -* Now determine whether rounding or chopping occurs, by adding a -* bit less than beta/2 and a bit more than beta/2 to a. -* - B = LBETA - F = DLAMC3( B / 2, -B / 100 ) - C = DLAMC3( F, A ) - IF( C.EQ.A ) THEN - LRND = .TRUE. - ELSE - LRND = .FALSE. - END IF - F = DLAMC3( B / 2, B / 100 ) - C = DLAMC3( F, A ) - IF( ( LRND ) .AND. ( C.EQ.A ) ) - $ LRND = .FALSE. -* -* Try and decide whether rounding is done in the IEEE 'round to -* nearest' style. B/2 is half a unit in the last place of the two -* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit -* zero, and SAVEC is odd. Thus adding B/2 to A should not change -* A, but adding B/2 to SAVEC should change SAVEC. -* - T1 = DLAMC3( B / 2, A ) - T2 = DLAMC3( B / 2, SAVEC ) - LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND -* -* Now find the mantissa, t. It should be the integer part of -* log to the base beta of a, however it is safer to determine t -* by powering. So we find t as the smallest positive integer for -* which -* -* fl( beta**t + 1.0 ) = 1.0. -* - LT = 0 - A = 1 - C = 1 -* -*+ WHILE( C.EQ.ONE )LOOP - 30 CONTINUE - IF( C.EQ.ONE ) THEN - LT = LT + 1 - A = A*LBETA - C = DLAMC3( A, ONE ) - C = DLAMC3( C, -A ) - GO TO 30 - END IF -*+ END WHILE -* - END IF -* - BETA = LBETA - T = LT - RND = LRND - IEEE1 = LIEEE1 - RETURN -* -* End of DLAMC1 -* - END -* -************************************************************************ -* - SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - LOGICAL RND - INTEGER BETA, EMAX, EMIN, T - DOUBLE PRECISION EPS, RMAX, RMIN -* .. -* -* Purpose -* ======= -* -* DLAMC2 determines the machine parameters specified in its argument -* list. -* -* Arguments -* ========= -* -* BETA (output) INTEGER -* The base of the machine. -* -* T (output) INTEGER -* The number of ( BETA ) digits in the mantissa. -* -* RND (output) LOGICAL -* Specifies whether proper rounding ( RND = .TRUE. ) or -* chopping ( RND = .FALSE. ) occurs in addition. This may not -* be a reliable guide to the way in which the machine performs -* its arithmetic. -* -* EPS (output) DOUBLE PRECISION -* The smallest positive number such that -* -* fl( 1.0 - EPS ) .LT. 1.0, -* -* where fl denotes the computed value. -* -* EMIN (output) INTEGER -* The minimum exponent before (gradual) underflow occurs. -* -* RMIN (output) DOUBLE PRECISION -* The smallest normalized number for the machine, given by -* BASE**( EMIN - 1 ), where BASE is the floating point value -* of BETA. -* -* EMAX (output) INTEGER -* The maximum exponent before overflow occurs. -* -* RMAX (output) DOUBLE PRECISION -* The largest positive number for the machine, given by -* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point -* value of BETA. -* -* Further Details -* =============== -* -* The computation of EPS is based on a routine PARANOIA by -* W. Kahan of the University of California at Berkeley. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND - INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, - $ NGNMIN, NGPMIN - DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, - $ SIXTH, SMALL, THIRD, TWO, ZERO -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3 - EXTERNAL DLAMC3 -* .. -* .. External Subroutines .. - EXTERNAL DLAMC1, DLAMC4, DLAMC5 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. Save statement .. - SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, - $ LRMIN, LT -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / , IWARN / .FALSE. / -* .. -* .. Executable Statements .. -* - IF( FIRST ) THEN - FIRST = .FALSE. - ZERO = 0 - ONE = 1 - TWO = 2 -* -* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of -* BETA, T, RND, EPS, EMIN and RMIN. -* -* Throughout this routine we use the function DLAMC3 to ensure -* that relevant values are stored and not held in registers, or -* are not affected by optimizers. -* -* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. -* - CALL DLAMC1( LBETA, LT, LRND, LIEEE1 ) -* -* Start to find EPS. -* - B = LBETA - A = B**( -LT ) - LEPS = A -* -* Try some tricks to see whether or not this is the correct EPS. -* - B = TWO / 3 - HALF = ONE / 2 - SIXTH = DLAMC3( B, -HALF ) - THIRD = DLAMC3( SIXTH, SIXTH ) - B = DLAMC3( THIRD, -HALF ) - B = DLAMC3( B, SIXTH ) - B = ABS( B ) - IF( B.LT.LEPS ) - $ B = LEPS -* - LEPS = 1 -* -*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP - 10 CONTINUE - IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN - LEPS = B - C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) - C = DLAMC3( HALF, -C ) - B = DLAMC3( HALF, C ) - C = DLAMC3( HALF, -B ) - B = DLAMC3( HALF, C ) - GO TO 10 - END IF -*+ END WHILE -* - IF( A.LT.LEPS ) - $ LEPS = A -* -* Computation of EPS complete. -* -* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). -* Keep dividing A by BETA until (gradual) underflow occurs. This -* is detected when we cannot recover the previous A. -* - RBASE = ONE / LBETA - SMALL = ONE - DO 20 I = 1, 3 - SMALL = DLAMC3( SMALL*RBASE, ZERO ) - 20 CONTINUE - A = DLAMC3( ONE, SMALL ) - CALL DLAMC4( NGPMIN, ONE, LBETA ) - CALL DLAMC4( NGNMIN, -ONE, LBETA ) - CALL DLAMC4( GPMIN, A, LBETA ) - CALL DLAMC4( GNMIN, -A, LBETA ) - IEEE = .FALSE. -* - IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN - IF( NGPMIN.EQ.GPMIN ) THEN - LEMIN = NGPMIN -* ( Non twos-complement machines, no gradual underflow; -* e.g., VAX ) - ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN - LEMIN = NGPMIN - 1 + LT - IEEE = .TRUE. -* ( Non twos-complement machines, with gradual underflow; -* e.g., IEEE standard followers ) - ELSE - LEMIN = MIN( NGPMIN, GPMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -* - ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN - IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN - LEMIN = MAX( NGPMIN, NGNMIN ) -* ( Twos-complement machines, no gradual underflow; -* e.g., CYBER 205 ) - ELSE - LEMIN = MIN( NGPMIN, NGNMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -* - ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. - $ ( GPMIN.EQ.GNMIN ) ) THEN - IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN - LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT -* ( Twos-complement machines with gradual underflow; -* no known machine ) - ELSE - LEMIN = MIN( NGPMIN, NGNMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -* - ELSE - LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -*** -* Comment out this if block if EMIN is ok - IF( IWARN ) THEN - FIRST = .TRUE. - WRITE( 6, FMT = 9999 )LEMIN - END IF -*** -* -* Assume IEEE arithmetic if we found denormalised numbers above, -* or if arithmetic seems to round in the IEEE style, determined -* in routine DLAMC1. A true IEEE machine should have both things -* true; however, faulty machines may have one or the other. -* - IEEE = IEEE .OR. LIEEE1 -* -* Compute RMIN by successive division by BETA. We could compute -* RMIN as BASE**( EMIN - 1 ), but some machines underflow during -* this computation. -* - LRMIN = 1 - DO 30 I = 1, 1 - LEMIN - LRMIN = DLAMC3( LRMIN*RBASE, ZERO ) - 30 CONTINUE -* -* Finally, call DLAMC5 to compute EMAX and RMAX. -* - CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) - END IF -* - BETA = LBETA - T = LT - RND = LRND - EPS = LEPS - EMIN = LEMIN - RMIN = LRMIN - EMAX = LEMAX - RMAX = LRMAX -* - RETURN -* - 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', - $ ' EMIN = ', I8, / - $ ' If, after inspection, the value EMIN looks', - $ ' acceptable please comment out ', - $ / ' the IF block as marked within the code of routine', - $ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / ) -* -* End of DLAMC2 -* - END -* -************************************************************************ -* - DOUBLE PRECISION FUNCTION DLAMC3( A, B ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - DOUBLE PRECISION A, B -* .. -* -* Purpose -* ======= -* -* DLAMC3 is intended to force A and B to be stored prior to doing -* the addition of A and B , for use in situations where optimizers -* might hold one of these in a register. -* -* Arguments -* ========= -* -* A, B (input) DOUBLE PRECISION -* The values A and B. -* -* ===================================================================== -* -* .. Executable Statements .. -* - DLAMC3 = A + B -* - RETURN -* -* End of DLAMC3 -* - END -* -************************************************************************ -* - SUBROUTINE DLAMC4( EMIN, START, BASE ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - INTEGER BASE, EMIN - DOUBLE PRECISION START -* .. -* -* Purpose -* ======= -* -* DLAMC4 is a service routine for DLAMC2. -* -* Arguments -* ========= -* -* EMIN (output) EMIN -* The minimum exponent before (gradual) underflow, computed by -* setting A = START and dividing by BASE until the previous A -* can not be recovered. -* -* START (input) DOUBLE PRECISION -* The starting point for determining EMIN. -* -* BASE (input) INTEGER -* The base of the machine. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I - DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3 - EXTERNAL DLAMC3 -* .. -* .. Executable Statements .. -* - A = START - ONE = 1 - RBASE = ONE / BASE - ZERO = 0 - EMIN = 1 - B1 = DLAMC3( A*RBASE, ZERO ) - C1 = A - C2 = A - D1 = A - D2 = A -*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. -* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP - 10 CONTINUE - IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. - $ ( D2.EQ.A ) ) THEN - EMIN = EMIN - 1 - A = B1 - B1 = DLAMC3( A / BASE, ZERO ) - C1 = DLAMC3( B1*BASE, ZERO ) - D1 = ZERO - DO 20 I = 1, BASE - D1 = D1 + B1 - 20 CONTINUE - B2 = DLAMC3( A*RBASE, ZERO ) - C2 = DLAMC3( B2 / RBASE, ZERO ) - D2 = ZERO - DO 30 I = 1, BASE - D2 = D2 + B2 - 30 CONTINUE - GO TO 10 - END IF -*+ END WHILE -* - RETURN -* -* End of DLAMC4 -* - END -* -************************************************************************ -* - SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - LOGICAL IEEE - INTEGER BETA, EMAX, EMIN, P - DOUBLE PRECISION RMAX -* .. -* -* Purpose -* ======= -* -* DLAMC5 attempts to compute RMAX, the largest machine floating-point -* number, without overflow. It assumes that EMAX + abs(EMIN) sum -* approximately to a power of 2. It will fail on machines where this -* assumption does not hold, for example, the Cyber 205 (EMIN = -28625, -* EMAX = 28718). It will also fail if the value supplied for EMIN is -* too large (i.e. too close to zero), probably with overflow. -* -* Arguments -* ========= -* -* BETA (input) INTEGER -* The base of floating-point arithmetic. -* -* P (input) INTEGER -* The number of base BETA digits in the mantissa of a -* floating-point value. -* -* EMIN (input) INTEGER -* The minimum exponent before (gradual) underflow. -* -* IEEE (input) LOGICAL -* A logical flag specifying whether or not the arithmetic -* system is thought to comply with the IEEE standard. -* -* EMAX (output) INTEGER -* The largest exponent before overflow -* -* RMAX (output) DOUBLE PRECISION -* The largest machine floating-point number. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP - DOUBLE PRECISION OLDY, RECBAS, Y, Z -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3 - EXTERNAL DLAMC3 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. -* .. Executable Statements .. -* -* First compute LEXP and UEXP, two powers of 2 that bound -* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum -* approximately to the bound that is closest to abs(EMIN). -* (EMAX is the exponent of the required number RMAX). -* - LEXP = 1 - EXBITS = 1 - 10 CONTINUE - TRY = LEXP*2 - IF( TRY.LE.( -EMIN ) ) THEN - LEXP = TRY - EXBITS = EXBITS + 1 - GO TO 10 - END IF - IF( LEXP.EQ.-EMIN ) THEN - UEXP = LEXP - ELSE - UEXP = TRY - EXBITS = EXBITS + 1 - END IF -* -* Now -LEXP is less than or equal to EMIN, and -UEXP is greater -* than or equal to EMIN. EXBITS is the number of bits needed to -* store the exponent. -* - IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN - EXPSUM = 2*LEXP - ELSE - EXPSUM = 2*UEXP - END IF -* -* EXPSUM is the exponent range, approximately equal to -* EMAX - EMIN + 1 . -* - EMAX = EXPSUM + EMIN - 1 - NBITS = 1 + EXBITS + P -* -* NBITS is the total number of bits needed to store a -* floating-point number. -* - IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN -* -* Either there are an odd number of bits used to store a -* floating-point number, which is unlikely, or some bits are -* not used in the representation of numbers, which is possible, -* (e.g. Cray machines) or the mantissa has an implicit bit, -* (e.g. IEEE machines, Dec Vax machines), which is perhaps the -* most likely. We have to assume the last alternative. -* If this is true, then we need to reduce EMAX by one because -* there must be some way of representing zero in an implicit-bit -* system. On machines like Cray, we are reducing EMAX by one -* unnecessarily. -* - EMAX = EMAX - 1 - END IF -* - IF( IEEE ) THEN -* -* Assume we are on an IEEE machine which reserves one exponent -* for infinity and NaN. -* - EMAX = EMAX - 1 - END IF -* -* Now create RMAX, the largest machine number, which should -* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . -* -* First compute 1.0 - BETA**(-P), being careful that the -* result is less than 1.0 . -* - RECBAS = ONE / BETA - Z = BETA - ONE - Y = ZERO - DO 20 I = 1, P - Z = Z*RECBAS - IF( Y.LT.ONE ) - $ OLDY = Y - Y = DLAMC3( Y, Z ) - 20 CONTINUE - IF( Y.GE.ONE ) - $ Y = OLDY -* -* Now multiply by BETA**EMAX to get RMAX. -* - DO 30 I = 1, EMAX - Y = DLAMC3( Y*BETA, ZERO ) - 30 CONTINUE -* - RMAX = Y - RETURN -* -* End of DLAMC5 -* - END diff --git a/mtx/blas_src/dscal.f b/mtx/blas_src/dscal.f deleted file mode 100644 index 3337de8e6..000000000 --- a/mtx/blas_src/dscal.f +++ /dev/null @@ -1,110 +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 one. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - DOUBLE PRECISION DA - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,M,MP1,NINCX -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - 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,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 diff --git a/mtx/blas_src/dswap.f b/mtx/blas_src/dswap.f deleted file mode 100644 index e567bd93e..000000000 --- a/mtx/blas_src/dswap.f +++ /dev/null @@ -1,122 +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 -*> -*> interchanges two vectors. -*> uses unrolled loops for increments equal one. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. 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 diff --git a/mtx/blas_src/dtbsv.f b/mtx/blas_src/dtbsv.f deleted file mode 100644 index 5e25a927b..000000000 --- a/mtx/blas_src/dtbsv.f +++ /dev/null @@ -1,401 +0,0 @@ -*> \brief \b DTBSV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) -* -* .. Scalar Arguments .. -* INTEGER INCX,K,LDA,N -* CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),X(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DTBSV solves one of the systems of equations -*> -*> A*x = b, or A**T*x = b, -*> -*> where b and x are n element vectors and A is an n by n unit, or -*> non-unit, upper or lower triangular band matrix, with ( k + 1 ) -*> diagonals. -*> -*> No test for singularity or near-singularity is included in this -*> routine. Such tests must be performed before calling this routine. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the matrix is an upper or -*> lower triangular matrix as follows: -*> -*> UPLO = 'U' or 'u' A is an upper triangular matrix. -*> -*> UPLO = 'L' or 'l' A is a lower triangular matrix. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the equations to be solved as -*> follows: -*> -*> TRANS = 'N' or 'n' A*x = b. -*> -*> TRANS = 'T' or 't' A**T*x = b. -*> -*> TRANS = 'C' or 'c' A**T*x = b. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> On entry, DIAG specifies whether or not A is unit -*> triangular as follows: -*> -*> DIAG = 'U' or 'u' A is assumed to be unit triangular. -*> -*> DIAG = 'N' or 'n' A is not assumed to be unit -*> triangular. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> On entry with UPLO = 'U' or 'u', K specifies the number of -*> super-diagonals of the matrix A. -*> On entry with UPLO = 'L' or 'l', K specifies the number of -*> sub-diagonals of the matrix A. -*> K must satisfy 0 .le. K. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array of DIMENSION ( LDA, n ). -*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -*> by n part of the array A must contain the upper triangular -*> band part of the matrix of coefficients, supplied column by -*> column, with the leading diagonal of the matrix in row -*> ( k + 1 ) of the array, the first super-diagonal starting at -*> position 2 in row k, and so on. The top left k by k triangle -*> of the array A is not referenced. -*> The following program segment will transfer an upper -*> triangular band matrix from conventional full matrix storage -*> to band storage: -*> -*> DO 20, J = 1, N -*> M = K + 1 - J -*> DO 10, I = MAX( 1, J - K ), J -*> A( M + I, J ) = matrix( I, J ) -*> 10 CONTINUE -*> 20 CONTINUE -*> -*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -*> by n part of the array A must contain the lower triangular -*> band part of the matrix of coefficients, supplied column by -*> column, with the leading diagonal of the matrix in row 1 of -*> the array, the first sub-diagonal starting at position 1 in -*> row 2, and so on. The bottom right k by k triangle of the -*> array A is not referenced. -*> The following program segment will transfer a lower -*> triangular band matrix from conventional full matrix storage -*> to band storage: -*> -*> DO 20, J = 1, N -*> M = 1 - J -*> DO 10, I = J, MIN( N, J + K ) -*> A( M + I, J ) = matrix( I, J ) -*> 10 CONTINUE -*> 20 CONTINUE -*> -*> Note that when DIAG = 'U' or 'u' the elements of the array A -*> corresponding to the diagonal elements of the matrix are not -*> referenced, but are assumed to be unity. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> ( k + 1 ). -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is DOUBLE PRECISION array of 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. -* -*> \date November 2011 -* -*> \ingroup double_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) -* -* -- Reference BLAS level2 routine (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INCX,K,LDA,N - CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER (ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L - LOGICAL NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX,MIN -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 2 - ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (K.LT.0) THEN - INFO = 5 - ELSE IF (LDA.LT. (K+1)) THEN - INFO = 7 - ELSE IF (INCX.EQ.0) THEN - INFO = 9 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTBSV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed by sequentially with one pass through A. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x := inv( A )*x. -* - IF (LSAME(UPLO,'U')) THEN - KPLUS1 = K + 1 - IF (INCX.EQ.1) THEN - DO 20 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - L = KPLUS1 - J - IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J) - TEMP = X(J) - DO 10 I = J - 1,MAX(1,J-K),-1 - X(I) = X(I) - TEMP*A(L+I,J) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 40 J = N,1,-1 - KX = KX - INCX - IF (X(JX).NE.ZERO) THEN - IX = KX - L = KPLUS1 - J - IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J) - TEMP = X(JX) - DO 30 I = J - 1,MAX(1,J-K),-1 - X(IX) = X(IX) - TEMP*A(L+I,J) - IX = IX - INCX - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 60 J = 1,N - IF (X(J).NE.ZERO) THEN - L = 1 - J - IF (NOUNIT) X(J) = X(J)/A(1,J) - TEMP = X(J) - DO 50 I = J + 1,MIN(N,J+K) - X(I) = X(I) - TEMP*A(L+I,J) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80 J = 1,N - KX = KX + INCX - IF (X(JX).NE.ZERO) THEN - IX = KX - L = 1 - J - IF (NOUNIT) X(JX) = X(JX)/A(1,J) - TEMP = X(JX) - DO 70 I = J + 1,MIN(N,J+K) - X(IX) = X(IX) - TEMP*A(L+I,J) - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A**T)*x. -* - IF (LSAME(UPLO,'U')) THEN - KPLUS1 = K + 1 - IF (INCX.EQ.1) THEN - DO 100 J = 1,N - TEMP = X(J) - L = KPLUS1 - J - DO 90 I = MAX(1,J-K),J - 1 - TEMP = TEMP - A(L+I,J)*X(I) - 90 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) - X(J) = TEMP - 100 CONTINUE - ELSE - JX = KX - DO 120 J = 1,N - TEMP = X(JX) - IX = KX - L = KPLUS1 - J - DO 110 I = MAX(1,J-K),J - 1 - TEMP = TEMP - A(L+I,J)*X(IX) - IX = IX + INCX - 110 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) - X(JX) = TEMP - JX = JX + INCX - IF (J.GT.K) KX = KX + INCX - 120 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 140 J = N,1,-1 - TEMP = X(J) - L = 1 - J - DO 130 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - A(L+I,J)*X(I) - 130 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(1,J) - X(J) = TEMP - 140 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 160 J = N,1,-1 - TEMP = X(JX) - IX = KX - L = 1 - J - DO 150 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - A(L+I,J)*X(IX) - IX = IX - INCX - 150 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(1,J) - X(JX) = TEMP - JX = JX - INCX - IF ((N-J).GE.K) KX = KX - INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTBSV . -* - END diff --git a/mtx/blas_src/dtrsm.f b/mtx/blas_src/dtrsm.f deleted file mode 100644 index 065df9a15..000000000 --- a/mtx/blas_src/dtrsm.f +++ /dev/null @@ -1,443 +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 of 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 of 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. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. 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/mtx/blas_src/dtrsv.f b/mtx/blas_src/dtrsv.f deleted file mode 100644 index e54303a93..000000000 --- a/mtx/blas_src/dtrsv.f +++ /dev/null @@ -1,338 +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 of 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 of 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. -* -*> \date November 2011 -* -*> \ingroup double_blas_level1 -* -* ===================================================================== - SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* -* -- Reference BLAS level1 routine (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. 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/mtx/blas_src/idamax.f b/mtx/blas_src/idamax.f deleted file mode 100644 index 4233fcc27..000000000 --- a/mtx/blas_src/idamax.f +++ /dev/null @@ -1,106 +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 element having max. absolute value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. 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 diff --git a/mtx/blas_src/ieeeck.f b/mtx/blas_src/ieeeck.f deleted file mode 100644 index 3c09fe95e..000000000 --- a/mtx/blas_src/ieeeck.f +++ /dev/null @@ -1,148 +0,0 @@ - INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1998 -* -* .. Scalar Arguments .. - INTEGER ISPEC - REAL ONE, ZERO -* .. -* -* Purpose -* ======= -* -* IEEECK is called from the ILAENV to verify that Infinity and -* possibly NaN arithmetic is safe (i.e. will not trap). -* -* Arguments -* ========= -* -* ISPEC (input) INTEGER -* Specifies whether to test just for inifinity arithmetic -* or whether to test for infinity and NaN arithmetic. -* = 0: Verify infinity arithmetic only. -* = 1: Verify infinity and NaN arithmetic. -* -* ZERO (input) REAL -* Must contain the value 0.0 -* This is passed to prevent the compiler from optimizing -* away this code. -* -* ONE (input) 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 -* -* .. 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*0.0 -* - 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/mtx/blas_src/ilaenv.f b/mtx/blas_src/ilaenv.f deleted file mode 100644 index 7263d6010..000000000 --- a/mtx/blas_src/ilaenv.f +++ /dev/null @@ -1,547 +0,0 @@ - INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, - $ N4 ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER*( * ) NAME, OPTS - INTEGER ISPEC, N1, N2, N3, N4 -* .. -* -* Purpose -* ======= -* -* ILAENV is called from the LAPACK routines to choose problem-dependent -* parameters for the local environment. See ISPEC for a description of -* the parameters. -* -* 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. -* -* Arguments -* ========= -* -* ISPEC (input) 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 -* = 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 and QZ methods -* for nonsymmetric eigenvalue problems. -* = 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 NaN arithmetic can be trusted not to trap -* =11: infinity arithmetic can be trusted not to trap -* -* NAME (input) CHARACTER*(*) -* The name of the calling subroutine, in either upper case or -* lower case. -* -* OPTS (input) 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'. -* -* N1 (input) INTEGER -* N2 (input) INTEGER -* N3 (input) INTEGER -* N4 (input) INTEGER -* Problem dimensions for the subroutine NAME; these may not all -* be required. -* -* (ILAENV) (output) INTEGER -* >= 0: the value of the parameter specified by ISPEC -* < 0: if ILAENV = -k, the k-th argument had an illegal value. -* -* Further Details -* =============== -* -* 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 ) -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL CNAME, SNAME - CHARACTER*1 C1 - CHARACTER*2 C2, C4 - CHARACTER*3 C3 - CHARACTER*6 SUBNAM - INTEGER I, IC, IZ, NB, NBMIN, NX -* .. -* .. Intrinsic Functions .. - INTRINSIC CHAR, ICHAR, INT, MIN, REAL -* .. -* .. External Functions .. - INTEGER IEEECK - EXTERNAL IEEECK -* .. -* .. Executable Statements .. -* - GO TO ( 100, 100, 100, 400, 500, 600, 700, 800, 900, 1000, - $ 1100 ) ISPEC -* -* Invalid value for ISPEC -* - ILAENV = -1 - RETURN -* - 100 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 10 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) - IF( IC.GE.97 .AND. IC.LE.122 ) - $ SUBNAM( I:I ) = CHAR( IC-32 ) - 10 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 20 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 ) - 20 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 30 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) - IF( IC.GE.225 .AND. IC.LE.250 ) - $ SUBNAM( I:I ) = CHAR( IC-32 ) - 30 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 ) -* - GO TO ( 110, 200, 300 ) ISPEC -* - 110 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( 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.'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 - NB = 64 - ELSE - NB = 64 - 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 - NB = 64 - 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 - END IF - ELSE IF( C2.EQ.'LA' ) THEN - IF( C3.EQ.'UUM' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN - IF( C3.EQ.'EBZ' ) THEN - NB = 1 - END IF - END IF - ILAENV = NB - RETURN -* - 200 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 - END IF - ILAENV = NBMIN - RETURN -* - 300 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 - END IF - ILAENV = NX - RETURN -* - 400 CONTINUE -* -* ISPEC = 4: number of shifts (used by xHSEQR) -* - ILAENV = 6 - RETURN -* - 500 CONTINUE -* -* ISPEC = 5: minimum column dimension (not used) -* - ILAENV = 2 - RETURN -* - 600 CONTINUE -* -* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) -* - ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) - RETURN -* - 700 CONTINUE -* -* ISPEC = 7: number of processors (not used) -* - ILAENV = 1 - RETURN -* - 800 CONTINUE -* -* ISPEC = 8: crossover point for multishift (used by xHSEQR) -* - ILAENV = 50 - RETURN -* - 900 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 -* - 1000 CONTINUE -* -* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap -* -C ILAENV = 0 - ILAENV = 1 - IF( ILAENV.EQ.1 ) THEN - ILAENV = IEEECK( 0, 0.0, 1.0 ) - END IF - RETURN -* - 1100 CONTINUE -* -* ISPEC = 11: infinity arithmetic can be trusted not to trap -* -C ILAENV = 0 - ILAENV = 1 - IF( ILAENV.EQ.1 ) THEN - ILAENV = IEEECK( 1, 0.0, 1.0 ) - END IF - RETURN -* -* End of ILAENV -* - END diff --git a/mtx/blas_src/isamax.f b/mtx/blas_src/isamax.f deleted file mode 100644 index af977c594..000000000 --- a/mtx/blas_src/isamax.f +++ /dev/null @@ -1,106 +0,0 @@ -*> \brief \b ISAMAX -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* INTEGER FUNCTION ISAMAX(N,SX,INCX) -* -* .. Scalar Arguments .. -* INTEGER INCX,N -* .. -* .. Array Arguments .. -* REAL SX(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ISAMAX finds the index of element having max. absolute value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup aux_blas -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, linpack, 3/11/78. -*> modified 3/93 to return if incx .le. 0. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - INTEGER FUNCTION ISAMAX(N,SX,INCX) -* -* -- Reference BLAS level1 routine (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - REAL SX(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - REAL SMAX - INTEGER I,IX -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. - ISAMAX = 0 - IF (N.LT.1 .OR. INCX.LE.0) RETURN - ISAMAX = 1 - IF (N.EQ.1) RETURN - IF (INCX.EQ.1) THEN -* -* code for increment equal to 1 -* - SMAX = ABS(SX(1)) - DO I = 2,N - IF (ABS(SX(I)).GT.SMAX) THEN - ISAMAX = I - SMAX = ABS(SX(I)) - END IF - END DO - ELSE -* -* code for increment not equal to 1 -* - IX = 1 - SMAX = ABS(SX(1)) - IX = IX + INCX - DO I = 2,N - IF (ABS(SX(IX)).GT.SMAX) THEN - ISAMAX = I - SMAX = ABS(SX(IX)) - END IF - IX = IX + INCX - END DO - END IF - RETURN - END diff --git a/mtx/blas_src/lsame.f b/mtx/blas_src/lsame.f deleted file mode 100644 index f19f9cda9..000000000 --- a/mtx/blas_src/lsame.f +++ /dev/null @@ -1,125 +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. -* -*> \date November 2011 -* -*> \ingroup aux_blas -* -* ===================================================================== - LOGICAL FUNCTION LSAME(CA,CB) -* -* -- Reference BLAS level1 routine (version 3.1) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. 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/mtx/blas_src/sgemm.f b/mtx/blas_src/sgemm.f deleted file mode 100644 index 9a3d9e1ad..000000000 --- a/mtx/blas_src/sgemm.f +++ /dev/null @@ -1,388 +0,0 @@ -*> \brief \b SGEMM -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* .. Scalar Arguments .. -* REAL ALPHA,BETA -* INTEGER K,LDA,LDB,LDC,M,N -* CHARACTER TRANSA,TRANSB -* .. -* .. Array Arguments .. -* REAL A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> SGEMM performs one of the matrix-matrix operations -*> -*> C := alpha*op( A )*op( B ) + beta*C, -*> -*> where op( X ) is one of -*> -*> op( X ) = X or op( X ) = X**T, -*> -*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) -*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] TRANSA -*> \verbatim -*> TRANSA is CHARACTER*1 -*> On entry, TRANSA specifies the form of op( A ) to be used in -*> the matrix multiplication as follows: -*> -*> TRANSA = 'N' or 'n', op( A ) = A. -*> -*> TRANSA = 'T' or 't', op( A ) = A**T. -*> -*> TRANSA = 'C' or 'c', op( A ) = A**T. -*> \endverbatim -*> -*> \param[in] TRANSB -*> \verbatim -*> TRANSB is CHARACTER*1 -*> On entry, TRANSB specifies the form of op( B ) to be used in -*> the matrix multiplication as follows: -*> -*> TRANSB = 'N' or 'n', op( B ) = B. -*> -*> TRANSB = 'T' or 't', op( B ) = B**T. -*> -*> TRANSB = 'C' or 'c', op( B ) = B**T. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of the matrix -*> op( A ) and of the matrix C. M must be at least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of the matrix -*> op( B ) and the number of columns of the matrix C. N must be -*> at least zero. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> On entry, K specifies the number of columns of the matrix -*> op( A ) and the number of rows of the matrix op( B ). K must -*> be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is REAL -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is REAL array of DIMENSION ( LDA, ka ), where ka is -*> k when TRANSA = 'N' or 'n', and is m otherwise. -*> Before entry with TRANSA = 'N' or 'n', the leading m by k -*> part of the array A must contain the matrix A, otherwise -*> the leading k by m part of the array A must contain the -*> matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. When TRANSA = 'N' or 'n' then -*> LDA must be at least max( 1, m ), otherwise LDA must be at -*> least max( 1, k ). -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is REAL array of DIMENSION ( LDB, kb ), where kb is -*> n when TRANSB = 'N' or 'n', and is k otherwise. -*> Before entry with TRANSB = 'N' or 'n', the leading k by n -*> part of the array B must contain the matrix B, otherwise -*> the leading n by k part of the array B must contain the -*> matrix B. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> On entry, LDB specifies the first dimension of B as declared -*> in the calling (sub) program. When TRANSB = 'N' or 'n' then -*> LDB must be at least max( 1, k ), otherwise LDB must be at -*> least max( 1, n ). -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is REAL -*> On entry, BETA specifies the scalar beta. When BETA is -*> supplied as zero then C need not be set on input. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is REAL array of 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. -* -*> \date November 2011 -* -*> \ingroup single_blas_level3 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 3 Blas routine. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* -- Reference BLAS level3 routine (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - REAL ALPHA,BETA - INTEGER K,LDA,LDB,LDC,M,N - CHARACTER TRANSA,TRANSB -* .. -* .. Array Arguments .. - REAL A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - REAL TEMP - INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB - LOGICAL NOTA,NOTB -* .. -* .. Parameters .. - REAL ONE,ZERO - PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) -* .. -* -* Set NOTA and NOTB as true if A and B respectively are not -* transposed and set NROWA, NCOLA and NROWB as the number of rows -* and columns of A and the number of rows of B respectively. -* - NOTA = LSAME(TRANSA,'N') - NOTB = LSAME(TRANSB,'N') - IF (NOTA) THEN - NROWA = M - NCOLA = K - ELSE - NROWA = K - NCOLA = M - END IF - IF (NOTB) THEN - NROWB = K - ELSE - NROWB = N - END IF -* -* Test the input parameters. -* - INFO = 0 - IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. - + (.NOT.LSAME(TRANSA,'T'))) THEN - INFO = 1 - ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. - + (.NOT.LSAME(TRANSB,'T'))) THEN - INFO = 2 - ELSE IF (M.LT.0) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (K.LT.0) THEN - INFO = 5 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 8 - ELSE IF (LDB.LT.MAX(1,NROWB)) THEN - INFO = 10 - ELSE IF (LDC.LT.MAX(1,M)) THEN - INFO = 13 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('SGEMM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. - + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN -* -* And if alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - IF (BETA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - C(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1,N - DO 30 I = 1,M - C(I,J) = BETA*C(I,J) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF (NOTB) THEN - IF (NOTA) THEN -* -* Form C := alpha*A*B + beta*C. -* - DO 90 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 50 I = 1,M - C(I,J) = ZERO - 50 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 60 I = 1,M - C(I,J) = BETA*C(I,J) - 60 CONTINUE - END IF - DO 80 L = 1,K - IF (B(L,J).NE.ZERO) THEN - TEMP = ALPHA*B(L,J) - DO 70 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 70 CONTINUE - END IF - 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 - IF (B(J,L).NE.ZERO) THEN - TEMP = ALPHA*B(J,L) - DO 150 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 150 CONTINUE - END IF - 160 CONTINUE - 170 CONTINUE - ELSE -* -* Form C := alpha*A**T*B**T + beta*C -* - DO 200 J = 1,N - DO 190 I = 1,M - TEMP = ZERO - DO 180 L = 1,K - TEMP = TEMP + A(L,I)*B(J,L) - 180 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 190 CONTINUE - 200 CONTINUE - END IF - END IF -* - RETURN -* -* End of SGEMM . -* - END diff --git a/mtx/blas_src/sger.f b/mtx/blas_src/sger.f deleted file mode 100644 index cf85ffdc0..000000000 --- a/mtx/blas_src/sger.f +++ /dev/null @@ -1,227 +0,0 @@ -*> \brief \b SGER -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* -* .. Scalar Arguments .. -* REAL ALPHA -* INTEGER INCX,INCY,LDA,M,N -* .. -* .. Array Arguments .. -* REAL A(LDA,*),X(*),Y(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> SGER performs the rank 1 operation -*> -*> A := alpha*x*y**T + A, -*> -*> where alpha is a scalar, x is an m element vector, y is an n element -*> vector and A is an m by n matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of the matrix A. -*> M must be at least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is REAL -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is REAL array of dimension at least -*> ( 1 + ( m - 1 )*abs( INCX ) ). -*> Before entry, the incremented array X must contain the m -*> element vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -*> -*> \param[in] Y -*> \verbatim -*> Y is REAL array of dimension at least -*> ( 1 + ( n - 1 )*abs( INCY ) ). -*> Before entry, the incremented array Y must contain the n -*> element vector y. -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> On entry, INCY specifies the increment for the elements of -*> Y. INCY must not be zero. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is REAL array of 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. -* -*> \date November 2011 -* -*> \ingroup single_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* -* -- Reference BLAS level2 routine (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - REAL ALPHA - INTEGER INCX,INCY,LDA,M,N -* .. -* .. Array Arguments .. - REAL A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - REAL ZERO - PARAMETER (ZERO=0.0E+0) -* .. -* .. Local Scalars .. - REAL TEMP - INTEGER I,INFO,IX,J,JY,KX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (M.LT.0) THEN - INFO = 1 - ELSE IF (N.LT.0) THEN - INFO = 2 - ELSE IF (INCX.EQ.0) THEN - INFO = 5 - ELSE IF (INCY.EQ.0) THEN - INFO = 7 - ELSE IF (LDA.LT.MAX(1,M)) THEN - INFO = 9 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('SGER ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF (INCY.GT.0) THEN - JY = 1 - ELSE - JY = 1 - (N-1)*INCY - END IF - IF (INCX.EQ.1) THEN - DO 20 J = 1,N - IF (Y(JY).NE.ZERO) THEN - TEMP = ALPHA*Y(JY) - DO 10 I = 1,M - A(I,J) = A(I,J) + X(I)*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (M-1)*INCX - END IF - DO 40 J = 1,N - IF (Y(JY).NE.ZERO) THEN - TEMP = ALPHA*Y(JY) - IX = KX - DO 30 I = 1,M - A(I,J) = A(I,J) + X(IX)*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of SGER . -* - END diff --git a/mtx/blas_src/slamch.f b/mtx/blas_src/slamch.f deleted file mode 100644 index 9b7da1f74..000000000 --- a/mtx/blas_src/slamch.f +++ /dev/null @@ -1,857 +0,0 @@ - REAL FUNCTION SLAMCH( CMACH ) -* -* -- LAPACK auxiliary routine (version 1.1) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER CMACH -* .. -* -* Purpose -* ======= -* -* SLAMCH determines single precision machine parameters. -* -* Arguments -* ========= -* -* CMACH (input) CHARACTER*1 -* Specifies the value to be returned by SLAMCH: -* = 'E' or 'e', SLAMCH := eps -* = 'S' or 's , SLAMCH := sfmin -* = 'B' or 'b', SLAMCH := base -* = 'P' or 'p', SLAMCH := eps*base -* = 'N' or 'n', SLAMCH := t -* = 'R' or 'r', SLAMCH := rnd -* = 'M' or 'm', SLAMCH := emin -* = 'U' or 'u', SLAMCH := rmin -* = 'L' or 'l', SLAMCH := emax -* = 'O' or 'o', SLAMCH := rmax -* -* where -* -* eps = relative machine precision -* sfmin = safe minimum, such that 1/sfmin does not overflow -* base = base of the machine -* prec = eps*base -* t = number of (base) digits in the mantissa -* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise -* emin = minimum exponent before (gradual) underflow -* rmin = underflow threshold - base**(emin-1) -* emax = largest exponent before overflow -* rmax = overflow threshold - (base**emax)*(1-eps) -* -* ===================================================================== -* -* .. Parameters .. - REAL ONE, ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. -* .. Local Scalars .. - LOGICAL FIRST, LRND - INTEGER BETA, IMAX, IMIN, IT - REAL BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, - $ RND, SFMIN, SMALL, T -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL SLAMC2 -* .. -* .. Save statement .. - SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, - $ EMAX, RMAX, PREC -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / -* .. -* .. Executable Statements .. -* - IF( FIRST ) THEN - FIRST = .FALSE. - CALL SLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) - BASE = BETA - T = IT - IF( LRND ) THEN - RND = ONE - EPS = ( BASE**( 1-IT ) ) / 2 - ELSE - RND = ZERO - EPS = BASE**( 1-IT ) - END IF - PREC = EPS*BASE - EMIN = IMIN - EMAX = IMAX - SFMIN = RMIN - SMALL = ONE / RMAX - 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 - END IF -* - IF( LSAME( CMACH, 'E' ) ) THEN - RMACH = EPS - ELSE IF( LSAME( CMACH, 'S' ) ) THEN - RMACH = SFMIN - ELSE IF( LSAME( CMACH, 'B' ) ) THEN - RMACH = BASE - ELSE IF( LSAME( CMACH, 'P' ) ) THEN - RMACH = PREC - ELSE IF( LSAME( CMACH, 'N' ) ) THEN - RMACH = T - ELSE IF( LSAME( CMACH, 'R' ) ) THEN - RMACH = RND - ELSE IF( LSAME( CMACH, 'M' ) ) THEN - RMACH = EMIN - ELSE IF( LSAME( CMACH, 'U' ) ) THEN - RMACH = RMIN - ELSE IF( LSAME( CMACH, 'L' ) ) THEN - RMACH = EMAX - ELSE IF( LSAME( CMACH, 'O' ) ) THEN - RMACH = RMAX - END IF -* - SLAMCH = RMACH - RETURN -* -* End of SLAMCH -* - END -* -************************************************************************ -* - SUBROUTINE SLAMC1( BETA, T, RND, IEEE1 ) -* -* -- LAPACK auxiliary routine (version 1.1) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - LOGICAL IEEE1, RND - INTEGER BETA, T -* .. -* -* Purpose -* ======= -* -* SLAMC1 determines the machine parameters given by BETA, T, RND, and -* IEEE1. -* -* Arguments -* ========= -* -* BETA (output) INTEGER -* The base of the machine. -* -* T (output) INTEGER -* The number of ( BETA ) digits in the mantissa. -* -* RND (output) LOGICAL -* Specifies whether proper rounding ( RND = .TRUE. ) or -* chopping ( RND = .FALSE. ) occurs in addition. This may not -* be a reliable guide to the way in which the machine performs -* its arithmetic. -* -* IEEE1 (output) LOGICAL -* Specifies whether rounding appears to be done in the IEEE -* 'round to nearest' style. -* -* Further Details -* =============== -* -* The routine is based on the routine ENVRON by Malcolm and -* incorporates suggestions by Gentleman and Marovich. See -* -* Malcolm M. A. (1972) Algorithms to reveal properties of -* floating-point arithmetic. Comms. of the ACM, 15, 949-951. -* -* Gentleman W. M. and Marovich S. B. (1974) More on algorithms -* that reveal properties of floating point arithmetic units. -* Comms. of the ACM, 17, 276-277. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL FIRST, LIEEE1, LRND - INTEGER LBETA, LT - REAL A, B, C, F, ONE, QTR, SAVEC, T1, T2 -* .. -* .. External Functions .. - REAL SLAMC3 - EXTERNAL SLAMC3 -* .. -* .. Save statement .. - SAVE FIRST, LIEEE1, LBETA, LRND, LT -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / -* .. -* .. Executable Statements .. -* - IF( FIRST ) THEN - FIRST = .FALSE. - ONE = 1 -* -* LBETA, LIEEE1, LT and LRND are the local values of BETA, -* IEEE1, T and RND. -* -* Throughout this routine we use the function SLAMC3 to ensure -* that relevant values are stored and not held in registers, or -* are not affected by optimizers. -* -* Compute a = 2.0**m with the smallest positive integer m such -* that -* -* fl( a + 1.0 ) = a. -* - A = 1 - C = 1 -* -*+ WHILE( C.EQ.ONE )LOOP - 10 CONTINUE - IF( C.EQ.ONE ) THEN - A = 2*A - C = SLAMC3( A, ONE ) - C = SLAMC3( C, -A ) - GO TO 10 - END IF -*+ END WHILE -* -* Now compute b = 2.0**m with the smallest positive integer m -* such that -* -* fl( a + b ) .gt. a. -* - B = 1 - C = SLAMC3( A, B ) -* -*+ WHILE( C.EQ.A )LOOP - 20 CONTINUE - IF( C.EQ.A ) THEN - B = 2*B - C = SLAMC3( A, B ) - GO TO 20 - END IF -*+ END WHILE -* -* Now compute the base. a and c are neighbouring floating point -* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so -* their difference is beta. Adding 0.25 to c is to ensure that it -* is truncated to beta and not ( beta - 1 ). -* - QTR = ONE / 4 - SAVEC = C - C = SLAMC3( C, -A ) - LBETA = C + QTR -* -* Now determine whether rounding or chopping occurs, by adding a -* bit less than beta/2 and a bit more than beta/2 to a. -* - B = LBETA - F = SLAMC3( B / 2, -B / 100 ) - C = SLAMC3( F, A ) - IF( C.EQ.A ) THEN - LRND = .TRUE. - ELSE - LRND = .FALSE. - END IF - F = SLAMC3( B / 2, B / 100 ) - C = SLAMC3( F, A ) - IF( ( LRND ) .AND. ( C.EQ.A ) ) - $ LRND = .FALSE. -* -* Try and decide whether rounding is done in the IEEE 'round to -* nearest' style. B/2 is half a unit in the last place of the two -* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit -* zero, and SAVEC is odd. Thus adding B/2 to A should not change -* A, but adding B/2 to SAVEC should change SAVEC. -* - T1 = SLAMC3( B / 2, A ) - T2 = SLAMC3( B / 2, SAVEC ) - LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND -* -* Now find the mantissa, t. It should be the integer part of -* log to the base beta of a, however it is safer to determine t -* by powering. So we find t as the smallest positive integer for -* which -* -* fl( beta**t + 1.0 ) = 1.0. -* - LT = 0 - A = 1 - C = 1 -* -*+ WHILE( C.EQ.ONE )LOOP - 30 CONTINUE - IF( C.EQ.ONE ) THEN - LT = LT + 1 - A = A*LBETA - C = SLAMC3( A, ONE ) - C = SLAMC3( C, -A ) - GO TO 30 - END IF -*+ END WHILE -* - END IF -* - BETA = LBETA - T = LT - RND = LRND - IEEE1 = LIEEE1 - RETURN -* -* End of SLAMC1 -* - END -* -************************************************************************ -* - SUBROUTINE SLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) -* -* -- LAPACK auxiliary routine (version 1.1) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - LOGICAL RND - INTEGER BETA, EMAX, EMIN, T - REAL EPS, RMAX, RMIN -* .. -* -* Purpose -* ======= -* -* SLAMC2 determines the machine parameters specified in its argument -* list. -* -* Arguments -* ========= -* -* BETA (output) INTEGER -* The base of the machine. -* -* T (output) INTEGER -* The number of ( BETA ) digits in the mantissa. -* -* RND (output) LOGICAL -* Specifies whether proper rounding ( RND = .TRUE. ) or -* chopping ( RND = .FALSE. ) occurs in addition. This may not -* be a reliable guide to the way in which the machine performs -* its arithmetic. -* -* EPS (output) REAL -* The smallest positive number such that -* -* fl( 1.0 - EPS ) .LT. 1.0, -* -* where fl denotes the computed value. -* -* EMIN (output) INTEGER -* The minimum exponent before (gradual) underflow occurs. -* -* RMIN (output) REAL -* The smallest normalized number for the machine, given by -* BASE**( EMIN - 1 ), where BASE is the floating point value -* of BETA. -* -* EMAX (output) INTEGER -* The maximum exponent before overflow occurs. -* -* RMAX (output) REAL -* The largest positive number for the machine, given by -* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point -* value of BETA. -* -* Further Details -* =============== -* -* The computation of EPS is based on a routine PARANOIA by -* W. Kahan of the University of California at Berkeley. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND - INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, - $ NGNMIN, NGPMIN - REAL A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, - $ SIXTH, SMALL, THIRD, TWO, ZERO -* .. -* .. External Functions .. - REAL SLAMC3 - EXTERNAL SLAMC3 -* .. -* .. External Subroutines .. - EXTERNAL SLAMC1, SLAMC4, SLAMC5 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. Save statement .. - SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, - $ LRMIN, LT -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / , IWARN / .FALSE. / -* .. -* .. Executable Statements .. -* - IF( FIRST ) THEN - FIRST = .FALSE. - ZERO = 0 - ONE = 1 - TWO = 2 -* -* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of -* BETA, T, RND, EPS, EMIN and RMIN. -* -* Throughout this routine we use the function SLAMC3 to ensure -* that relevant values are stored and not held in registers, or -* are not affected by optimizers. -* -* SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. -* - CALL SLAMC1( LBETA, LT, LRND, LIEEE1 ) -* -* Start to find EPS. -* - B = LBETA - A = B**( -LT ) - LEPS = A -* -* Try some tricks to see whether or not this is the correct EPS. -* - B = TWO / 3 - HALF = ONE / 2 - SIXTH = SLAMC3( B, -HALF ) - THIRD = SLAMC3( SIXTH, SIXTH ) - B = SLAMC3( THIRD, -HALF ) - B = SLAMC3( B, SIXTH ) - B = ABS( B ) - IF( B.LT.LEPS ) - $ B = LEPS -* - LEPS = 1 -* -*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP - 10 CONTINUE - IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN - LEPS = B - C = SLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) - C = SLAMC3( HALF, -C ) - B = SLAMC3( HALF, C ) - C = SLAMC3( HALF, -B ) - B = SLAMC3( HALF, C ) - GO TO 10 - END IF -*+ END WHILE -* - IF( A.LT.LEPS ) - $ LEPS = A -* -* Computation of EPS complete. -* -* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). -* Keep dividing A by BETA until (gradual) underflow occurs. This -* is detected when we cannot recover the previous A. -* - RBASE = ONE / LBETA - SMALL = ONE - DO 20 I = 1, 3 - SMALL = SLAMC3( SMALL*RBASE, ZERO ) - 20 CONTINUE - A = SLAMC3( ONE, SMALL ) - CALL SLAMC4( NGPMIN, ONE, LBETA ) - CALL SLAMC4( NGNMIN, -ONE, LBETA ) - CALL SLAMC4( GPMIN, A, LBETA ) - CALL SLAMC4( GNMIN, -A, LBETA ) - IEEE = .FALSE. -* - IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN - IF( NGPMIN.EQ.GPMIN ) THEN - LEMIN = NGPMIN -* ( Non twos-complement machines, no gradual underflow; -* e.g., VAX ) - ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN - LEMIN = NGPMIN - 1 + LT - IEEE = .TRUE. -* ( Non twos-complement machines, with gradual underflow; -* e.g., IEEE standard followers ) - ELSE - LEMIN = MIN( NGPMIN, GPMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -* - ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN - IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN - LEMIN = MAX( NGPMIN, NGNMIN ) -* ( Twos-complement machines, no gradual underflow; -* e.g., CYBER 205 ) - ELSE - LEMIN = MIN( NGPMIN, NGNMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -* - ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. - $ ( GPMIN.EQ.GNMIN ) ) THEN - IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN - LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT -* ( Twos-complement machines with gradual underflow; -* no known machine ) - ELSE - LEMIN = MIN( NGPMIN, NGNMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -* - ELSE - LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -*** -* Comment out this if block if EMIN is ok - IF( IWARN ) THEN - FIRST = .TRUE. - WRITE( 6, FMT = 9999 )LEMIN - END IF -*** -* -* Assume IEEE arithmetic if we found denormalised numbers above, -* or if arithmetic seems to round in the IEEE style, determined -* in routine SLAMC1. A true IEEE machine should have both things -* true; however, faulty machines may have one or the other. -* - IEEE = IEEE .OR. LIEEE1 -* -* Compute RMIN by successive division by BETA. We could compute -* RMIN as BASE**( EMIN - 1 ), but some machines underflow during -* this computation. -* - LRMIN = 1 - DO 30 I = 1, 1 - LEMIN - LRMIN = SLAMC3( LRMIN*RBASE, ZERO ) - 30 CONTINUE -* -* Finally, call SLAMC5 to compute EMAX and RMAX. -* - CALL SLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) - END IF -* - BETA = LBETA - T = LT - RND = LRND - EPS = LEPS - EMIN = LEMIN - RMIN = LRMIN - EMAX = LEMAX - RMAX = LRMAX -* - RETURN -* - 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', - $ ' EMIN = ', I8, / - $ ' If, after inspection, the value EMIN looks', - $ ' acceptable please comment out ', - $ / ' the IF block as marked within the code of routine', - $ ' SLAMC2,', / ' otherwise supply EMIN explicitly.', / ) -* -* End of SLAMC2 -* - END -* -************************************************************************ -* - REAL FUNCTION SLAMC3( A, B ) -* -* -- LAPACK auxiliary routine (version 1.1) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - REAL A, B -* .. -* -* Purpose -* ======= -* -* SLAMC3 is intended to force A and B to be stored prior to doing -* the addition of A and B , for use in situations where optimizers -* might hold one of these in a register. -* -* Arguments -* ========= -* -* A, B (input) REAL -* The values A and B. -* -* ===================================================================== -* -* .. Executable Statements .. -* - SLAMC3 = A + B -* - RETURN -* -* End of SLAMC3 -* - END -* -************************************************************************ -* - SUBROUTINE SLAMC4( EMIN, START, BASE ) -* -* -- LAPACK auxiliary routine (version 1.1) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - INTEGER BASE, EMIN - REAL START -* .. -* -* Purpose -* ======= -* -* SLAMC4 is a service routine for SLAMC2. -* -* Arguments -* ========= -* -* EMIN (output) EMIN -* The minimum exponent before (gradual) underflow, computed by -* setting A = START and dividing by BASE until the previous A -* can not be recovered. -* -* START (input) REAL -* The starting point for determining EMIN. -* -* BASE (input) INTEGER -* The base of the machine. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I - REAL A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO -* .. -* .. External Functions .. - REAL SLAMC3 - EXTERNAL SLAMC3 -* .. -* .. Executable Statements .. -* - A = START - ONE = 1 - RBASE = ONE / BASE - ZERO = 0 - EMIN = 1 - B1 = SLAMC3( A*RBASE, ZERO ) - C1 = A - C2 = A - D1 = A - D2 = A -*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. -* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP - 10 CONTINUE - IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. - $ ( D2.EQ.A ) ) THEN - EMIN = EMIN - 1 - A = B1 - B1 = SLAMC3( A / BASE, ZERO ) - C1 = SLAMC3( B1*BASE, ZERO ) - D1 = ZERO - DO 20 I = 1, BASE - D1 = D1 + B1 - 20 CONTINUE - B2 = SLAMC3( A*RBASE, ZERO ) - C2 = SLAMC3( B2 / RBASE, ZERO ) - D2 = ZERO - DO 30 I = 1, BASE - D2 = D2 + B2 - 30 CONTINUE - GO TO 10 - END IF -*+ END WHILE -* - RETURN -* -* End of SLAMC4 -* - END -* -************************************************************************ -* - SUBROUTINE SLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) -* -* -- LAPACK auxiliary routine (version 1.1) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - LOGICAL IEEE - INTEGER BETA, EMAX, EMIN, P - REAL RMAX -* .. -* -* Purpose -* ======= -* -* SLAMC5 attempts to compute RMAX, the largest machine floating-point -* number, without overflow. It assumes that EMAX + abs(EMIN) sum -* approximately to a power of 2. It will fail on machines where this -* assumption does not hold, for example, the Cyber 205 (EMIN = -28625, -* EMAX = 28718). It will also fail if the value supplied for EMIN is -* too large (i.e. too close to zero), probably with overflow. -* -* Arguments -* ========= -* -* BETA (input) INTEGER -* The base of floating-point arithmetic. -* -* P (input) INTEGER -* The number of base BETA digits in the mantissa of a -* floating-point value. -* -* EMIN (input) INTEGER -* The minimum exponent before (gradual) underflow. -* -* IEEE (input) LOGICAL -* A logical flag specifying whether or not the arithmetic -* system is thought to comply with the IEEE standard. -* -* EMAX (output) INTEGER -* The largest exponent before overflow -* -* RMAX (output) REAL -* The largest machine floating-point number. -* -* ===================================================================== -* -* .. Parameters .. - REAL ZERO, ONE - PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) -* .. -* .. Local Scalars .. - INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP - REAL OLDY, RECBAS, Y, Z -* .. -* .. External Functions .. - REAL SLAMC3 - EXTERNAL SLAMC3 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. -* .. Executable Statements .. -* -* First compute LEXP and UEXP, two powers of 2 that bound -* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum -* approximately to the bound that is closest to abs(EMIN). -* (EMAX is the exponent of the required number RMAX). -* - LEXP = 1 - EXBITS = 1 - 10 CONTINUE - TRY = LEXP*2 - IF( TRY.LE.( -EMIN ) ) THEN - LEXP = TRY - EXBITS = EXBITS + 1 - GO TO 10 - END IF - IF( LEXP.EQ.-EMIN ) THEN - UEXP = LEXP - ELSE - UEXP = TRY - EXBITS = EXBITS + 1 - END IF -* -* Now -LEXP is less than or equal to EMIN, and -UEXP is greater -* than or equal to EMIN. EXBITS is the number of bits needed to -* store the exponent. -* - IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN - EXPSUM = 2*LEXP - ELSE - EXPSUM = 2*UEXP - END IF -* -* EXPSUM is the exponent range, approximately equal to -* EMAX - EMIN + 1 . -* - EMAX = EXPSUM + EMIN - 1 - NBITS = 1 + EXBITS + P -* -* NBITS is the total number of bits needed to store a -* floating-point number. -* - IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN -* -* Either there are an odd number of bits used to store a -* floating-point number, which is unlikely, or some bits are -* not used in the representation of numbers, which is possible, -* (e.g. Cray machines) or the mantissa has an implicit bit, -* (e.g. IEEE machines, Dec Vax machines), which is perhaps the -* most likely. We have to assume the last alternative. -* If this is true, then we need to reduce EMAX by one because -* there must be some way of representing zero in an implicit-bit -* system. On machines like Cray, we are reducing EMAX by one -* unnecessarily. -* - EMAX = EMAX - 1 - END IF -* - IF( IEEE ) THEN -* -* Assume we are on an IEEE machine which reserves one exponent -* for infinity and NaN. -* - EMAX = EMAX - 1 - END IF -* -* Now create RMAX, the largest machine number, which should -* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . -* -* First compute 1.0 - BETA**(-P), being careful that the -* result is less than 1.0 . -* - RECBAS = ONE / BETA - Z = BETA - ONE - Y = ZERO - DO 20 I = 1, P - Z = Z*RECBAS - IF( Y.LT.ONE ) - $ OLDY = Y - Y = SLAMC3( Y, Z ) - 20 CONTINUE - IF( Y.GE.ONE ) - $ Y = OLDY -* -* Now multiply by BETA**EMAX to get RMAX. -* - DO 30 I = 1, EMAX - Y = SLAMC3( Y*BETA, ZERO ) - 30 CONTINUE -* - RMAX = Y - RETURN -* -* End of SLAMC5 -* - END diff --git a/mtx/blas_src/sscal.f b/mtx/blas_src/sscal.f deleted file mode 100644 index b4b086252..000000000 --- a/mtx/blas_src/sscal.f +++ /dev/null @@ -1,110 +0,0 @@ -*> \brief \b SSCAL -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE SSCAL(N,SA,SX,INCX) -* -* .. Scalar Arguments .. -* REAL SA -* INTEGER INCX,N -* .. -* .. Array Arguments .. -* REAL SX(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> scales a vector by a constant. -*> uses unrolled loops for increment equal to 1. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup single_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, linpack, 3/11/78. -*> modified 3/93 to return if incx .le. 0. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE SSCAL(N,SA,SX,INCX) -* -* -- Reference BLAS level1 routine (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - REAL SA - INTEGER INCX,N -* .. -* .. Array Arguments .. - REAL SX(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,M,MP1,NINCX -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - 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,5) - IF (M.NE.0) THEN - DO I = 1,M - SX(I) = SA*SX(I) - END DO - IF (N.LT.5) RETURN - END IF - MP1 = M + 1 - DO I = MP1,N,5 - SX(I) = SA*SX(I) - SX(I+1) = SA*SX(I+1) - SX(I+2) = SA*SX(I+2) - SX(I+3) = SA*SX(I+3) - SX(I+4) = SA*SX(I+4) - END DO - ELSE -* -* code for increment not equal to 1 -* - NINCX = N*INCX - DO I = 1,NINCX,INCX - SX(I) = SA*SX(I) - END DO - END IF - RETURN - END diff --git a/mtx/blas_src/sswap.f b/mtx/blas_src/sswap.f deleted file mode 100644 index ad5a7f5c6..000000000 --- a/mtx/blas_src/sswap.f +++ /dev/null @@ -1,122 +0,0 @@ -*> \brief \b SSWAP -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE SSWAP(N,SX,INCX,SY,INCY) -* -* .. Scalar Arguments .. -* INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. -* REAL SX(*),SY(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> interchanges two vectors. -*> uses unrolled loops for increments equal to 1. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup single_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, linpack, 3/11/78. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE SSWAP(N,SX,INCX,SY,INCY) -* -* -- Reference BLAS level1 routine (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - REAL SX(*),SY(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - REAL STEMP - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - 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 - STEMP = SX(I) - SX(I) = SY(I) - SY(I) = STEMP - END DO - IF (N.LT.3) RETURN - END IF - MP1 = M + 1 - DO I = MP1,N,3 - STEMP = SX(I) - SX(I) = SY(I) - SY(I) = STEMP - STEMP = SX(I+1) - SX(I+1) = SY(I+1) - SY(I+1) = STEMP - STEMP = SX(I+2) - SX(I+2) = SY(I+2) - SY(I+2) = STEMP - END DO - ELSE -* -* code for unequal increments or equal increments not equal -* to 1 -* - IX = 1 - IY = 1 - IF (INCX.LT.0) IX = (-N+1)*INCX + 1 - IF (INCY.LT.0) IY = (-N+1)*INCY + 1 - DO I = 1,N - STEMP = SX(IX) - SX(IX) = SY(IY) - SY(IY) = STEMP - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN - END diff --git a/mtx/blas_src/strsm.f b/mtx/blas_src/strsm.f deleted file mode 100644 index dad4bb057..000000000 --- a/mtx/blas_src/strsm.f +++ /dev/null @@ -1,443 +0,0 @@ -*> \brief \b STRSM -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* -* .. Scalar Arguments .. -* REAL ALPHA -* INTEGER LDA,LDB,M,N -* CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. -* REAL A(LDA,*),B(LDB,*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> STRSM 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 REAL -*> 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 REAL array of 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 REAL array of 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. -* -*> \date November 2011 -* -*> \ingroup single_blas_level3 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 3 Blas routine. -*> -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* -* -- Reference BLAS level3 routine (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - REAL ALPHA - INTEGER LDA,LDB,M,N - CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. - REAL A(LDA,*),B(LDB,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - REAL TEMP - INTEGER I,INFO,J,K,NROWA - LOGICAL LSIDE,NOUNIT,UPPER -* .. -* .. Parameters .. - REAL ONE,ZERO - PARAMETER (ONE=1.0E+0,ZERO=0.0E+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('STRSM ',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 STRSM . -* - END diff --git a/mtx/blas_src/xerbla.f b/mtx/blas_src/xerbla.f deleted file mode 100644 index eb1c037d2..000000000 --- a/mtx/blas_src/xerbla.f +++ /dev/null @@ -1,89 +0,0 @@ -*> \brief \b XERBLA -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* 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. -* -*> \date November 2011 -* -*> \ingroup aux_blas -* -* ===================================================================== - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* -- Reference BLAS level1 routine (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. 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/mtx/blas_src/zaxpy.f b/mtx/blas_src/zaxpy.f deleted file mode 100644 index e6f5e1f6d..000000000 --- a/mtx/blas_src/zaxpy.f +++ /dev/null @@ -1,102 +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 -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. 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 diff --git a/mtx/blas_src/zdotc.f b/mtx/blas_src/zdotc.f deleted file mode 100644 index 660648bbe..000000000 --- a/mtx/blas_src/zdotc.f +++ /dev/null @@ -1,101 +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 a vector. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. 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 diff --git a/mtx/blas_src/zgerc.f b/mtx/blas_src/zgerc.f deleted file mode 100644 index accfeafc0..000000000 --- a/mtx/blas_src/zgerc.f +++ /dev/null @@ -1,227 +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 of 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 of 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 of 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. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. 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/mtx/blas_src/zhemv.f b/mtx/blas_src/zhemv.f deleted file mode 100644 index 34216fbff..000000000 --- a/mtx/blas_src/zhemv.f +++ /dev/null @@ -1,337 +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 of 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 of 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 of 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. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. 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/mtx/blas_src/zher2.f b/mtx/blas_src/zher2.f deleted file mode 100644 index e2a02c3c6..000000000 --- a/mtx/blas_src/zher2.f +++ /dev/null @@ -1,317 +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 of 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 of 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 of 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. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. 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/mtx/blas_src/ztrsv.f b/mtx/blas_src/ztrsv.f deleted file mode 100644 index f9fd4f840..000000000 --- a/mtx/blas_src/ztrsv.f +++ /dev/null @@ -1,375 +0,0 @@ -*> \brief \b ZTRSV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE ZTRSV(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 -*> -*> ZTRSV solves one of the systems of equations -*> -*> A*x = b, or A**T*x = b, or A**H*x = b, -*> -*> where b and x are n element vectors and A is an n by n unit, or -*> non-unit, upper or lower triangular matrix. -*> -*> No test for singularity or near-singularity is included in this -*> routine. Such tests must be performed before calling this routine. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the matrix is an upper or -*> lower triangular matrix as follows: -*> -*> UPLO = 'U' or 'u' A is an upper triangular matrix. -*> -*> UPLO = 'L' or 'l' A is a lower triangular matrix. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the equations to be solved as -*> follows: -*> -*> TRANS = 'N' or 'n' A*x = b. -*> -*> TRANS = 'T' or 't' A**T*x = b. -*> -*> TRANS = 'C' or 'c' A**H*x = b. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> On entry, DIAG specifies whether or not A is unit -*> triangular as follows: -*> -*> DIAG = 'U' or 'u' A is assumed to be unit triangular. -*> -*> DIAG = 'N' or 'n' A is not assumed to be unit -*> triangular. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array of 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 of 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. -* -*> \date November 2011 -* -*> \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 ZTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* -* -- Reference BLAS level2 routine (version 3.4.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. 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('ZTRSV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOCONJ = LSAME(TRANS,'T') - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x := inv( A )*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 20 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - IF (NOUNIT) X(J) = X(J)/A(J,J) - TEMP = X(J) - DO 10 I = J - 1,1,-1 - X(I) = X(I) - TEMP*A(I,J) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - JX = KX + (N-1)*INCX - DO 40 J = N,1,-1 - IF (X(JX).NE.ZERO) THEN - IF (NOUNIT) X(JX) = X(JX)/A(J,J) - TEMP = X(JX) - IX = JX - DO 30 I = J - 1,1,-1 - IX = IX - INCX - X(IX) = X(IX) - TEMP*A(I,J) - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 60 J = 1,N - IF (X(J).NE.ZERO) THEN - IF (NOUNIT) X(J) = X(J)/A(J,J) - TEMP = X(J) - DO 50 I = J + 1,N - X(I) = X(I) - TEMP*A(I,J) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80 J = 1,N - IF (X(JX).NE.ZERO) THEN - IF (NOUNIT) X(JX) = X(JX)/A(J,J) - TEMP = X(JX) - IX = JX - DO 70 I = J + 1,N - IX = IX + INCX - X(IX) = X(IX) - TEMP*A(I,J) - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A**T )*x or x := inv( A**H )*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 110 J = 1,N - TEMP = X(J) - IF (NOCONJ) THEN - DO 90 I = 1,J - 1 - TEMP = TEMP - A(I,J)*X(I) - 90 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(J,J) - ELSE - DO 100 I = 1,J - 1 - TEMP = TEMP - DCONJG(A(I,J))*X(I) - 100 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(A(J,J)) - END IF - X(J) = TEMP - 110 CONTINUE - ELSE - JX = KX - DO 140 J = 1,N - IX = KX - TEMP = X(JX) - IF (NOCONJ) THEN - DO 120 I = 1,J - 1 - TEMP = TEMP - A(I,J)*X(IX) - IX = IX + INCX - 120 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(J,J) - ELSE - DO 130 I = 1,J - 1 - TEMP = TEMP - DCONJG(A(I,J))*X(IX) - IX = IX + INCX - 130 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(A(J,J)) - END IF - X(JX) = TEMP - JX = JX + INCX - 140 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 170 J = N,1,-1 - TEMP = X(J) - IF (NOCONJ) THEN - DO 150 I = N,J + 1,-1 - TEMP = TEMP - A(I,J)*X(I) - 150 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(J,J) - ELSE - DO 160 I = N,J + 1,-1 - TEMP = TEMP - DCONJG(A(I,J))*X(I) - 160 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(A(J,J)) - END IF - X(J) = TEMP - 170 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 200 J = N,1,-1 - IX = KX - TEMP = X(JX) - IF (NOCONJ) THEN - DO 180 I = N,J + 1,-1 - TEMP = TEMP - A(I,J)*X(IX) - IX = IX - INCX - 180 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(J,J) - ELSE - DO 190 I = N,J + 1,-1 - TEMP = TEMP - DCONJG(A(I,J))*X(IX) - IX = IX - INCX - 190 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(A(J,J)) - END IF - X(JX) = TEMP - JX = JX - INCX - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTRSV . -* - END diff --git a/mtx/lapack_src/dbdsqr.f b/mtx/lapack_src/dbdsqr.f deleted file mode 100644 index 007e99779..000000000 --- a/mtx/lapack_src/dbdsqr.f +++ /dev/null @@ -1,850 +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) -*> \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 -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, - $ LDU, C, LDC, WORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER 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, J, LL, LLL, M, MAXIT, 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.) -* - MAXIT = MAXITR*N*N - ITER = 0 - 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.GT.MAXIT ) - $ GO TO 200 -* -* 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/mtx/lapack_src/dcabs1.f b/mtx/lapack_src/dcabs1.f deleted file mode 100644 index c4acbeb5a..000000000 --- a/mtx/lapack_src/dcabs1.f +++ /dev/null @@ -1,16 +0,0 @@ - DOUBLE PRECISION FUNCTION DCABS1(Z) -* .. Scalar Arguments .. - DOUBLE COMPLEX Z -* .. -* .. -* Purpose -* ======= -* -* DCABS1 computes absolute value of a double complex number -* -* .. Intrinsic Functions .. - INTRINSIC ABS,DBLE,DIMAG -* - DCABS1 = ABS(DBLE(Z)) + ABS(DIMAG(Z)) - RETURN - END diff --git a/mtx/lapack_src/dgbcon.f b/mtx/lapack_src/dgbcon.f deleted file mode 100644 index bf6933faf..000000000 --- a/mtx/lapack_src/dgbcon.f +++ /dev/null @@ -1,311 +0,0 @@ -*> \brief \b DGBCON -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGBCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, -* WORK, IWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER NORM -* INTEGER INFO, KL, KU, LDAB, N -* DOUBLE PRECISION ANORM, RCOND -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ), IWORK( * ) -* DOUBLE PRECISION AB( LDAB, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGBCON estimates the reciprocal of the condition number of a real -*> general band matrix A, in either the 1-norm or the infinity-norm, -*> using the LU factorization computed by DGBTRF. -*> -*> 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] KL -*> \verbatim -*> KL is INTEGER -*> The number of subdiagonals within the band of A. KL >= 0. -*> \endverbatim -*> -*> \param[in] KU -*> \verbatim -*> KU is INTEGER -*> The number of superdiagonals within the band of A. KU >= 0. -*> \endverbatim -*> -*> \param[in] AB -*> \verbatim -*> AB is DOUBLE PRECISION array, dimension (LDAB,N) -*> Details of the LU factorization of the band matrix A, as -*> computed by DGBTRF. U is stored as an upper triangular band -*> matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and -*> the multipliers used during the factorization are stored in -*> rows KL+KU+2 to 2*KL+KU+1. -*> \endverbatim -*> -*> \param[in] LDAB -*> \verbatim -*> LDAB is INTEGER -*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1. -*> \endverbatim -*> -*> \param[in] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (N) -*> The pivot indices; for 1 <= i <= N, row i of the matrix was -*> interchanged with row IPIV(i). -*> \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 (3*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. -* -*> \date November 2011 -* -*> \ingroup doubleGBcomputational -* -* ===================================================================== - SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, - $ WORK, IWORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER NORM - INTEGER INFO, KL, KU, LDAB, N - DOUBLE PRECISION ANORM, RCOND -* .. -* .. Array Arguments .. - INTEGER IPIV( * ), IWORK( * ) - DOUBLE PRECISION AB( LDAB, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LNOTI, ONENRM - CHARACTER NORMIN - INTEGER IX, J, JP, KASE, KASE1, KD, LM - DOUBLE PRECISION AINVNM, SCALE, SMLNUM, T -* .. -* .. Local Arrays .. - INTEGER ISAVE( 3 ) -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DDOT, DLAMCH - EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DLACN2, DLATBS, DRSCL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MIN -* .. -* .. 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( KL.LT.0 ) THEN - INFO = -3 - ELSE IF( KU.LT.0 ) THEN - INFO = -4 - ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN - INFO = -6 - ELSE IF( ANORM.LT.ZERO ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGBCON', -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 - KD = KL + KU + 1 - LNOTI = KL.GT.0 - 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). -* - IF( LNOTI ) THEN - DO 20 J = 1, N - 1 - LM = MIN( KL, N-J ) - JP = IPIV( J ) - T = WORK( JP ) - IF( JP.NE.J ) THEN - WORK( JP ) = WORK( J ) - WORK( J ) = T - END IF - CALL DAXPY( LM, -T, AB( KD+1, J ), 1, WORK( J+1 ), 1 ) - 20 CONTINUE - END IF -* -* Multiply by inv(U). -* - CALL DLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, - $ KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ), - $ INFO ) - ELSE -* -* Multiply by inv(U**T). -* - CALL DLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, - $ KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ), - $ INFO ) -* -* Multiply by inv(L**T). -* - IF( LNOTI ) THEN - DO 30 J = N - 1, 1, -1 - LM = MIN( KL, N-J ) - WORK( J ) = WORK( J ) - DDOT( LM, AB( KD+1, J ), 1, - $ WORK( J+1 ), 1 ) - JP = IPIV( J ) - IF( JP.NE.J ) THEN - T = WORK( JP ) - WORK( JP ) = WORK( J ) - WORK( J ) = T - END IF - 30 CONTINUE - END IF - END IF -* -* Divide X by 1/SCALE if doing so will not cause overflow. -* - 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 40 - 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 -* - 40 CONTINUE - RETURN -* -* End of DGBCON -* - END diff --git a/mtx/lapack_src/dgbequ.f b/mtx/lapack_src/dgbequ.f deleted file mode 100644 index cc94fdb5b..000000000 --- a/mtx/lapack_src/dgbequ.f +++ /dev/null @@ -1,324 +0,0 @@ -*> \brief \b DGBEQU -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGBEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, -* AMAX, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, KL, KU, LDAB, M, N -* DOUBLE PRECISION AMAX, COLCND, ROWCND -* .. -* .. Array Arguments .. -* DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGBEQU computes row and column scalings intended to equilibrate an -*> M-by-N band matrix A and reduce its condition number. R returns the -*> row scale factors and C the column scale factors, chosen to try to -*> make the largest element in each row and column of the matrix B with -*> elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. -*> -*> R(i) and C(j) are restricted to be between SMLNUM = smallest safe -*> number and BIGNUM = largest safe number. Use of these scaling -*> factors is not guaranteed to reduce the condition number of A but -*> works well in practice. -*> \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] KL -*> \verbatim -*> KL is INTEGER -*> The number of subdiagonals within the band of A. KL >= 0. -*> \endverbatim -*> -*> \param[in] KU -*> \verbatim -*> KU is INTEGER -*> The number of superdiagonals within the band of A. KU >= 0. -*> \endverbatim -*> -*> \param[in] AB -*> \verbatim -*> AB is DOUBLE PRECISION array, dimension (LDAB,N) -*> The band matrix A, stored in rows 1 to KL+KU+1. The j-th -*> column of A is stored in the j-th column of the array AB as -*> follows: -*> AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). -*> \endverbatim -*> -*> \param[in] LDAB -*> \verbatim -*> LDAB is INTEGER -*> The leading dimension of the array AB. LDAB >= KL+KU+1. -*> \endverbatim -*> -*> \param[out] R -*> \verbatim -*> R is DOUBLE PRECISION array, dimension (M) -*> If INFO = 0, or INFO > M, R contains the row scale factors -*> for A. -*> \endverbatim -*> -*> \param[out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (N) -*> If INFO = 0, C contains the column scale factors for A. -*> \endverbatim -*> -*> \param[out] ROWCND -*> \verbatim -*> ROWCND is DOUBLE PRECISION -*> If INFO = 0 or INFO > M, ROWCND contains the ratio of the -*> smallest R(i) to the largest R(i). If ROWCND >= 0.1 and -*> AMAX is neither too large nor too small, it is not worth -*> scaling by R. -*> \endverbatim -*> -*> \param[out] COLCND -*> \verbatim -*> COLCND is DOUBLE PRECISION -*> If INFO = 0, COLCND contains the ratio of the smallest -*> C(i) to the largest C(i). If COLCND >= 0.1, it is not -*> worth scaling by C. -*> \endverbatim -*> -*> \param[out] AMAX -*> \verbatim -*> AMAX is DOUBLE PRECISION -*> Absolute value of largest matrix element. If AMAX is very -*> close to overflow or very close to underflow, the matrix -*> should be scaled. -*> \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 i is -*> <= M: the i-th row of A is exactly zero -*> > M: the (i-M)-th column of A is exactly zero -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleGBcomputational -* -* ===================================================================== - SUBROUTINE DGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, - $ AMAX, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INFO, KL, KU, LDAB, M, N - DOUBLE PRECISION AMAX, COLCND, ROWCND -* .. -* .. Array Arguments .. - DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, KD - DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, 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( KL.LT.0 ) THEN - INFO = -3 - ELSE IF( KU.LT.0 ) THEN - INFO = -4 - ELSE IF( LDAB.LT.KL+KU+1 ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGBEQU', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - ROWCND = ONE - COLCND = ONE - AMAX = ZERO - RETURN - END IF -* -* Get machine constants. -* - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM -* -* Compute row scale factors. -* - DO 10 I = 1, M - R( I ) = ZERO - 10 CONTINUE -* -* Find the maximum element in each row. -* - KD = KU + 1 - DO 30 J = 1, N - DO 20 I = MAX( J-KU, 1 ), MIN( J+KL, M ) - R( I ) = MAX( R( I ), ABS( AB( KD+I-J, J ) ) ) - 20 CONTINUE - 30 CONTINUE -* -* Find the maximum and minimum scale factors. -* - RCMIN = BIGNUM - RCMAX = ZERO - DO 40 I = 1, M - RCMAX = MAX( RCMAX, R( I ) ) - RCMIN = MIN( RCMIN, R( I ) ) - 40 CONTINUE - AMAX = RCMAX -* - IF( RCMIN.EQ.ZERO ) THEN -* -* Find the first zero scale factor and return an error code. -* - DO 50 I = 1, M - IF( R( I ).EQ.ZERO ) THEN - INFO = I - RETURN - END IF - 50 CONTINUE - ELSE -* -* Invert the scale factors. -* - DO 60 I = 1, M - R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM ) - 60 CONTINUE -* -* Compute ROWCND = min(R(I)) / max(R(I)) -* - ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) - END IF -* -* Compute column scale factors -* - DO 70 J = 1, N - C( J ) = ZERO - 70 CONTINUE -* -* Find the maximum element in each column, -* assuming the row scaling computed above. -* - KD = KU + 1 - DO 90 J = 1, N - DO 80 I = MAX( J-KU, 1 ), MIN( J+KL, M ) - C( J ) = MAX( C( J ), ABS( AB( KD+I-J, J ) )*R( I ) ) - 80 CONTINUE - 90 CONTINUE -* -* Find the maximum and minimum scale factors. -* - RCMIN = BIGNUM - RCMAX = ZERO - DO 100 J = 1, N - RCMIN = MIN( RCMIN, C( J ) ) - RCMAX = MAX( RCMAX, C( J ) ) - 100 CONTINUE -* - IF( RCMIN.EQ.ZERO ) THEN -* -* Find the first zero scale factor and return an error code. -* - DO 110 J = 1, N - IF( C( J ).EQ.ZERO ) THEN - INFO = M + J - RETURN - END IF - 110 CONTINUE - ELSE -* -* Invert the scale factors. -* - DO 120 J = 1, N - C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM ) - 120 CONTINUE -* -* Compute COLCND = min(C(J)) / max(C(J)) -* - COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) - END IF -* - RETURN -* -* End of DGBEQU -* - END diff --git a/mtx/lapack_src/dgbrfs.f b/mtx/lapack_src/dgbrfs.f deleted file mode 100644 index 39d91981b..000000000 --- a/mtx/lapack_src/dgbrfs.f +++ /dev/null @@ -1,464 +0,0 @@ -*> \brief \b DGBRFS -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGBRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, -* IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, -* INFO ) -* -* .. Scalar Arguments .. -* CHARACTER TRANS -* INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ), IWORK( * ) -* DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), -* $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGBRFS improves the computed solution to a system of linear -*> equations when the coefficient matrix is banded, and provides -*> error bounds and backward error estimates for the solution. -*> \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**H * X = B (Conjugate transpose = Transpose) -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in] KL -*> \verbatim -*> KL is INTEGER -*> The number of subdiagonals within the band of A. KL >= 0. -*> \endverbatim -*> -*> \param[in] KU -*> \verbatim -*> KU is INTEGER -*> The number of superdiagonals within the band of A. KU >= 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] AB -*> \verbatim -*> AB is DOUBLE PRECISION array, dimension (LDAB,N) -*> The original band matrix A, stored in rows 1 to KL+KU+1. -*> The j-th column of A is stored in the j-th column of the -*> array AB as follows: -*> AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). -*> \endverbatim -*> -*> \param[in] LDAB -*> \verbatim -*> LDAB is INTEGER -*> The leading dimension of the array AB. LDAB >= KL+KU+1. -*> \endverbatim -*> -*> \param[in] AFB -*> \verbatim -*> AFB is DOUBLE PRECISION array, dimension (LDAFB,N) -*> Details of the LU factorization of the band matrix A, as -*> computed by DGBTRF. U is stored as an upper triangular band -*> matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and -*> the multipliers used during the factorization are stored in -*> rows KL+KU+2 to 2*KL+KU+1. -*> \endverbatim -*> -*> \param[in] LDAFB -*> \verbatim -*> LDAFB is INTEGER -*> The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. -*> \endverbatim -*> -*> \param[in] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (N) -*> The pivot indices from DGBTRF; for 1<=i<=N, row i of the -*> matrix was interchanged with row IPIV(i). -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) -*> The right hand side matrix B. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,N). -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) -*> On entry, the solution matrix X, as computed by DGBTRS. -*> On exit, the improved solution matrix X. -*> \endverbatim -*> -*> \param[in] LDX -*> \verbatim -*> LDX is INTEGER -*> The leading dimension of the array X. LDX >= max(1,N). -*> \endverbatim -*> -*> \param[out] FERR -*> \verbatim -*> FERR is DOUBLE PRECISION array, dimension (NRHS) -*> The estimated forward error bound for each solution vector -*> X(j) (the j-th column of the solution matrix X). -*> If XTRUE is the true solution corresponding to X(j), FERR(j) -*> is an estimated upper bound for the magnitude of the largest -*> element in (X(j) - XTRUE) divided by the magnitude of the -*> largest element in X(j). The estimate is as reliable as -*> the estimate for RCOND, and is almost always a slight -*> overestimate of the true error. -*> \endverbatim -*> -*> \param[out] BERR -*> \verbatim -*> BERR is DOUBLE PRECISION array, dimension (NRHS) -*> The componentwise relative backward error of each solution -*> vector X(j) (i.e., the smallest relative change in -*> any element of A or B that makes X(j) an exact solution). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (3*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 -* -*> \par Internal Parameters: -* ========================= -*> -*> \verbatim -*> ITMAX is the maximum number of steps of iterative refinement. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleGBcomputational -* -* ===================================================================== - SUBROUTINE DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, - $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, - $ INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ), IWORK( * ) - DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), - $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER ITMAX - PARAMETER ( ITMAX = 5 ) - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D+0 ) - DOUBLE PRECISION THREE - PARAMETER ( THREE = 3.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN - CHARACTER TRANST - INTEGER COUNT, I, J, K, KASE, KK, NZ - DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK -* .. -* .. Local Arrays .. - INTEGER ISAVE( 3 ) -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGBMV, DGBTRS, DLACN2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, DLAMCH -* .. -* .. 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( KL.LT.0 ) THEN - INFO = -3 - ELSE IF( KU.LT.0 ) THEN - INFO = -4 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -5 - ELSE IF( LDAB.LT.KL+KU+1 ) THEN - INFO = -7 - ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -14 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGBRFS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN - DO 10 J = 1, NRHS - FERR( J ) = ZERO - BERR( J ) = ZERO - 10 CONTINUE - RETURN - END IF -* - IF( NOTRAN ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF -* -* NZ = maximum number of nonzero elements in each row of A, plus 1 -* - NZ = MIN( KL+KU+2, N+1 ) - EPS = DLAMCH( 'Epsilon' ) - SAFMIN = DLAMCH( 'Safe minimum' ) - SAFE1 = NZ*SAFMIN - SAFE2 = SAFE1 / EPS -* -* Do for each right hand side -* - DO 140 J = 1, NRHS -* - COUNT = 1 - LSTRES = THREE - 20 CONTINUE -* -* Loop until stopping criterion is satisfied. -* -* Compute residual R = B - op(A) * X, -* where op(A) = A, A**T, or A**H, depending on TRANS. -* - CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 ) - CALL DGBMV( TRANS, N, N, KL, KU, -ONE, AB, LDAB, X( 1, J ), 1, - $ ONE, WORK( N+1 ), 1 ) -* -* Compute componentwise relative backward error from formula -* -* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) -* -* where abs(Z) is the componentwise absolute value of the matrix -* or vector Z. If the i-th component of the denominator is less -* than SAFE2, then SAFE1 is added to the i-th components of the -* numerator and denominator before dividing. -* - DO 30 I = 1, N - WORK( I ) = ABS( B( I, J ) ) - 30 CONTINUE -* -* Compute abs(op(A))*abs(X) + abs(B). -* - IF( NOTRAN ) THEN - DO 50 K = 1, N - KK = KU + 1 - K - XK = ABS( X( K, J ) ) - DO 40 I = MAX( 1, K-KU ), MIN( N, K+KL ) - WORK( I ) = WORK( I ) + ABS( AB( KK+I, K ) )*XK - 40 CONTINUE - 50 CONTINUE - ELSE - DO 70 K = 1, N - S = ZERO - KK = KU + 1 - K - DO 60 I = MAX( 1, K-KU ), MIN( N, K+KL ) - S = S + ABS( AB( KK+I, K ) )*ABS( X( I, J ) ) - 60 CONTINUE - WORK( K ) = WORK( K ) + S - 70 CONTINUE - END IF - S = ZERO - DO 80 I = 1, N - IF( WORK( I ).GT.SAFE2 ) THEN - S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) ) - ELSE - S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) / - $ ( WORK( I )+SAFE1 ) ) - END IF - 80 CONTINUE - BERR( J ) = S -* -* Test stopping criterion. Continue iterating if -* 1) The residual BERR(J) is larger than machine epsilon, and -* 2) BERR(J) decreased by at least a factor of 2 during the -* last iteration, and -* 3) At most ITMAX iterations tried. -* - IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND. - $ COUNT.LE.ITMAX ) THEN -* -* Update solution and try again. -* - CALL DGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV, - $ WORK( N+1 ), N, INFO ) - CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 ) - LSTRES = BERR( J ) - COUNT = COUNT + 1 - GO TO 20 - END IF -* -* Bound error from formula -* -* norm(X - XTRUE) / norm(X) .le. FERR = -* norm( abs(inv(op(A)))* -* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) -* -* where -* norm(Z) is the magnitude of the largest component of Z -* inv(op(A)) is the inverse of op(A) -* abs(Z) is the componentwise absolute value of the matrix or -* vector Z -* NZ is the maximum number of nonzeros in any row of A, plus 1 -* EPS is machine epsilon -* -* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) -* is incremented by SAFE1 if the i-th component of -* abs(op(A))*abs(X) + abs(B) is less than SAFE2. -* -* Use DLACN2 to estimate the infinity-norm of the matrix -* inv(op(A)) * diag(W), -* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) -* - DO 90 I = 1, N - IF( WORK( I ).GT.SAFE2 ) THEN - WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) - ELSE - WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1 - END IF - 90 CONTINUE -* - KASE = 0 - 100 CONTINUE - CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ), - $ KASE, ISAVE ) - IF( KASE.NE.0 ) THEN - IF( KASE.EQ.1 ) THEN -* -* Multiply by diag(W)*inv(op(A)**T). -* - CALL DGBTRS( TRANST, N, KL, KU, 1, AFB, LDAFB, IPIV, - $ WORK( N+1 ), N, INFO ) - DO 110 I = 1, N - WORK( N+I ) = WORK( N+I )*WORK( I ) - 110 CONTINUE - ELSE -* -* Multiply by inv(op(A))*diag(W). -* - DO 120 I = 1, N - WORK( N+I ) = WORK( N+I )*WORK( I ) - 120 CONTINUE - CALL DGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV, - $ WORK( N+1 ), N, INFO ) - END IF - GO TO 100 - END IF -* -* Normalize error. -* - LSTRES = ZERO - DO 130 I = 1, N - LSTRES = MAX( LSTRES, ABS( X( I, J ) ) ) - 130 CONTINUE - IF( LSTRES.NE.ZERO ) - $ FERR( J ) = FERR( J ) / LSTRES -* - 140 CONTINUE -* - RETURN -* -* End of DGBRFS -* - END diff --git a/mtx/lapack_src/dgbsv.f b/mtx/lapack_src/dgbsv.f deleted file mode 100644 index 93769d387..000000000 --- a/mtx/lapack_src/dgbsv.f +++ /dev/null @@ -1,223 +0,0 @@ -*> \brief DGBSV computes the solution to system of linear equations A * X = B for GB matrices (simple driver) -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGBSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGBSV computes the solution to a real system of linear equations -*> A * X = B, where A is a band matrix of order N with KL subdiagonals -*> and KU superdiagonals, 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 = L * U, where L is a product of permutation -*> and unit lower triangular matrices with KL subdiagonals, and U is -*> upper triangular with KL+KU superdiagonals. 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] KL -*> \verbatim -*> KL is INTEGER -*> The number of subdiagonals within the band of A. KL >= 0. -*> \endverbatim -*> -*> \param[in] KU -*> \verbatim -*> KU is INTEGER -*> The number of superdiagonals within the band of A. KU >= 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] AB -*> \verbatim -*> AB is DOUBLE PRECISION array, dimension (LDAB,N) -*> On entry, the matrix A in band storage, in rows KL+1 to -*> 2*KL+KU+1; rows 1 to KL of the array need not be set. -*> The j-th column of A is stored in the j-th column of the -*> array AB as follows: -*> AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL) -*> On exit, details of the factorization: U is stored as an -*> upper triangular band matrix with KL+KU superdiagonals in -*> rows 1 to KL+KU+1, and the multipliers used during the -*> factorization are stored in rows KL+KU+2 to 2*KL+KU+1. -*> See below for further details. -*> \endverbatim -*> -*> \param[in] LDAB -*> \verbatim -*> LDAB is INTEGER -*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1. -*> \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 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, 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. -* -*> \date November 2011 -* -*> \ingroup doubleGBsolve -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The band storage scheme is illustrated by the following example, when -*> M = N = 6, KL = 2, KU = 1: -*> -*> On entry: On exit: -*> -*> * * * + + + * * * u14 u25 u36 -*> * * + + + + * * u13 u24 u35 u46 -*> * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 -*> a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 -*> a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * -*> a31 a42 a53 a64 * * m31 m42 m53 m64 * * -*> -*> Array elements marked * are not used by the routine; elements marked -*> + need not be set on entry, but are required by the routine to store -*> elements of U because of fill-in resulting from the row interchanges. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) -* -* -- LAPACK driver routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. External Subroutines .. - EXTERNAL DGBTRF, DGBTRS, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( KL.LT.0 ) THEN - INFO = -2 - ELSE IF( KU.LT.0 ) THEN - INFO = -3 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -4 - ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGBSV ', -INFO ) - RETURN - END IF -* -* Compute the LU factorization of the band matrix A. -* - CALL DGBTRF( N, N, KL, KU, AB, LDAB, IPIV, INFO ) - IF( INFO.EQ.0 ) THEN -* -* Solve the system A*X = B, overwriting B with X. -* - CALL DGBTRS( 'No transpose', N, KL, KU, NRHS, AB, LDAB, IPIV, - $ B, LDB, INFO ) - END IF - RETURN -* -* End of DGBSV -* - END diff --git a/mtx/lapack_src/dgbsvx.f b/mtx/lapack_src/dgbsvx.f deleted file mode 100644 index f6911b267..000000000 --- a/mtx/lapack_src/dgbsvx.f +++ /dev/null @@ -1,642 +0,0 @@ -*> \brief DGBSVX computes the solution to system of linear equations A * X = B for GB matrices -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGBSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, -* LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, -* RCOND, FERR, BERR, WORK, IWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER EQUED, FACT, TRANS -* INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS -* DOUBLE PRECISION RCOND -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ), IWORK( * ) -* DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), -* $ BERR( * ), C( * ), FERR( * ), R( * ), -* $ WORK( * ), X( LDX, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGBSVX uses the LU factorization to compute the solution to a real -*> system of linear equations A * X = B, A**T * X = B, or A**H * X = B, -*> where A is a band matrix of order N with KL subdiagonals and KU -*> superdiagonals, and X and B are N-by-NRHS matrices. -*> -*> Error bounds on the solution and a condition estimate are also -*> provided. -*> \endverbatim -* -*> \par Description: -* ================= -*> -*> \verbatim -*> -*> The following steps are performed by this subroutine: -*> -*> 1. If FACT = 'E', real scaling factors are computed to equilibrate -*> the system: -*> TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B -*> TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B -*> TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B -*> Whether or not the system will be equilibrated depends on the -*> scaling of the matrix A, but if equilibration is used, A is -*> overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') -*> or diag(C)*B (if TRANS = 'T' or 'C'). -*> -*> 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the -*> matrix A (after equilibration if FACT = 'E') as -*> A = L * U, -*> where L is a product of permutation and unit lower triangular -*> matrices with KL subdiagonals, and U is upper triangular with -*> KL+KU superdiagonals. -*> -*> 3. If some U(i,i)=0, so that U is exactly singular, then the routine -*> returns with INFO = i. Otherwise, the factored form of A is used -*> to estimate the condition number of the matrix A. If the -*> reciprocal of the condition number is less than machine precision, -*> INFO = N+1 is returned as a warning, but the routine still goes on -*> to solve for X and compute error bounds as described below. -*> -*> 4. The system of equations is solved for X using the factored form -*> of A. -*> -*> 5. Iterative refinement is applied to improve the computed solution -*> matrix and calculate error bounds and backward error estimates -*> for it. -*> -*> 6. If equilibration was used, the matrix X is premultiplied by -*> diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so -*> that it solves the original system before equilibration. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] FACT -*> \verbatim -*> FACT is CHARACTER*1 -*> Specifies whether or not the factored form of the matrix A is -*> supplied on entry, and if not, whether the matrix A should be -*> equilibrated before it is factored. -*> = 'F': On entry, AFB and IPIV contain the factored form of -*> A. If EQUED is not 'N', the matrix A has been -*> equilibrated with scaling factors given by R and C. -*> AB, AFB, and IPIV are not modified. -*> = 'N': The matrix A will be copied to AFB and factored. -*> = 'E': The matrix A will be equilibrated if necessary, then -*> copied to AFB and factored. -*> \endverbatim -*> -*> \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**H * X = B (Transpose) -*> \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] KL -*> \verbatim -*> KL is INTEGER -*> The number of subdiagonals within the band of A. KL >= 0. -*> \endverbatim -*> -*> \param[in] KU -*> \verbatim -*> KU is INTEGER -*> The number of superdiagonals within the band of A. KU >= 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] AB -*> \verbatim -*> AB is DOUBLE PRECISION array, dimension (LDAB,N) -*> On entry, the matrix A in band storage, in rows 1 to KL+KU+1. -*> The j-th column of A is stored in the j-th column of the -*> array AB as follows: -*> AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) -*> -*> If FACT = 'F' and EQUED is not 'N', then A must have been -*> equilibrated by the scaling factors in R and/or C. AB is not -*> modified if FACT = 'F' or 'N', or if FACT = 'E' and -*> EQUED = 'N' on exit. -*> -*> On exit, if EQUED .ne. 'N', A is scaled as follows: -*> EQUED = 'R': A := diag(R) * A -*> EQUED = 'C': A := A * diag(C) -*> EQUED = 'B': A := diag(R) * A * diag(C). -*> \endverbatim -*> -*> \param[in] LDAB -*> \verbatim -*> LDAB is INTEGER -*> The leading dimension of the array AB. LDAB >= KL+KU+1. -*> \endverbatim -*> -*> \param[in,out] AFB -*> \verbatim -*> AFB is DOUBLE PRECISION array, dimension (LDAFB,N) -*> If FACT = 'F', then AFB is an input argument and on entry -*> contains details of the LU factorization of the band matrix -*> A, as computed by DGBTRF. U is stored as an upper triangular -*> band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, -*> and the multipliers used during the factorization are stored -*> in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is -*> the factored form of the equilibrated matrix A. -*> -*> If FACT = 'N', then AFB is an output argument and on exit -*> returns details of the LU factorization of A. -*> -*> If FACT = 'E', then AFB is an output argument and on exit -*> returns details of the LU factorization of the equilibrated -*> matrix A (see the description of AB for the form of the -*> equilibrated matrix). -*> \endverbatim -*> -*> \param[in] LDAFB -*> \verbatim -*> LDAFB is INTEGER -*> The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. -*> \endverbatim -*> -*> \param[in,out] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (N) -*> If FACT = 'F', then IPIV is an input argument and on entry -*> contains the pivot indices from the factorization A = L*U -*> as computed by DGBTRF; row i of the matrix was interchanged -*> with row IPIV(i). -*> -*> If FACT = 'N', then IPIV is an output argument and on exit -*> contains the pivot indices from the factorization A = L*U -*> of the original matrix A. -*> -*> If FACT = 'E', then IPIV is an output argument and on exit -*> contains the pivot indices from the factorization A = L*U -*> of the equilibrated matrix A. -*> \endverbatim -*> -*> \param[in,out] EQUED -*> \verbatim -*> EQUED is CHARACTER*1 -*> Specifies the form of equilibration that was done. -*> = 'N': No equilibration (always true if FACT = 'N'). -*> = 'R': Row equilibration, i.e., A has been premultiplied by -*> diag(R). -*> = 'C': Column equilibration, i.e., A has been postmultiplied -*> by diag(C). -*> = 'B': Both row and column equilibration, i.e., A has been -*> replaced by diag(R) * A * diag(C). -*> EQUED is an input argument if FACT = 'F'; otherwise, it is an -*> output argument. -*> \endverbatim -*> -*> \param[in,out] R -*> \verbatim -*> R is DOUBLE PRECISION array, dimension (N) -*> The row scale factors for A. If EQUED = 'R' or 'B', A is -*> multiplied on the left by diag(R); if EQUED = 'N' or 'C', R -*> is not accessed. R is an input argument if FACT = 'F'; -*> otherwise, R is an output argument. If FACT = 'F' and -*> EQUED = 'R' or 'B', each element of R must be positive. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (N) -*> The column scale factors for A. If EQUED = 'C' or 'B', A is -*> multiplied on the right by diag(C); if EQUED = 'N' or 'R', C -*> is not accessed. C is an input argument if FACT = 'F'; -*> otherwise, C is an output argument. If FACT = 'F' and -*> EQUED = 'C' or 'B', each element of C must be positive. -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) -*> On entry, the right hand side matrix B. -*> On exit, -*> if EQUED = 'N', B is not modified; -*> if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by -*> diag(R)*B; -*> if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is -*> overwritten by diag(C)*B. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,N). -*> \endverbatim -*> -*> \param[out] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) -*> If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X -*> to the original system of equations. Note that A and B are -*> modified on exit if EQUED .ne. 'N', and the solution to the -*> equilibrated system is inv(diag(C))*X if TRANS = 'N' and -*> EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' -*> and EQUED = 'R' or 'B'. -*> \endverbatim -*> -*> \param[in] LDX -*> \verbatim -*> LDX is INTEGER -*> The leading dimension of the array X. LDX >= max(1,N). -*> \endverbatim -*> -*> \param[out] RCOND -*> \verbatim -*> RCOND is DOUBLE PRECISION -*> The estimate of the reciprocal condition number of the matrix -*> A after equilibration (if done). If RCOND is less than the -*> machine precision (in particular, if RCOND = 0), the matrix -*> is singular to working precision. This condition is -*> indicated by a return code of INFO > 0. -*> \endverbatim -*> -*> \param[out] FERR -*> \verbatim -*> FERR is DOUBLE PRECISION array, dimension (NRHS) -*> The estimated forward error bound for each solution vector -*> X(j) (the j-th column of the solution matrix X). -*> If XTRUE is the true solution corresponding to X(j), FERR(j) -*> is an estimated upper bound for the magnitude of the largest -*> element in (X(j) - XTRUE) divided by the magnitude of the -*> largest element in X(j). The estimate is as reliable as -*> the estimate for RCOND, and is almost always a slight -*> overestimate of the true error. -*> \endverbatim -*> -*> \param[out] BERR -*> \verbatim -*> BERR is DOUBLE PRECISION array, dimension (NRHS) -*> The componentwise relative backward error of each solution -*> vector X(j) (i.e., the smallest relative change in -*> any element of A or B that makes X(j) an exact solution). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (3*N) -*> On exit, WORK(1) contains the reciprocal pivot growth -*> factor norm(A)/norm(U). The "max absolute element" norm is -*> used. If WORK(1) is much less than 1, then the stability -*> of the LU factorization of the (equilibrated) matrix A -*> could be poor. This also means that the solution X, condition -*> estimator RCOND, and forward error bound FERR could be -*> unreliable. If factorization fails with 0 WORK(1) contains the reciprocal pivot growth factor for the -*> leading INFO columns of A. -*> \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 -*> > 0: if INFO = i, and i is -*> <= N: U(i,i) is exactly zero. The factorization -*> has been completed, but the factor U is exactly -*> singular, so the solution and error bounds -*> could not be computed. RCOND = 0 is returned. -*> = N+1: U is nonsingular, but RCOND is less than machine -*> precision, meaning that the matrix is singular -*> to working precision. Nevertheless, the -*> solution and error bounds are computed because -*> there are a number of situations where the -*> computed solution can be more accurate than the -*> value of RCOND would suggest. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date April 2012 -* -*> \ingroup doubleGBsolve -* -* ===================================================================== - SUBROUTINE DGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, - $ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, - $ RCOND, FERR, BERR, WORK, IWORK, INFO ) -* -* -- LAPACK driver routine (version 3.4.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 -* -* .. Scalar Arguments .. - CHARACTER EQUED, FACT, TRANS - INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS - DOUBLE PRECISION RCOND -* .. -* .. Array Arguments .. - INTEGER IPIV( * ), IWORK( * ) - DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), - $ BERR( * ), C( * ), FERR( * ), R( * ), - $ WORK( * ), X( LDX, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU - CHARACTER NORM - INTEGER I, INFEQU, J, J1, J2 - DOUBLE PRECISION AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN, - $ ROWCND, RPVGRW, SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGB, DLANTB - EXTERNAL LSAME, DLAMCH, DLANGB, DLANTB -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGBCON, DGBEQU, DGBRFS, DGBTRF, DGBTRS, - $ DLACPY, DLAQGB, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. Executable Statements .. -* - INFO = 0 - NOFACT = LSAME( FACT, 'N' ) - EQUIL = LSAME( FACT, 'E' ) - NOTRAN = LSAME( TRANS, 'N' ) - IF( NOFACT .OR. EQUIL ) THEN - EQUED = 'N' - ROWEQU = .FALSE. - COLEQU = .FALSE. - ELSE - ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) - COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) - SMLNUM = DLAMCH( 'Safe minimum' ) - BIGNUM = ONE / SMLNUM - END IF -* -* Test the input parameters. -* - IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) ) - $ THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( KL.LT.0 ) THEN - INFO = -4 - ELSE IF( KU.LT.0 ) THEN - INFO = -5 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -6 - ELSE IF( LDAB.LT.KL+KU+1 ) THEN - INFO = -8 - ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN - INFO = -10 - ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. - $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN - INFO = -12 - ELSE - IF( ROWEQU ) THEN - RCMIN = BIGNUM - RCMAX = ZERO - DO 10 J = 1, N - RCMIN = MIN( RCMIN, R( J ) ) - RCMAX = MAX( RCMAX, R( J ) ) - 10 CONTINUE - IF( RCMIN.LE.ZERO ) THEN - INFO = -13 - ELSE IF( N.GT.0 ) THEN - ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) - ELSE - ROWCND = ONE - END IF - END IF - IF( COLEQU .AND. INFO.EQ.0 ) THEN - RCMIN = BIGNUM - RCMAX = ZERO - DO 20 J = 1, N - RCMIN = MIN( RCMIN, C( J ) ) - RCMAX = MAX( RCMAX, C( J ) ) - 20 CONTINUE - IF( RCMIN.LE.ZERO ) THEN - INFO = -14 - ELSE IF( N.GT.0 ) THEN - COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) - ELSE - COLCND = ONE - END IF - END IF - IF( INFO.EQ.0 ) THEN - IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -18 - END IF - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGBSVX', -INFO ) - RETURN - END IF -* - IF( EQUIL ) THEN -* -* Compute row and column scalings to equilibrate the matrix A. -* - CALL DGBEQU( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, - $ AMAX, INFEQU ) - IF( INFEQU.EQ.0 ) THEN -* -* Equilibrate the matrix. -* - CALL DLAQGB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, - $ AMAX, EQUED ) - ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) - COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) - END IF - END IF -* -* Scale the right hand side. -* - IF( NOTRAN ) THEN - IF( ROWEQU ) THEN - DO 40 J = 1, NRHS - DO 30 I = 1, N - B( I, J ) = R( I )*B( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE IF( COLEQU ) THEN - DO 60 J = 1, NRHS - DO 50 I = 1, N - B( I, J ) = C( I )*B( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF -* - IF( NOFACT .OR. EQUIL ) THEN -* -* Compute the LU factorization of the band matrix A. -* - DO 70 J = 1, N - J1 = MAX( J-KU, 1 ) - J2 = MIN( J+KL, N ) - CALL DCOPY( J2-J1+1, AB( KU+1-J+J1, J ), 1, - $ AFB( KL+KU+1-J+J1, J ), 1 ) - 70 CONTINUE -* - CALL DGBTRF( N, N, KL, KU, AFB, LDAFB, IPIV, INFO ) -* -* Return if INFO is non-zero. -* - IF( INFO.GT.0 ) THEN -* -* Compute the reciprocal pivot growth factor of the -* leading rank-deficient INFO columns of A. -* - ANORM = ZERO - DO 90 J = 1, INFO - DO 80 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 ) - ANORM = MAX( ANORM, ABS( AB( I, J ) ) ) - 80 CONTINUE - 90 CONTINUE - RPVGRW = DLANTB( 'M', 'U', 'N', INFO, MIN( INFO-1, KL+KU ), - $ AFB( MAX( 1, KL+KU+2-INFO ), 1 ), LDAFB, - $ WORK ) - IF( RPVGRW.EQ.ZERO ) THEN - RPVGRW = ONE - ELSE - RPVGRW = ANORM / RPVGRW - END IF - WORK( 1 ) = RPVGRW - RCOND = ZERO - RETURN - END IF - END IF -* -* Compute the norm of the matrix A and the -* reciprocal pivot growth factor RPVGRW. -* - IF( NOTRAN ) THEN - NORM = '1' - ELSE - NORM = 'I' - END IF - ANORM = DLANGB( NORM, N, KL, KU, AB, LDAB, WORK ) - RPVGRW = DLANTB( 'M', 'U', 'N', N, KL+KU, AFB, LDAFB, WORK ) - IF( RPVGRW.EQ.ZERO ) THEN - RPVGRW = ONE - ELSE - RPVGRW = DLANGB( 'M', N, KL, KU, AB, LDAB, WORK ) / RPVGRW - END IF -* -* Compute the reciprocal of the condition number of A. -* - CALL DGBCON( NORM, N, KL, KU, AFB, LDAFB, IPIV, ANORM, RCOND, - $ WORK, IWORK, INFO ) -* -* Compute the solution matrix X. -* - CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) - CALL DGBTRS( TRANS, N, KL, KU, NRHS, AFB, LDAFB, IPIV, X, LDX, - $ INFO ) -* -* Use iterative refinement to improve the computed solution and -* compute error bounds and backward error estimates for it. -* - CALL DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, - $ B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) -* -* Transform the solution matrix X to a solution of the original -* system. -* - IF( NOTRAN ) THEN - IF( COLEQU ) THEN - DO 110 J = 1, NRHS - DO 100 I = 1, N - X( I, J ) = C( I )*X( I, J ) - 100 CONTINUE - 110 CONTINUE - DO 120 J = 1, NRHS - FERR( J ) = FERR( J ) / COLCND - 120 CONTINUE - END IF - ELSE IF( ROWEQU ) THEN - DO 140 J = 1, NRHS - DO 130 I = 1, N - X( I, J ) = R( I )*X( I, J ) - 130 CONTINUE - 140 CONTINUE - DO 150 J = 1, NRHS - FERR( J ) = FERR( J ) / ROWCND - 150 CONTINUE - END IF -* -* Set INFO = N+1 if the matrix is singular to working precision. -* - IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) - $ INFO = N + 1 -* - WORK( 1 ) = RPVGRW - RETURN -* -* End of DGBSVX -* - END diff --git a/mtx/lapack_src/dgbtf2.f b/mtx/lapack_src/dgbtf2.f deleted file mode 100644 index d053e413e..000000000 --- a/mtx/lapack_src/dgbtf2.f +++ /dev/null @@ -1,277 +0,0 @@ -*> \brief \b DGBTF2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGBTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, KL, KU, LDAB, M, N -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* DOUBLE PRECISION AB( LDAB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGBTF2 computes an LU factorization of a real m-by-n band matrix A -*> using partial pivoting with row interchanges. -*> -*> This is the unblocked version of the algorithm, calling Level 2 BLAS. -*> \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] KL -*> \verbatim -*> KL is INTEGER -*> The number of subdiagonals within the band of A. KL >= 0. -*> \endverbatim -*> -*> \param[in] KU -*> \verbatim -*> KU is INTEGER -*> The number of superdiagonals within the band of A. KU >= 0. -*> \endverbatim -*> -*> \param[in,out] AB -*> \verbatim -*> AB is DOUBLE PRECISION array, dimension (LDAB,N) -*> On entry, the matrix A in band storage, in rows KL+1 to -*> 2*KL+KU+1; rows 1 to KL of the array need not be set. -*> The j-th column of A is stored in the j-th column of the -*> array AB as follows: -*> AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) -*> -*> On exit, details of the factorization: U is stored as an -*> upper triangular band matrix with KL+KU superdiagonals in -*> rows 1 to KL+KU+1, and the multipliers used during the -*> factorization are stored in rows KL+KU+2 to 2*KL+KU+1. -*> See below for further details. -*> \endverbatim -*> -*> \param[in] LDAB -*> \verbatim -*> LDAB is INTEGER -*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1. -*> \endverbatim -*> -*> \param[out] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (min(M,N)) -*> The pivot indices; for 1 <= i <= min(M,N), row i of the -*> matrix was interchanged with row IPIV(i). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: if INFO = +i, U(i,i) is exactly zero. The factorization -*> has been completed, but the factor U is exactly -*> singular, and division by zero will occur if it is used -*> to solve a system of equations. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleGBcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The band storage scheme is illustrated by the following example, when -*> M = N = 6, KL = 2, KU = 1: -*> -*> On entry: On exit: -*> -*> * * * + + + * * * u14 u25 u36 -*> * * + + + + * * u13 u24 u35 u46 -*> * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 -*> a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 -*> a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * -*> a31 a42 a53 a64 * * m31 m42 m53 m64 * * -*> -*> Array elements marked * are not used by the routine; elements marked -*> + need not be set on entry, but are required by the routine to store -*> elements of U, because of fill-in resulting from the row -*> interchanges. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INFO, KL, KU, LDAB, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION AB( LDAB, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, JP, JU, KM, KV -* .. -* .. External Functions .. - INTEGER IDAMAX - EXTERNAL IDAMAX -* .. -* .. External Subroutines .. - EXTERNAL DGER, DSCAL, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* KV is the number of superdiagonals in the factor U, allowing for -* fill-in. -* - KV = KU + KL -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( KL.LT.0 ) THEN - INFO = -3 - ELSE IF( KU.LT.0 ) THEN - INFO = -4 - ELSE IF( LDAB.LT.KL+KV+1 ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGBTF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Gaussian elimination with partial pivoting -* -* Set fill-in elements in columns KU+2 to KV to zero. -* - DO 20 J = KU + 2, MIN( KV, N ) - DO 10 I = KV - J + 2, KL - AB( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE -* -* JU is the index of the last column affected by the current stage -* of the factorization. -* - JU = 1 -* - DO 40 J = 1, MIN( M, N ) -* -* Set fill-in elements in column J+KV to zero. -* - IF( J+KV.LE.N ) THEN - DO 30 I = 1, KL - AB( I, J+KV ) = ZERO - 30 CONTINUE - END IF -* -* Find pivot and test for singularity. KM is the number of -* subdiagonal elements in the current column. -* - KM = MIN( KL, M-J ) - JP = IDAMAX( KM+1, AB( KV+1, J ), 1 ) - IPIV( J ) = JP + J - 1 - IF( AB( KV+JP, J ).NE.ZERO ) THEN - JU = MAX( JU, MIN( J+KU+JP-1, N ) ) -* -* Apply interchange to columns J to JU. -* - IF( JP.NE.1 ) - $ CALL DSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1, - $ AB( KV+1, J ), LDAB-1 ) -* - IF( KM.GT.0 ) THEN -* -* Compute multipliers. -* - CALL DSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 ) -* -* Update trailing submatrix within the band. -* - IF( JU.GT.J ) - $ CALL DGER( KM, JU-J, -ONE, AB( KV+2, J ), 1, - $ AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ), - $ LDAB-1 ) - END IF - ELSE -* -* If pivot is zero, set INFO to the index of the pivot -* unless a zero pivot has already been found. -* - IF( INFO.EQ.0 ) - $ INFO = J - END IF - 40 CONTINUE - RETURN -* -* End of DGBTF2 -* - END diff --git a/mtx/lapack_src/dgbtrf.f b/mtx/lapack_src/dgbtrf.f deleted file mode 100644 index 653f8e376..000000000 --- a/mtx/lapack_src/dgbtrf.f +++ /dev/null @@ -1,516 +0,0 @@ -*> \brief \b DGBTRF -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGBTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, KL, KU, LDAB, M, N -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* DOUBLE PRECISION AB( LDAB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGBTRF computes an LU factorization of a real m-by-n band matrix A -*> using partial pivoting with row interchanges. -*> -*> This is the blocked version of the algorithm, calling Level 3 BLAS. -*> \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] KL -*> \verbatim -*> KL is INTEGER -*> The number of subdiagonals within the band of A. KL >= 0. -*> \endverbatim -*> -*> \param[in] KU -*> \verbatim -*> KU is INTEGER -*> The number of superdiagonals within the band of A. KU >= 0. -*> \endverbatim -*> -*> \param[in,out] AB -*> \verbatim -*> AB is DOUBLE PRECISION array, dimension (LDAB,N) -*> On entry, the matrix A in band storage, in rows KL+1 to -*> 2*KL+KU+1; rows 1 to KL of the array need not be set. -*> The j-th column of A is stored in the j-th column of the -*> array AB as follows: -*> AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) -*> -*> On exit, details of the factorization: U is stored as an -*> upper triangular band matrix with KL+KU superdiagonals in -*> rows 1 to KL+KU+1, and the multipliers used during the -*> factorization are stored in rows KL+KU+2 to 2*KL+KU+1. -*> See below for further details. -*> \endverbatim -*> -*> \param[in] LDAB -*> \verbatim -*> LDAB is INTEGER -*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1. -*> \endverbatim -*> -*> \param[out] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (min(M,N)) -*> The pivot indices; for 1 <= i <= min(M,N), row i of the -*> matrix was interchanged with row IPIV(i). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: if INFO = +i, U(i,i) is exactly zero. The factorization -*> has been completed, but the factor U is exactly -*> singular, and division by zero will occur if it is used -*> to solve a system of equations. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleGBcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The band storage scheme is illustrated by the following example, when -*> M = N = 6, KL = 2, KU = 1: -*> -*> On entry: On exit: -*> -*> * * * + + + * * * u14 u25 u36 -*> * * + + + + * * u13 u24 u35 u46 -*> * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 -*> a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 -*> a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * -*> a31 a42 a53 a64 * * m31 m42 m53 m64 * * -*> -*> Array elements marked * are not used by the routine; elements marked -*> + need not be set on entry, but are required by the routine to store -*> elements of U because of fill-in resulting from the row interchanges. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INFO, KL, KU, LDAB, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION AB( LDAB, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) - INTEGER NBMAX, LDWORK - PARAMETER ( NBMAX = 64, LDWORK = NBMAX+1 ) -* .. -* .. Local Scalars .. - INTEGER I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP, - $ JU, K2, KM, KV, NB, NW - DOUBLE PRECISION TEMP -* .. -* .. Local Arrays .. - DOUBLE PRECISION WORK13( LDWORK, NBMAX ), - $ WORK31( LDWORK, NBMAX ) -* .. -* .. External Functions .. - INTEGER IDAMAX, ILAENV - EXTERNAL IDAMAX, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGBTF2, DGEMM, DGER, DLASWP, DSCAL, - $ DSWAP, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* KV is the number of superdiagonals in the factor U, allowing for -* fill-in -* - KV = KU + KL -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( KL.LT.0 ) THEN - INFO = -3 - ELSE IF( KU.LT.0 ) THEN - INFO = -4 - ELSE IF( LDAB.LT.KL+KV+1 ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGBTRF', -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, 'DGBTRF', ' ', M, N, KL, KU ) -* -* The block size must not exceed the limit set by the size of the -* local arrays WORK13 and WORK31. -* - NB = MIN( NB, NBMAX ) -* - IF( NB.LE.1 .OR. NB.GT.KL ) THEN -* -* Use unblocked code -* - CALL DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) - ELSE -* -* Use blocked code -* -* Zero the superdiagonal elements of the work array WORK13 -* - DO 20 J = 1, NB - DO 10 I = 1, J - 1 - WORK13( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE -* -* Zero the subdiagonal elements of the work array WORK31 -* - DO 40 J = 1, NB - DO 30 I = J + 1, NB - WORK31( I, J ) = ZERO - 30 CONTINUE - 40 CONTINUE -* -* Gaussian elimination with partial pivoting -* -* Set fill-in elements in columns KU+2 to KV to zero -* - DO 60 J = KU + 2, MIN( KV, N ) - DO 50 I = KV - J + 2, KL - AB( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE -* -* JU is the index of the last column affected by the current -* stage of the factorization -* - JU = 1 -* - DO 180 J = 1, MIN( M, N ), NB - JB = MIN( NB, MIN( M, N )-J+1 ) -* -* The active part of the matrix is partitioned -* -* A11 A12 A13 -* A21 A22 A23 -* A31 A32 A33 -* -* Here A11, A21 and A31 denote the current block of JB columns -* which is about to be factorized. The number of rows in the -* partitioning are JB, I2, I3 respectively, and the numbers -* of columns are JB, J2, J3. The superdiagonal elements of A13 -* and the subdiagonal elements of A31 lie outside the band. -* - I2 = MIN( KL-JB, M-J-JB+1 ) - I3 = MIN( JB, M-J-KL+1 ) -* -* J2 and J3 are computed after JU has been updated. -* -* Factorize the current block of JB columns -* - DO 80 JJ = J, J + JB - 1 -* -* Set fill-in elements in column JJ+KV to zero -* - IF( JJ+KV.LE.N ) THEN - DO 70 I = 1, KL - AB( I, JJ+KV ) = ZERO - 70 CONTINUE - END IF -* -* Find pivot and test for singularity. KM is the number of -* subdiagonal elements in the current column. -* - KM = MIN( KL, M-JJ ) - JP = IDAMAX( KM+1, AB( KV+1, JJ ), 1 ) - IPIV( JJ ) = JP + JJ - J - IF( AB( KV+JP, JJ ).NE.ZERO ) THEN - JU = MAX( JU, MIN( JJ+KU+JP-1, N ) ) - IF( JP.NE.1 ) THEN -* -* Apply interchange to columns J to J+JB-1 -* - IF( JP+JJ-1.LT.J+KL ) THEN -* - CALL DSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1, - $ AB( KV+JP+JJ-J, J ), LDAB-1 ) - ELSE -* -* The interchange affects columns J to JJ-1 of A31 -* which are stored in the work array WORK31 -* - CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, - $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) - CALL DSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1, - $ AB( KV+JP, JJ ), LDAB-1 ) - END IF - END IF -* -* Compute multipliers -* - CALL DSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ), - $ 1 ) -* -* Update trailing submatrix within the band and within -* the current block. JM is the index of the last column -* which needs to be updated. -* - JM = MIN( JU, J+JB-1 ) - IF( JM.GT.JJ ) - $ CALL DGER( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1, - $ AB( KV, JJ+1 ), LDAB-1, - $ AB( KV+1, JJ+1 ), LDAB-1 ) - ELSE -* -* If pivot is zero, set INFO to the index of the pivot -* unless a zero pivot has already been found. -* - IF( INFO.EQ.0 ) - $ INFO = JJ - END IF -* -* Copy current column of A31 into the work array WORK31 -* - NW = MIN( JJ-J+1, I3 ) - IF( NW.GT.0 ) - $ CALL DCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1, - $ WORK31( 1, JJ-J+1 ), 1 ) - 80 CONTINUE - IF( J+JB.LE.N ) THEN -* -* Apply the row interchanges to the other blocks. -* - J2 = MIN( JU-J+1, KV ) - JB - J3 = MAX( 0, JU-J-KV+1 ) -* -* Use DLASWP to apply the row interchanges to A12, A22, and -* A32. -* - CALL DLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB, - $ IPIV( J ), 1 ) -* -* Adjust the pivot indices. -* - DO 90 I = J, J + JB - 1 - IPIV( I ) = IPIV( I ) + J - 1 - 90 CONTINUE -* -* Apply the row interchanges to A13, A23, and A33 -* columnwise. -* - K2 = J - 1 + JB + J2 - DO 110 I = 1, J3 - JJ = K2 + I - DO 100 II = J + I - 1, J + JB - 1 - IP = IPIV( II ) - IF( IP.NE.II ) THEN - TEMP = AB( KV+1+II-JJ, JJ ) - AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ ) - AB( KV+1+IP-JJ, JJ ) = TEMP - END IF - 100 CONTINUE - 110 CONTINUE -* -* Update the relevant part of the trailing submatrix -* - IF( J2.GT.0 ) THEN -* -* Update A12 -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ JB, J2, ONE, AB( KV+1, J ), LDAB-1, - $ AB( KV+1-JB, J+JB ), LDAB-1 ) -* - IF( I2.GT.0 ) THEN -* -* Update A22 -* - CALL DGEMM( 'No transpose', 'No transpose', I2, J2, - $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, - $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, - $ AB( KV+1, J+JB ), LDAB-1 ) - END IF -* - IF( I3.GT.0 ) THEN -* -* Update A32 -* - CALL DGEMM( 'No transpose', 'No transpose', I3, J2, - $ JB, -ONE, WORK31, LDWORK, - $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, - $ AB( KV+KL+1-JB, J+JB ), LDAB-1 ) - END IF - END IF -* - IF( J3.GT.0 ) THEN -* -* Copy the lower triangle of A13 into the work array -* WORK13 -* - DO 130 JJ = 1, J3 - DO 120 II = JJ, JB - WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 ) - 120 CONTINUE - 130 CONTINUE -* -* Update A13 in the work array -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ JB, J3, ONE, AB( KV+1, J ), LDAB-1, - $ WORK13, LDWORK ) -* - IF( I2.GT.0 ) THEN -* -* Update A23 -* - CALL DGEMM( 'No transpose', 'No transpose', I2, J3, - $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, - $ WORK13, LDWORK, ONE, AB( 1+JB, J+KV ), - $ LDAB-1 ) - END IF -* - IF( I3.GT.0 ) THEN -* -* Update A33 -* - CALL DGEMM( 'No transpose', 'No transpose', I3, J3, - $ JB, -ONE, WORK31, LDWORK, WORK13, - $ LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 ) - END IF -* -* Copy the lower triangle of A13 back into place -* - DO 150 JJ = 1, J3 - DO 140 II = JJ, JB - AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ ) - 140 CONTINUE - 150 CONTINUE - END IF - ELSE -* -* Adjust the pivot indices. -* - DO 160 I = J, J + JB - 1 - IPIV( I ) = IPIV( I ) + J - 1 - 160 CONTINUE - END IF -* -* Partially undo the interchanges in the current block to -* restore the upper triangular form of A31 and copy the upper -* triangle of A31 back into place -* - DO 170 JJ = J + JB - 1, J, -1 - JP = IPIV( JJ ) - JJ + 1 - IF( JP.NE.1 ) THEN -* -* Apply interchange to columns J to JJ-1 -* - IF( JP+JJ-1.LT.J+KL ) THEN -* -* The interchange does not affect A31 -* - CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, - $ AB( KV+JP+JJ-J, J ), LDAB-1 ) - ELSE -* -* The interchange does affect A31 -* - CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, - $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) - END IF - END IF -* -* Copy the current column of A31 back into place -* - NW = MIN( I3, JJ-J+1 ) - IF( NW.GT.0 ) - $ CALL DCOPY( NW, WORK31( 1, JJ-J+1 ), 1, - $ AB( KV+KL+1-JJ+J, JJ ), 1 ) - 170 CONTINUE - 180 CONTINUE - END IF -* - RETURN -* -* End of DGBTRF -* - END diff --git a/mtx/lapack_src/dgbtrs.f b/mtx/lapack_src/dgbtrs.f deleted file mode 100644 index f34ae750a..000000000 --- a/mtx/lapack_src/dgbtrs.f +++ /dev/null @@ -1,269 +0,0 @@ -*> \brief \b DGBTRS -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGBTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, -* INFO ) -* -* .. Scalar Arguments .. -* CHARACTER TRANS -* INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGBTRS solves a system of linear equations -*> A * X = B or A**T * X = B -*> with a general band matrix A using the LU factorization computed -*> by DGBTRF. -*> \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] KL -*> \verbatim -*> KL is INTEGER -*> The number of subdiagonals within the band of A. KL >= 0. -*> \endverbatim -*> -*> \param[in] KU -*> \verbatim -*> KU is INTEGER -*> The number of superdiagonals within the band of A. KU >= 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] AB -*> \verbatim -*> AB is DOUBLE PRECISION array, dimension (LDAB,N) -*> Details of the LU factorization of the band matrix A, as -*> computed by DGBTRF. U is stored as an upper triangular band -*> matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and -*> the multipliers used during the factorization are stored in -*> rows KL+KU+2 to 2*KL+KU+1. -*> \endverbatim -*> -*> \param[in] LDAB -*> \verbatim -*> LDAB is INTEGER -*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1. -*> \endverbatim -*> -*> \param[in] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (N) -*> The pivot indices; 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. -* -*> \date November 2011 -* -*> \ingroup doubleGBcomputational -* -* ===================================================================== - SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, - $ INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LNOTI, NOTRAN - INTEGER I, J, KD, L, LM -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DGER, DSWAP, DTBSV, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. 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( KL.LT.0 ) THEN - INFO = -3 - ELSE IF( KU.LT.0 ) THEN - INFO = -4 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -5 - ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGBTRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - KD = KU + KL + 1 - LNOTI = KL.GT.0 -* - IF( NOTRAN ) THEN -* -* Solve A*X = B. -* -* Solve L*X = B, overwriting B with X. -* -* L is represented as a product of permutations and unit lower -* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), -* where each transformation L(i) is a rank-one modification of -* the identity matrix. -* - IF( LNOTI ) THEN - DO 10 J = 1, N - 1 - LM = MIN( KL, N-J ) - L = IPIV( J ) - IF( L.NE.J ) - $ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) - CALL DGER( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ), - $ LDB, B( J+1, 1 ), LDB ) - 10 CONTINUE - END IF -* - DO 20 I = 1, NRHS -* -* Solve U*X = B, overwriting B with X. -* - CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU, - $ AB, LDAB, B( 1, I ), 1 ) - 20 CONTINUE -* - ELSE -* -* Solve A**T*X = B. -* - DO 30 I = 1, NRHS -* -* Solve U**T*X = B, overwriting B with X. -* - CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB, - $ LDAB, B( 1, I ), 1 ) - 30 CONTINUE -* -* Solve L**T*X = B, overwriting B with X. -* - IF( LNOTI ) THEN - DO 40 J = N - 1, 1, -1 - LM = MIN( KL, N-J ) - CALL DGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ), - $ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB ) - L = IPIV( J ) - IF( L.NE.J ) - $ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) - 40 CONTINUE - END IF - END IF - RETURN -* -* End of DGBTRS -* - END diff --git a/mtx/lapack_src/dgebak.f b/mtx/lapack_src/dgebak.f deleted file mode 100644 index 276a29818..000000000 --- a/mtx/lapack_src/dgebak.f +++ /dev/null @@ -1,268 +0,0 @@ -*> \brief \b DGEBAK -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGEBAK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, -* INFO ) -* -* .. Scalar Arguments .. -* CHARACTER JOB, SIDE -* INTEGER IHI, ILO, INFO, LDV, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION SCALE( * ), V( LDV, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGEBAK forms the right or left eigenvectors of a real general matrix -*> by backward transformation on the computed eigenvectors of the -*> balanced matrix output by DGEBAL. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] JOB -*> \verbatim -*> JOB is CHARACTER*1 -*> Specifies the type of backward transformation required: -*> = 'N', do nothing, return immediately; -*> = 'P', do backward transformation for permutation only; -*> = 'S', do backward transformation for scaling only; -*> = 'B', do backward transformations for both permutation and -*> scaling. -*> JOB must be the same as the argument JOB supplied to DGEBAL. -*> \endverbatim -*> -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'R': V contains right eigenvectors; -*> = 'L': V contains left eigenvectors. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of rows of the matrix V. N >= 0. -*> \endverbatim -*> -*> \param[in] ILO -*> \verbatim -*> ILO is INTEGER -*> \endverbatim -*> -*> \param[in] IHI -*> \verbatim -*> IHI is INTEGER -*> The integers ILO and IHI determined by DGEBAL. -*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. -*> \endverbatim -*> -*> \param[in] SCALE -*> \verbatim -*> SCALE is DOUBLE PRECISION array, dimension (N) -*> Details of the permutation and scaling factors, as returned -*> by DGEBAL. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of columns of the matrix V. M >= 0. -*> \endverbatim -*> -*> \param[in,out] V -*> \verbatim -*> V is DOUBLE PRECISION array, dimension (LDV,M) -*> On entry, the matrix of right or left eigenvectors to be -*> transformed, as returned by DHSEIN or DTREVC. -*> On exit, V is overwritten by the transformed eigenvectors. -*> \endverbatim -*> -*> \param[in] LDV -*> \verbatim -*> LDV is INTEGER -*> The leading dimension of the array V. LDV >= 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. -* -*> \date November 2011 -* -*> \ingroup doubleGEcomputational -* -* ===================================================================== - SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, - $ INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER JOB, SIDE - INTEGER IHI, ILO, INFO, LDV, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION SCALE( * ), V( LDV, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LEFTV, RIGHTV - INTEGER I, II, K - DOUBLE PRECISION S -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DSCAL, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Decode and Test the input parameters -* - RIGHTV = LSAME( SIDE, 'R' ) - LEFTV = LSAME( SIDE, 'L' ) -* - INFO = 0 - IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. - $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN - INFO = -1 - ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -7 - ELSE IF( LDV.LT.MAX( 1, N ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEBAK', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN - IF( M.EQ.0 ) - $ RETURN - IF( LSAME( JOB, 'N' ) ) - $ RETURN -* - IF( ILO.EQ.IHI ) - $ GO TO 30 -* -* Backward balance -* - IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN -* - IF( RIGHTV ) THEN - DO 10 I = ILO, IHI - S = SCALE( I ) - CALL DSCAL( M, S, V( I, 1 ), LDV ) - 10 CONTINUE - END IF -* - IF( LEFTV ) THEN - DO 20 I = ILO, IHI - S = ONE / SCALE( I ) - CALL DSCAL( M, S, V( I, 1 ), LDV ) - 20 CONTINUE - END IF -* - END IF -* -* Backward permutation -* -* For I = ILO-1 step -1 until 1, -* IHI+1 step 1 until N do -- -* - 30 CONTINUE - IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN - IF( RIGHTV ) THEN - DO 40 II = 1, N - I = II - IF( I.GE.ILO .AND. I.LE.IHI ) - $ GO TO 40 - IF( I.LT.ILO ) - $ I = ILO - II - K = SCALE( I ) - IF( K.EQ.I ) - $ GO TO 40 - CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) - 40 CONTINUE - END IF -* - IF( LEFTV ) THEN - DO 50 II = 1, N - I = II - IF( I.GE.ILO .AND. I.LE.IHI ) - $ GO TO 50 - IF( I.LT.ILO ) - $ I = ILO - II - K = SCALE( I ) - IF( K.EQ.I ) - $ GO TO 50 - CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) - 50 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEBAK -* - END diff --git a/mtx/lapack_src/dgebal.f b/mtx/lapack_src/dgebal.f deleted file mode 100644 index 5d7ed035c..000000000 --- a/mtx/lapack_src/dgebal.f +++ /dev/null @@ -1,405 +0,0 @@ -*> \brief \b DGEBAL -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGEBAL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER JOB -* INTEGER IHI, ILO, INFO, LDA, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), SCALE( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGEBAL balances a general real matrix A. This involves, first, -*> permuting A by a similarity transformation to isolate eigenvalues -*> in the first 1 to ILO-1 and last IHI+1 to N elements on the -*> diagonal; and second, applying a diagonal similarity transformation -*> to rows and columns ILO to IHI to make the rows and columns as -*> close in norm as possible. Both steps are optional. -*> -*> Balancing may reduce the 1-norm of the matrix, and improve the -*> accuracy of the computed eigenvalues and/or eigenvectors. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] JOB -*> \verbatim -*> JOB is CHARACTER*1 -*> Specifies the operations to be performed on A: -*> = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 -*> for i = 1,...,N; -*> = 'P': permute only; -*> = 'S': scale only; -*> = 'B': both permute and scale. -*> \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 array, dimension (LDA,N) -*> On entry, the input matrix A. -*> On exit, A is overwritten by the balanced matrix. -*> If JOB = 'N', A is not referenced. -*> 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] ILO -*> \verbatim -*> ILO is INTEGER -*> \endverbatim -*> \param[out] IHI -*> \verbatim -*> IHI is INTEGER -*> ILO and IHI are set to integers such that on exit -*> A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. -*> If JOB = 'N' or 'S', ILO = 1 and IHI = N. -*> \endverbatim -*> -*> \param[out] SCALE -*> \verbatim -*> SCALE is DOUBLE array, dimension (N) -*> Details of the permutations and scaling factors applied to -*> A. If P(j) is the index of the row and column interchanged -*> with row and column j and D(j) is the scaling factor -*> applied to row and column j, then -*> SCALE(j) = P(j) for j = 1,...,ILO-1 -*> = D(j) for j = ILO,...,IHI -*> = P(j) for j = IHI+1,...,N. -*> The order in which the interchanges are made is N to IHI+1, -*> then 1 to ILO-1. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleGEcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The permutations consist of row and column interchanges which put -*> the matrix in the form -*> -*> ( T1 X Y ) -*> P A P = ( 0 B Z ) -*> ( 0 0 T2 ) -*> -*> where T1 and T2 are upper triangular matrices whose eigenvalues lie -*> along the diagonal. The column indices ILO and IHI mark the starting -*> and ending columns of the submatrix B. Balancing consists of applying -*> a diagonal similarity transformation inv(D) * B * D to make the -*> 1-norms of each row of B and its corresponding column nearly equal. -*> The output matrix is -*> -*> ( T1 X*D Y ) -*> ( 0 inv(D)*B*D inv(D)*Z ). -*> ( 0 0 T2 ) -*> -*> Information about the permutations P and the diagonal matrix D is -*> returned in the vector SCALE. -*> -*> This subroutine is based on the EISPACK routine BALANC. -*> -*> Modified by Tzu-Yi Chen, Computer Science Division, University of -*> California at Berkeley, USA -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER JOB - INTEGER IHI, ILO, INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), SCALE( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - DOUBLE PRECISION SCLFAC - PARAMETER ( SCLFAC = 2.0D+0 ) - DOUBLE PRECISION FACTOR - PARAMETER ( FACTOR = 0.95D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOCONV - INTEGER I, ICA, IEXC, IRA, J, K, L, M - DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1, - $ SFMIN2 -* .. -* .. External Functions .. - LOGICAL DISNAN, LSAME - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL DISNAN, LSAME, IDAMAX, DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DSCAL, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. - $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) 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( 'DGEBAL', -INFO ) - RETURN - END IF -* - K = 1 - L = N -* - IF( N.EQ.0 ) - $ GO TO 210 -* - IF( LSAME( JOB, 'N' ) ) THEN - DO 10 I = 1, N - SCALE( I ) = ONE - 10 CONTINUE - GO TO 210 - END IF -* - IF( LSAME( JOB, 'S' ) ) - $ GO TO 120 -* -* Permutation to isolate eigenvalues if possible -* - GO TO 50 -* -* Row and column exchange. -* - 20 CONTINUE - SCALE( M ) = J - IF( J.EQ.M ) - $ GO TO 30 -* - CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) - CALL DSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA ) -* - 30 CONTINUE - GO TO ( 40, 80 )IEXC -* -* Search for rows isolating an eigenvalue and push them down. -* - 40 CONTINUE - IF( L.EQ.1 ) - $ GO TO 210 - L = L - 1 -* - 50 CONTINUE - DO 70 J = L, 1, -1 -* - DO 60 I = 1, L - IF( I.EQ.J ) - $ GO TO 60 - IF( A( J, I ).NE.ZERO ) - $ GO TO 70 - 60 CONTINUE -* - M = L - IEXC = 1 - GO TO 20 - 70 CONTINUE -* - GO TO 90 -* -* Search for columns isolating an eigenvalue and push them left. -* - 80 CONTINUE - K = K + 1 -* - 90 CONTINUE - DO 110 J = K, L -* - DO 100 I = K, L - IF( I.EQ.J ) - $ GO TO 100 - IF( A( I, J ).NE.ZERO ) - $ GO TO 110 - 100 CONTINUE -* - M = K - IEXC = 2 - GO TO 20 - 110 CONTINUE -* - 120 CONTINUE - DO 130 I = K, L - SCALE( I ) = ONE - 130 CONTINUE -* - IF( LSAME( JOB, 'P' ) ) - $ GO TO 210 -* -* Balance the submatrix in rows K to L. -* -* Iterative loop for norm reduction -* - SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) - SFMAX1 = ONE / SFMIN1 - SFMIN2 = SFMIN1*SCLFAC - SFMAX2 = ONE / SFMIN2 - 140 CONTINUE - NOCONV = .FALSE. -* - DO 200 I = K, L - C = ZERO - R = ZERO -* - DO 150 J = K, L - IF( J.EQ.I ) - $ GO TO 150 - C = C + ABS( A( J, I ) ) - R = R + ABS( A( I, J ) ) - 150 CONTINUE - ICA = IDAMAX( L, A( 1, I ), 1 ) - CA = ABS( A( ICA, I ) ) - IRA = IDAMAX( N-K+1, A( I, K ), LDA ) - RA = ABS( A( I, IRA+K-1 ) ) -* -* Guard against zero C or R due to underflow. -* - IF( C.EQ.ZERO .OR. R.EQ.ZERO ) - $ GO TO 200 - G = R / SCLFAC - F = ONE - S = C + R - 160 CONTINUE - IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR. - $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 170 - IF( DISNAN( C+F+CA+R+G+RA ) ) THEN -* -* Exit if NaN to avoid infinite loop -* - INFO = -3 - CALL XERBLA( 'DGEBAL', -INFO ) - RETURN - END IF - F = F*SCLFAC - C = C*SCLFAC - CA = CA*SCLFAC - R = R / SCLFAC - G = G / SCLFAC - RA = RA / SCLFAC - GO TO 160 -* - 170 CONTINUE - G = C / SCLFAC - 180 CONTINUE - IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR. - $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190 - F = F / SCLFAC - C = C / SCLFAC - G = G / SCLFAC - CA = CA / SCLFAC - R = R*SCLFAC - RA = RA*SCLFAC - GO TO 180 -* -* Now balance. -* - 190 CONTINUE - IF( ( C+R ).GE.FACTOR*S ) - $ GO TO 200 - IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN - IF( F*SCALE( I ).LE.SFMIN1 ) - $ GO TO 200 - END IF - IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN - IF( SCALE( I ).GE.SFMAX1 / F ) - $ GO TO 200 - END IF - G = ONE / F - SCALE( I ) = SCALE( I )*F - NOCONV = .TRUE. -* - CALL DSCAL( N-K+1, G, A( I, K ), LDA ) - CALL DSCAL( L, F, A( 1, I ), 1 ) -* - 200 CONTINUE -* - IF( NOCONV ) - $ GO TO 140 -* - 210 CONTINUE - ILO = K - IHI = L -* - RETURN -* -* End of DGEBAL -* - END diff --git a/mtx/lapack_src/dgebd2.f b/mtx/lapack_src/dgebd2.f deleted file mode 100644 index c35db4904..000000000 --- a/mtx/lapack_src/dgebd2.f +++ /dev/null @@ -1,320 +0,0 @@ -*> \brief \b DGEBD2 -* -* =========== 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. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER 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/mtx/lapack_src/dgebrd.f b/mtx/lapack_src/dgebrd.f deleted file mode 100644 index 6cb61f002..000000000 --- a/mtx/lapack_src/dgebrd.f +++ /dev/null @@ -1,353 +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. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER 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 - DOUBLE PRECISION 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/mtx/lapack_src/dgecon.f b/mtx/lapack_src/dgecon.f deleted file mode 100644 index df9d8e1c4..000000000 --- a/mtx/lapack_src/dgecon.f +++ /dev/null @@ -1,261 +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. -* -*> \date November 2011 -* -*> \ingroup doubleGEcomputational -* -* ===================================================================== - SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, - $ INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER 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/mtx/lapack_src/dgeequ.f b/mtx/lapack_src/dgeequ.f deleted file mode 100644 index a93af8f8d..000000000 --- a/mtx/lapack_src/dgeequ.f +++ /dev/null @@ -1,304 +0,0 @@ -*> \brief \b DGEEQU -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGEEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, -* INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, M, N -* DOUBLE PRECISION AMAX, COLCND, ROWCND -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGEEQU computes row and column scalings intended to equilibrate an -*> M-by-N matrix A and reduce its condition number. R returns the row -*> scale factors and C the column scale factors, chosen to try to make -*> the largest element in each row and column of the matrix B with -*> elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. -*> -*> R(i) and C(j) are restricted to be between SMLNUM = smallest safe -*> number and BIGNUM = largest safe number. Use of these scaling -*> factors is not guaranteed to reduce the condition number of A but -*> works well in practice. -*> \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] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The M-by-N matrix whose equilibration factors are -*> to be computed. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] R -*> \verbatim -*> R is DOUBLE PRECISION array, dimension (M) -*> If INFO = 0 or INFO > M, R contains the row scale factors -*> for A. -*> \endverbatim -*> -*> \param[out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (N) -*> If INFO = 0, C contains the column scale factors for A. -*> \endverbatim -*> -*> \param[out] ROWCND -*> \verbatim -*> ROWCND is DOUBLE PRECISION -*> If INFO = 0 or INFO > M, ROWCND contains the ratio of the -*> smallest R(i) to the largest R(i). If ROWCND >= 0.1 and -*> AMAX is neither too large nor too small, it is not worth -*> scaling by R. -*> \endverbatim -*> -*> \param[out] COLCND -*> \verbatim -*> COLCND is DOUBLE PRECISION -*> If INFO = 0, COLCND contains the ratio of the smallest -*> C(i) to the largest C(i). If COLCND >= 0.1, it is not -*> worth scaling by C. -*> \endverbatim -*> -*> \param[out] AMAX -*> \verbatim -*> AMAX is DOUBLE PRECISION -*> Absolute value of largest matrix element. If AMAX is very -*> close to overflow or very close to underflow, the matrix -*> should be scaled. -*> \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 i is -*> <= M: the i-th row of A is exactly zero -*> > M: the (i-M)-th column of A is exactly zero -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleGEcomputational -* -* ===================================================================== - SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, - $ INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N - DOUBLE PRECISION AMAX, COLCND, ROWCND -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, 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( 'DGEEQU', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - ROWCND = ONE - COLCND = ONE - AMAX = ZERO - RETURN - END IF -* -* Get machine constants. -* - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM -* -* Compute row scale factors. -* - DO 10 I = 1, M - R( I ) = ZERO - 10 CONTINUE -* -* Find the maximum element in each row. -* - DO 30 J = 1, N - DO 20 I = 1, M - R( I ) = MAX( R( I ), ABS( A( I, J ) ) ) - 20 CONTINUE - 30 CONTINUE -* -* Find the maximum and minimum scale factors. -* - RCMIN = BIGNUM - RCMAX = ZERO - DO 40 I = 1, M - RCMAX = MAX( RCMAX, R( I ) ) - RCMIN = MIN( RCMIN, R( I ) ) - 40 CONTINUE - AMAX = RCMAX -* - IF( RCMIN.EQ.ZERO ) THEN -* -* Find the first zero scale factor and return an error code. -* - DO 50 I = 1, M - IF( R( I ).EQ.ZERO ) THEN - INFO = I - RETURN - END IF - 50 CONTINUE - ELSE -* -* Invert the scale factors. -* - DO 60 I = 1, M - R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM ) - 60 CONTINUE -* -* Compute ROWCND = min(R(I)) / max(R(I)) -* - ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) - END IF -* -* Compute column scale factors -* - DO 70 J = 1, N - C( J ) = ZERO - 70 CONTINUE -* -* Find the maximum element in each column, -* assuming the row scaling computed above. -* - DO 90 J = 1, N - DO 80 I = 1, M - C( J ) = MAX( C( J ), ABS( A( I, J ) )*R( I ) ) - 80 CONTINUE - 90 CONTINUE -* -* Find the maximum and minimum scale factors. -* - RCMIN = BIGNUM - RCMAX = ZERO - DO 100 J = 1, N - RCMIN = MIN( RCMIN, C( J ) ) - RCMAX = MAX( RCMAX, C( J ) ) - 100 CONTINUE -* - IF( RCMIN.EQ.ZERO ) THEN -* -* Find the first zero scale factor and return an error code. -* - DO 110 J = 1, N - IF( C( J ).EQ.ZERO ) THEN - INFO = M + J - RETURN - END IF - 110 CONTINUE - ELSE -* -* Invert the scale factors. -* - DO 120 J = 1, N - C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM ) - 120 CONTINUE -* -* Compute COLCND = min(C(J)) / max(C(J)) -* - COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) - END IF -* - RETURN -* -* End of DGEEQU -* - END diff --git a/mtx/lapack_src/dgeev.f b/mtx/lapack_src/dgeev.f deleted file mode 100644 index f2cadb0d5..000000000 --- a/mtx/lapack_src/dgeev.f +++ /dev/null @@ -1,516 +0,0 @@ -*> \brief DGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGEEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, -* LDVR, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER JOBVL, JOBVR -* INTEGER INFO, LDA, LDVL, LDVR, LWORK, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), -* $ WI( * ), WORK( * ), WR( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGEEV computes for an N-by-N real nonsymmetric matrix A, the -*> eigenvalues and, optionally, the left and/or right eigenvectors. -*> -*> The right eigenvector v(j) of A satisfies -*> A * v(j) = lambda(j) * v(j) -*> where lambda(j) is its eigenvalue. -*> The left eigenvector u(j) of A satisfies -*> u(j)**T * A = lambda(j) * u(j)**T -*> where u(j)**T denotes the transpose of u(j). -*> -*> The computed eigenvectors are normalized to have Euclidean norm -*> equal to 1 and largest component real. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] JOBVL -*> \verbatim -*> JOBVL is CHARACTER*1 -*> = 'N': left eigenvectors of A are not computed; -*> = 'V': left eigenvectors of A are computed. -*> \endverbatim -*> -*> \param[in] JOBVR -*> \verbatim -*> JOBVR is CHARACTER*1 -*> = 'N': right eigenvectors of A are not computed; -*> = 'V': right eigenvectors of A are computed. -*> \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 N-by-N matrix A. -*> On exit, A has been overwritten. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] WR -*> \verbatim -*> WR is DOUBLE PRECISION array, dimension (N) -*> \endverbatim -*> -*> \param[out] WI -*> \verbatim -*> WI is DOUBLE PRECISION array, dimension (N) -*> WR and WI contain the real and imaginary parts, -*> respectively, of the computed eigenvalues. Complex -*> conjugate pairs of eigenvalues appear consecutively -*> with the eigenvalue having the positive imaginary part -*> first. -*> \endverbatim -*> -*> \param[out] VL -*> \verbatim -*> VL is DOUBLE PRECISION array, dimension (LDVL,N) -*> If JOBVL = 'V', the left eigenvectors u(j) are stored one -*> after another in the columns of VL, in the same order -*> as their eigenvalues. -*> If JOBVL = 'N', VL is not referenced. -*> If the j-th eigenvalue is real, then u(j) = VL(:,j), -*> the j-th column of VL. -*> If the j-th and (j+1)-st eigenvalues form a complex -*> conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and -*> u(j+1) = VL(:,j) - i*VL(:,j+1). -*> \endverbatim -*> -*> \param[in] LDVL -*> \verbatim -*> LDVL is INTEGER -*> The leading dimension of the array VL. LDVL >= 1; if -*> JOBVL = 'V', LDVL >= N. -*> \endverbatim -*> -*> \param[out] VR -*> \verbatim -*> VR is DOUBLE PRECISION array, dimension (LDVR,N) -*> If JOBVR = 'V', the right eigenvectors v(j) are stored one -*> after another in the columns of VR, in the same order -*> as their eigenvalues. -*> If JOBVR = 'N', VR is not referenced. -*> If the j-th eigenvalue is real, then v(j) = VR(:,j), -*> the j-th column of VR. -*> If the j-th and (j+1)-st eigenvalues form a complex -*> conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and -*> v(j+1) = VR(:,j) - i*VR(:,j+1). -*> \endverbatim -*> -*> \param[in] LDVR -*> \verbatim -*> LDVR is INTEGER -*> The leading dimension of the array VR. LDVR >= 1; if -*> JOBVR = 'V', LDVR >= 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. LWORK >= max(1,3*N), and -*> if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good -*> performance, LWORK must 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 INFO = i, the QR algorithm failed to compute all the -*> eigenvalues, and no eigenvectors have been computed; -*> elements i+1:N of WR and WI contain eigenvalues which -*> have converged. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleGEeigen -* -* ===================================================================== - SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, - $ LDVR, WORK, LWORK, INFO ) -* -* -- LAPACK driver routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER JOBVL, JOBVR - INTEGER INFO, LDA, LDVL, LDVR, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), - $ WI( * ), WORK( * ), WR( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, SCALEA, WANTVL, WANTVR - CHARACTER SIDE - INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K, - $ MAXWRK, MINWRK, NOUT - DOUBLE PRECISION ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM, - $ SN -* .. -* .. Local Arrays .. - LOGICAL SELECT( 1 ) - DOUBLE PRECISION DUM( 1 ) -* .. -* .. External Subroutines .. - EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY, - $ DLARTG, DLASCL, DORGHR, DROT, DSCAL, DTREVC, - $ XERBLA -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX, ILAENV - DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2, DNRM2 - EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DLANGE, DLAPY2, - $ DNRM2 -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) - WANTVL = LSAME( JOBVL, 'V' ) - WANTVR = LSAME( JOBVR, 'V' ) - IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN - INFO = -9 - ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) 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. -* HSWORK refers to the workspace preferred by DHSEQR, as -* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, -* the worst case.) -* - IF( INFO.EQ.0 ) THEN - IF( N.EQ.0 ) THEN - MINWRK = 1 - MAXWRK = 1 - ELSE - MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) - IF( WANTVL ) THEN - MINWRK = 4*N - MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, - $ 'DORGHR', ' ', N, 1, N, -1 ) ) - CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL, - $ WORK, -1, INFO ) - HSWORK = WORK( 1 ) - MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) - MAXWRK = MAX( MAXWRK, 4*N ) - ELSE IF( WANTVR ) THEN - MINWRK = 4*N - MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, - $ 'DORGHR', ' ', N, 1, N, -1 ) ) - CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR, - $ WORK, -1, INFO ) - HSWORK = WORK( 1 ) - MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) - MAXWRK = MAX( MAXWRK, 4*N ) - ELSE - MINWRK = 3*N - CALL DHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR, LDVR, - $ WORK, -1, INFO ) - HSWORK = WORK( 1 ) - MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) - END IF - MAXWRK = MAX( MAXWRK, MINWRK ) - END IF - WORK( 1 ) = MAXWRK -* - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEEV ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Get machine constants -* - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = SQRT( SMLNUM ) / EPS - BIGNUM = ONE / SMLNUM -* -* Scale A if max element outside range [SMLNUM,BIGNUM] -* - ANRM = DLANGE( 'M', N, N, A, LDA, DUM ) - SCALEA = .FALSE. - IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN - SCALEA = .TRUE. - CSCALE = SMLNUM - ELSE IF( ANRM.GT.BIGNUM ) THEN - SCALEA = .TRUE. - CSCALE = BIGNUM - END IF - IF( SCALEA ) - $ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) -* -* Balance the matrix -* (Workspace: need N) -* - IBAL = 1 - CALL DGEBAL( 'B', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR ) -* -* Reduce to upper Hessenberg form -* (Workspace: need 3*N, prefer 2*N+N*NB) -* - ITAU = IBAL + N - IWRK = ITAU + N - CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), - $ LWORK-IWRK+1, IERR ) -* - IF( WANTVL ) THEN -* -* Want left eigenvectors -* Copy Householder vectors to VL -* - SIDE = 'L' - CALL DLACPY( 'L', N, N, A, LDA, VL, LDVL ) -* -* Generate orthogonal matrix in VL -* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) -* - CALL DORGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ), - $ LWORK-IWRK+1, IERR ) -* -* Perform QR iteration, accumulating Schur vectors in VL -* (Workspace: need N+1, prefer N+HSWORK (see comments) ) -* - IWRK = ITAU - CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VL, LDVL, - $ WORK( IWRK ), LWORK-IWRK+1, INFO ) -* - IF( WANTVR ) THEN -* -* Want left and right eigenvectors -* Copy Schur vectors to VR -* - SIDE = 'B' - CALL DLACPY( 'F', N, N, VL, LDVL, VR, LDVR ) - END IF -* - ELSE IF( WANTVR ) THEN -* -* Want right eigenvectors -* Copy Householder vectors to VR -* - SIDE = 'R' - CALL DLACPY( 'L', N, N, A, LDA, VR, LDVR ) -* -* Generate orthogonal matrix in VR -* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) -* - CALL DORGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ), - $ LWORK-IWRK+1, IERR ) -* -* Perform QR iteration, accumulating Schur vectors in VR -* (Workspace: need N+1, prefer N+HSWORK (see comments) ) -* - IWRK = ITAU - CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR, - $ WORK( IWRK ), LWORK-IWRK+1, INFO ) -* - ELSE -* -* Compute eigenvalues only -* (Workspace: need N+1, prefer N+HSWORK (see comments) ) -* - IWRK = ITAU - CALL DHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR, - $ WORK( IWRK ), LWORK-IWRK+1, INFO ) - END IF -* -* If INFO > 0 from DHSEQR, then quit -* - IF( INFO.GT.0 ) - $ GO TO 50 -* - IF( WANTVL .OR. WANTVR ) THEN -* -* Compute left and/or right eigenvectors -* (Workspace: need 4*N) -* - CALL DTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, - $ N, NOUT, WORK( IWRK ), IERR ) - END IF -* - IF( WANTVL ) THEN -* -* Undo balancing of left eigenvectors -* (Workspace: need N) -* - CALL DGEBAK( 'B', 'L', N, ILO, IHI, WORK( IBAL ), N, VL, LDVL, - $ IERR ) -* -* Normalize left eigenvectors and make largest component real -* - DO 20 I = 1, N - IF( WI( I ).EQ.ZERO ) THEN - SCL = ONE / DNRM2( N, VL( 1, I ), 1 ) - CALL DSCAL( N, SCL, VL( 1, I ), 1 ) - ELSE IF( WI( I ).GT.ZERO ) THEN - SCL = ONE / DLAPY2( DNRM2( N, VL( 1, I ), 1 ), - $ DNRM2( N, VL( 1, I+1 ), 1 ) ) - CALL DSCAL( N, SCL, VL( 1, I ), 1 ) - CALL DSCAL( N, SCL, VL( 1, I+1 ), 1 ) - DO 10 K = 1, N - WORK( IWRK+K-1 ) = VL( K, I )**2 + VL( K, I+1 )**2 - 10 CONTINUE - K = IDAMAX( N, WORK( IWRK ), 1 ) - CALL DLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R ) - CALL DROT( N, VL( 1, I ), 1, VL( 1, I+1 ), 1, CS, SN ) - VL( K, I+1 ) = ZERO - END IF - 20 CONTINUE - END IF -* - IF( WANTVR ) THEN -* -* Undo balancing of right eigenvectors -* (Workspace: need N) -* - CALL DGEBAK( 'B', 'R', N, ILO, IHI, WORK( IBAL ), N, VR, LDVR, - $ IERR ) -* -* Normalize right eigenvectors and make largest component real -* - DO 40 I = 1, N - IF( WI( I ).EQ.ZERO ) THEN - SCL = ONE / DNRM2( N, VR( 1, I ), 1 ) - CALL DSCAL( N, SCL, VR( 1, I ), 1 ) - ELSE IF( WI( I ).GT.ZERO ) THEN - SCL = ONE / DLAPY2( DNRM2( N, VR( 1, I ), 1 ), - $ DNRM2( N, VR( 1, I+1 ), 1 ) ) - CALL DSCAL( N, SCL, VR( 1, I ), 1 ) - CALL DSCAL( N, SCL, VR( 1, I+1 ), 1 ) - DO 30 K = 1, N - WORK( IWRK+K-1 ) = VR( K, I )**2 + VR( K, I+1 )**2 - 30 CONTINUE - K = IDAMAX( N, WORK( IWRK ), 1 ) - CALL DLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R ) - CALL DROT( N, VR( 1, I ), 1, VR( 1, I+1 ), 1, CS, SN ) - VR( K, I+1 ) = ZERO - END IF - 40 CONTINUE - END IF -* -* Undo scaling if necessary -* - 50 CONTINUE - IF( SCALEA ) THEN - CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ), - $ MAX( N-INFO, 1 ), IERR ) - CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ), - $ MAX( N-INFO, 1 ), IERR ) - IF( INFO.GT.0 ) THEN - CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N, - $ IERR ) - CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N, - $ IERR ) - END IF - END IF -* - WORK( 1 ) = MAXWRK - RETURN -* -* End of DGEEV -* - END diff --git a/mtx/lapack_src/dgehd2.f b/mtx/lapack_src/dgehd2.f deleted file mode 100644 index 499b0d811..000000000 --- a/mtx/lapack_src/dgehd2.f +++ /dev/null @@ -1,225 +0,0 @@ -*> \brief \b DGEHD2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGEHD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER IHI, ILO, INFO, LDA, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGEHD2 reduces a real general matrix A to upper Hessenberg form H by -*> an orthogonal similarity transformation: Q**T * A * Q = H . -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in] ILO -*> \verbatim -*> ILO is INTEGER -*> \endverbatim -*> -*> \param[in] IHI -*> \verbatim -*> IHI is INTEGER -*> -*> It is assumed that A is already upper triangular in rows -*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally -*> set by a previous call to DGEBAL; otherwise they should be -*> set to 1 and N respectively. See Further Details. -*> 1 <= ILO <= IHI <= max(1,N). -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the n by n general matrix to be reduced. -*> On exit, the upper triangle and the first subdiagonal of A -*> are overwritten with the upper Hessenberg matrix H, 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] 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 (N) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleGEcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The matrix Q is represented as a product of (ihi-ilo) elementary -*> reflectors -*> -*> Q = H(ilo) H(ilo+1) . . . H(ihi-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, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on -*> exit in A(i+2:ihi,i), and tau in TAU(i). -*> -*> The contents of A are illustrated by the following example, with -*> n = 7, ilo = 2 and ihi = 6: -*> -*> on entry, on exit, -*> -*> ( a a a a a a a ) ( a a h h h h a ) -*> ( a a a a a a ) ( a h h h h a ) -*> ( a a a a a a ) ( h h h h h h ) -*> ( a a a a a a ) ( v2 h h h h h ) -*> ( a a a a a a ) ( v2 v3 h h h h ) -*> ( a a a a a a ) ( v2 v3 v4 h h h ) -*> ( a ) ( a ) -*> -*> where a denotes an element of the original matrix A, h denotes a -*> modified element of the upper Hessenberg matrix H, and vi denotes an -*> element of the vector defining H(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER IHI, ILO, INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I - DOUBLE PRECISION AII -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -2 - ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEHD2', -INFO ) - RETURN - END IF -* - DO 10 I = ILO, IHI - 1 -* -* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) -* - CALL DLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, - $ TAU( I ) ) - AII = A( I+1, I ) - A( I+1, I ) = ONE -* -* Apply H(i) to A(1:ihi,i+1:ihi) from the right -* - CALL DLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), - $ A( 1, I+1 ), LDA, WORK ) -* -* Apply H(i) to A(i+1:ihi,i+1:n) from the left -* - CALL DLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ), - $ A( I+1, I+1 ), LDA, WORK ) -* - A( I+1, I ) = AII - 10 CONTINUE -* - RETURN -* -* End of DGEHD2 -* - END diff --git a/mtx/lapack_src/dgehrd.f b/mtx/lapack_src/dgehrd.f deleted file mode 100644 index 0dda2e2f9..000000000 --- a/mtx/lapack_src/dgehrd.f +++ /dev/null @@ -1,352 +0,0 @@ -*> \brief \b DGEHRD -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGEHRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER IHI, ILO, INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGEHRD reduces a real general matrix A to upper Hessenberg form H by -*> an orthogonal similarity transformation: Q**T * A * Q = H . -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in] ILO -*> \verbatim -*> ILO is INTEGER -*> \endverbatim -*> -*> \param[in] IHI -*> \verbatim -*> IHI is INTEGER -*> -*> It is assumed that A is already upper triangular in rows -*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally -*> set by a previous call to DGEBAL; otherwise they should be -*> set to 1 and N respectively. See Further Details. -*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the N-by-N general matrix to be reduced. -*> On exit, the upper triangle and the first subdiagonal of A -*> are overwritten with the upper Hessenberg matrix H, 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] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (N-1) -*> The scalar factors of the elementary reflectors (see Further -*> Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to -*> zero. -*> \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 length 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 had an illegal value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleGEcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The matrix Q is represented as a product of (ihi-ilo) elementary -*> reflectors -*> -*> Q = H(ilo) H(ilo+1) . . . H(ihi-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, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on -*> exit in A(i+2:ihi,i), and tau in TAU(i). -*> -*> The contents of A are illustrated by the following example, with -*> n = 7, ilo = 2 and ihi = 6: -*> -*> on entry, on exit, -*> -*> ( a a a a a a a ) ( a a h h h h a ) -*> ( a a a a a a ) ( a h h h h a ) -*> ( a a a a a a ) ( h h h h h h ) -*> ( a a a a a a ) ( v2 h h h h h ) -*> ( a a a a a a ) ( v2 v3 h h h h ) -*> ( a a a a a a ) ( v2 v3 v4 h h h ) -*> ( a ) ( a ) -*> -*> where a denotes an element of the original matrix A, h denotes a -*> modified element of the upper Hessenberg matrix H, and vi denotes an -*> element of the vector defining H(i). -*> -*> This file is a slight modification of LAPACK-3.0's DGEHRD -*> subroutine incorporating improvements proposed by Quintana-Orti and -*> Van de Geijn (2006). (See DLAHR2.) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER IHI, ILO, INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT - PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, - $ ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, J, LDWORK, LWKOPT, NB, - $ NBMIN, NH, NX - DOUBLE PRECISION EI -* .. -* .. Local Arrays .. - DOUBLE PRECISION T( LDT, NBMAX ) -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DGEHD2, DGEMM, DLAHR2, DLARFB, DTRMM, - $ XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -2 - ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) 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( 'DGEHRD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero -* - DO 10 I = 1, ILO - 1 - TAU( I ) = ZERO - 10 CONTINUE - DO 20 I = MAX( 1, IHI ), N - 1 - TAU( I ) = ZERO - 20 CONTINUE -* -* Quick return if possible -* - NH = IHI - ILO + 1 - IF( NH.LE.1 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* -* Determine the block size -* - NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) - NBMIN = 2 - IWS = 1 - IF( NB.GT.1 .AND. NB.LT.NH ) THEN -* -* Determine when to cross over from blocked to unblocked code -* (last block is always handled by unblocked code) -* - NX = MAX( NB, ILAENV( 3, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) - IF( NX.LT.NH ) THEN -* -* Determine if workspace is large enough for blocked code -* - IWS = N*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 -* - NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N, ILO, IHI, - $ -1 ) ) - IF( LWORK.GE.N*NBMIN ) THEN - NB = LWORK / N - ELSE - NB = 1 - END IF - END IF - END IF - END IF - LDWORK = N -* - IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN -* -* Use unblocked code below -* - I = ILO -* - ELSE -* -* Use blocked code -* - DO 40 I = ILO, IHI - 1 - NX, NB - IB = MIN( NB, IHI-I ) -* -* Reduce columns i:i+ib-1 to Hessenberg form, returning the -* matrices V and T of the block reflector H = I - V*T*V**T -* which performs the reduction, and also the matrix Y = A*V*T -* - CALL DLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT, - $ WORK, LDWORK ) -* -* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the -* right, computing A := A - Y * V**T. V(i+ib,ib-1) must be set -* to 1 -* - EI = A( I+IB, I+IB-1 ) - A( I+IB, I+IB-1 ) = ONE - CALL DGEMM( 'No transpose', 'Transpose', - $ IHI, IHI-I-IB+1, - $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE, - $ A( 1, I+IB ), LDA ) - A( I+IB, I+IB-1 ) = EI -* -* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the -* right -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', - $ 'Unit', I, IB-1, - $ ONE, A( I+1, I ), LDA, WORK, LDWORK ) - DO 30 J = 0, IB-2 - CALL DAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1, - $ A( 1, I+J+1 ), 1 ) - 30 CONTINUE -* -* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the -* left -* - CALL DLARFB( 'Left', 'Transpose', 'Forward', - $ 'Columnwise', - $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT, - $ A( I+1, I+IB ), LDA, WORK, LDWORK ) - 40 CONTINUE - END IF -* -* Use unblocked code to reduce the rest of the matrix -* - CALL DGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO ) - WORK( 1 ) = IWS -* - RETURN -* -* End of DGEHRD -* - END diff --git a/mtx/lapack_src/dgelq2.f b/mtx/lapack_src/dgelq2.f deleted file mode 100644 index 73315c9c8..000000000 --- a/mtx/lapack_src/dgelq2.f +++ /dev/null @@ -1,192 +0,0 @@ -*> \brief \b DGELQ2 -* -* =========== 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 * Q. -*> \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. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER 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/mtx/lapack_src/dgelqf.f b/mtx/lapack_src/dgelqf.f deleted file mode 100644 index d27b04ab1..000000000 --- a/mtx/lapack_src/dgelqf.f +++ /dev/null @@ -1,269 +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 * Q. -*> \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. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER 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/mtx/lapack_src/dgeqr2.f b/mtx/lapack_src/dgeqr2.f deleted file mode 100644 index d253d6bd6..000000000 --- a/mtx/lapack_src/dgeqr2.f +++ /dev/null @@ -1,192 +0,0 @@ -*> \brief \b DGEQR2 -* -* =========== 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. -*> \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. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER 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/mtx/lapack_src/dgeqrf.f b/mtx/lapack_src/dgeqrf.f deleted file mode 100644 index 299025758..000000000 --- a/mtx/lapack_src/dgeqrf.f +++ /dev/null @@ -1,270 +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. -*> \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 >= 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 had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER 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 -* - INFO = 0 - NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - LWKOPT = N*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, N ) .AND. .NOT.LQUERY ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQRF', -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 = 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/mtx/lapack_src/dgerfs.f b/mtx/lapack_src/dgerfs.f deleted file mode 100644 index 9a48db9e1..000000000 --- a/mtx/lapack_src/dgerfs.f +++ /dev/null @@ -1,438 +0,0 @@ -*> \brief \b DGERFS -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGERFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, -* X, LDX, FERR, BERR, WORK, IWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER TRANS -* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ), IWORK( * ) -* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), -* $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGERFS improves the computed solution to a system of linear -*> equations and provides error bounds and backward error estimates for -*> the solution. -*> \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**H * 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 matrices B and X. NRHS >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The original N-by-N matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] AF -*> \verbatim -*> AF is DOUBLE PRECISION array, dimension (LDAF,N) -*> The factors L and U from the factorization A = P*L*U -*> as computed by DGETRF. -*> \endverbatim -*> -*> \param[in] LDAF -*> \verbatim -*> LDAF is INTEGER -*> The leading dimension of the array AF. LDAF >= 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] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) -*> The right hand side matrix B. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,N). -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) -*> On entry, the solution matrix X, as computed by DGETRS. -*> On exit, the improved solution matrix X. -*> \endverbatim -*> -*> \param[in] LDX -*> \verbatim -*> LDX is INTEGER -*> The leading dimension of the array X. LDX >= max(1,N). -*> \endverbatim -*> -*> \param[out] FERR -*> \verbatim -*> FERR is DOUBLE PRECISION array, dimension (NRHS) -*> The estimated forward error bound for each solution vector -*> X(j) (the j-th column of the solution matrix X). -*> If XTRUE is the true solution corresponding to X(j), FERR(j) -*> is an estimated upper bound for the magnitude of the largest -*> element in (X(j) - XTRUE) divided by the magnitude of the -*> largest element in X(j). The estimate is as reliable as -*> the estimate for RCOND, and is almost always a slight -*> overestimate of the true error. -*> \endverbatim -*> -*> \param[out] BERR -*> \verbatim -*> BERR is DOUBLE PRECISION array, dimension (NRHS) -*> The componentwise relative backward error of each solution -*> vector X(j) (i.e., the smallest relative change in -*> any element of A or B that makes X(j) an exact solution). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (3*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 -* -*> \par Internal Parameters: -* ========================= -*> -*> \verbatim -*> ITMAX is the maximum number of steps of iterative refinement. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleGEcomputational -* -* ===================================================================== - SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, - $ X, LDX, FERR, BERR, WORK, IWORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ), IWORK( * ) - DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), - $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER ITMAX - PARAMETER ( ITMAX = 5 ) - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D+0 ) - DOUBLE PRECISION THREE - PARAMETER ( THREE = 3.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN - CHARACTER TRANST - INTEGER COUNT, I, J, K, KASE, NZ - DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK -* .. -* .. Local Arrays .. - INTEGER ISAVE( 3 ) -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DGETRS, DLACN2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, DLAMCH -* .. -* .. 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( LDAF.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -12 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGERFS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN - DO 10 J = 1, NRHS - FERR( J ) = ZERO - BERR( J ) = ZERO - 10 CONTINUE - RETURN - END IF -* - IF( NOTRAN ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF -* -* NZ = maximum number of nonzero elements in each row of A, plus 1 -* - NZ = N + 1 - EPS = DLAMCH( 'Epsilon' ) - SAFMIN = DLAMCH( 'Safe minimum' ) - SAFE1 = NZ*SAFMIN - SAFE2 = SAFE1 / EPS -* -* Do for each right hand side -* - DO 140 J = 1, NRHS -* - COUNT = 1 - LSTRES = THREE - 20 CONTINUE -* -* Loop until stopping criterion is satisfied. -* -* Compute residual R = B - op(A) * X, -* where op(A) = A, A**T, or A**H, depending on TRANS. -* - CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 ) - CALL DGEMV( TRANS, N, N, -ONE, A, LDA, X( 1, J ), 1, ONE, - $ WORK( N+1 ), 1 ) -* -* Compute componentwise relative backward error from formula -* -* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) -* -* where abs(Z) is the componentwise absolute value of the matrix -* or vector Z. If the i-th component of the denominator is less -* than SAFE2, then SAFE1 is added to the i-th components of the -* numerator and denominator before dividing. -* - DO 30 I = 1, N - WORK( I ) = ABS( B( I, J ) ) - 30 CONTINUE -* -* Compute abs(op(A))*abs(X) + abs(B). -* - IF( NOTRAN ) THEN - DO 50 K = 1, N - XK = ABS( X( K, J ) ) - DO 40 I = 1, N - WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK - 40 CONTINUE - 50 CONTINUE - ELSE - DO 70 K = 1, N - S = ZERO - DO 60 I = 1, N - S = S + ABS( A( I, K ) )*ABS( X( I, J ) ) - 60 CONTINUE - WORK( K ) = WORK( K ) + S - 70 CONTINUE - END IF - S = ZERO - DO 80 I = 1, N - IF( WORK( I ).GT.SAFE2 ) THEN - S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) ) - ELSE - S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) / - $ ( WORK( I )+SAFE1 ) ) - END IF - 80 CONTINUE - BERR( J ) = S -* -* Test stopping criterion. Continue iterating if -* 1) The residual BERR(J) is larger than machine epsilon, and -* 2) BERR(J) decreased by at least a factor of 2 during the -* last iteration, and -* 3) At most ITMAX iterations tried. -* - IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND. - $ COUNT.LE.ITMAX ) THEN -* -* Update solution and try again. -* - CALL DGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N, - $ INFO ) - CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 ) - LSTRES = BERR( J ) - COUNT = COUNT + 1 - GO TO 20 - END IF -* -* Bound error from formula -* -* norm(X - XTRUE) / norm(X) .le. FERR = -* norm( abs(inv(op(A)))* -* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) -* -* where -* norm(Z) is the magnitude of the largest component of Z -* inv(op(A)) is the inverse of op(A) -* abs(Z) is the componentwise absolute value of the matrix or -* vector Z -* NZ is the maximum number of nonzeros in any row of A, plus 1 -* EPS is machine epsilon -* -* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) -* is incremented by SAFE1 if the i-th component of -* abs(op(A))*abs(X) + abs(B) is less than SAFE2. -* -* Use DLACN2 to estimate the infinity-norm of the matrix -* inv(op(A)) * diag(W), -* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) -* - DO 90 I = 1, N - IF( WORK( I ).GT.SAFE2 ) THEN - WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) - ELSE - WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1 - END IF - 90 CONTINUE -* - KASE = 0 - 100 CONTINUE - CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ), - $ KASE, ISAVE ) - IF( KASE.NE.0 ) THEN - IF( KASE.EQ.1 ) THEN -* -* Multiply by diag(W)*inv(op(A)**T). -* - CALL DGETRS( TRANST, N, 1, AF, LDAF, IPIV, WORK( N+1 ), - $ N, INFO ) - DO 110 I = 1, N - WORK( N+I ) = WORK( I )*WORK( N+I ) - 110 CONTINUE - ELSE -* -* Multiply by inv(op(A))*diag(W). -* - DO 120 I = 1, N - WORK( N+I ) = WORK( I )*WORK( N+I ) - 120 CONTINUE - CALL DGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N, - $ INFO ) - END IF - GO TO 100 - END IF -* -* Normalize error. -* - LSTRES = ZERO - DO 130 I = 1, N - LSTRES = MAX( LSTRES, ABS( X( I, J ) ) ) - 130 CONTINUE - IF( LSTRES.NE.ZERO ) - $ FERR( J ) = FERR( J ) / LSTRES -* - 140 CONTINUE -* - RETURN -* -* End of DGERFS -* - END diff --git a/mtx/lapack_src/dgesv.f b/mtx/lapack_src/dgesv.f deleted file mode 100644 index 8d47f839d..000000000 --- a/mtx/lapack_src/dgesv.f +++ /dev/null @@ -1,179 +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. -* -*> \date November 2011 -* -*> \ingroup doubleGEsolve -* -* ===================================================================== - SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK driver routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER 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/mtx/lapack_src/dgesvd.f b/mtx/lapack_src/dgesvd.f deleted file mode 100644 index 898570b66..000000000 --- a/mtx/lapack_src/dgesvd.f +++ /dev/null @@ -1,3493 +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. -* -*> \date April 2012 -* -*> \ingroup doubleGEsing -* -* ===================================================================== - SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, - $ VT, LDVT, WORK, LWORK, INFO ) -* -* -- LAPACK driver routine (version 3.4.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 -* -* .. Scalar Arguments .. - CHARACTER 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=DUM(1) -* Compute space needed for DORGQR - CALL DORGQR( M, N, N, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_DORGQR_N=DUM(1) - CALL DORGQR( M, M, N, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_DORGQR_M=DUM(1) -* Compute space needed for DGEBRD - CALL DGEBRD( N, N, A, LDA, S, DUM(1), DUM(1), - $ DUM(1), DUM(1), -1, IERR ) - LWORK_DGEBRD=DUM(1) -* Compute space needed for DORGBR P - CALL DORGBR( 'P', N, N, N, A, LDA, DUM(1), - $ DUM(1), -1, IERR ) - LWORK_DORGBR_P=DUM(1) -* Compute space needed for DORGBR Q - CALL DORGBR( 'Q', N, N, N, A, LDA, DUM(1), - $ DUM(1), -1, IERR ) - LWORK_DORGBR_Q=DUM(1) -* - 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=DUM(1) - MAXWRK = 3*N + LWORK_DGEBRD - IF( WNTUS .OR. WNTUO ) THEN - CALL DORGBR( 'Q', M, N, N, A, LDA, DUM(1), - $ DUM(1), -1, IERR ) - LWORK_DORGBR_Q=DUM(1) - MAXWRK = MAX( MAXWRK, 3*N+LWORK_DORGBR_Q ) - END IF - IF( WNTUA ) THEN - CALL DORGBR( 'Q', M, M, N, A, LDA, DUM(1), - $ DUM(1), -1, IERR ) - LWORK_DORGBR_Q=DUM(1) - MAXWRK = MAX( MAXWRK, 3*N+LWORK_DORGBR_Q ) - 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=DUM(1) -* Compute space needed for DORGLQ - CALL DORGLQ( N, N, M, DUM(1), N, DUM(1), DUM(1), -1, IERR ) - LWORK_DORGLQ_N=DUM(1) - CALL DORGLQ( M, N, M, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_DORGLQ_M=DUM(1) -* Compute space needed for DGEBRD - CALL DGEBRD( M, M, A, LDA, S, DUM(1), DUM(1), - $ DUM(1), DUM(1), -1, IERR ) - LWORK_DGEBRD=DUM(1) -* Compute space needed for DORGBR P - CALL DORGBR( 'P', M, M, M, A, N, DUM(1), - $ DUM(1), -1, IERR ) - LWORK_DORGBR_P=DUM(1) -* Compute space needed for DORGBR Q - CALL DORGBR( 'Q', M, M, M, A, N, DUM(1), - $ DUM(1), -1, IERR ) - LWORK_DORGBR_Q=DUM(1) - 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=DUM(1) - MAXWRK = 3*M + LWORK_DGEBRD - IF( WNTVS .OR. WNTVO ) THEN -* Compute space needed for DORGBR P - CALL DORGBR( 'P', M, N, M, A, N, DUM(1), - $ DUM(1), -1, IERR ) - LWORK_DORGBR_P=DUM(1) - MAXWRK = MAX( MAXWRK, 3*M+LWORK_DORGBR_P ) - END IF - IF( WNTVA ) THEN - CALL DORGBR( 'P', N, N, M, A, N, DUM(1), - $ DUM(1), -1, IERR ) - LWORK_DORGBR_P=DUM(1) - MAXWRK = MAX( MAXWRK, 3*M+LWORK_DORGBR_P ) - 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 -* - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA ) - 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 -* - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), - $ LDA ) -* -* 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 -* - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), - $ LDA ) -* -* 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 -* - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), - $ LDA ) -* -* 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 -* - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), - $ LDA ) -* -* 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/mtx/lapack_src/dgesvx.f b/mtx/lapack_src/dgesvx.f deleted file mode 100644 index aac205324..000000000 --- a/mtx/lapack_src/dgesvx.f +++ /dev/null @@ -1,602 +0,0 @@ -*> \brief DGESVX 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 DGESVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, -* EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, -* WORK, IWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER EQUED, FACT, TRANS -* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS -* DOUBLE PRECISION RCOND -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ), IWORK( * ) -* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), -* $ BERR( * ), C( * ), FERR( * ), R( * ), -* $ WORK( * ), X( LDX, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGESVX uses the LU factorization to compute 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. -*> -*> Error bounds on the solution and a condition estimate are also -*> provided. -*> \endverbatim -* -*> \par Description: -* ================= -*> -*> \verbatim -*> -*> The following steps are performed: -*> -*> 1. If FACT = 'E', real scaling factors are computed to equilibrate -*> the system: -*> TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B -*> TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B -*> TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B -*> Whether or not the system will be equilibrated depends on the -*> scaling of the matrix A, but if equilibration is used, A is -*> overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') -*> or diag(C)*B (if TRANS = 'T' or 'C'). -*> -*> 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the -*> matrix A (after equilibration if FACT = 'E') as -*> A = P * L * U, -*> where P is a permutation matrix, L is a unit lower triangular -*> matrix, and U is upper triangular. -*> -*> 3. If some U(i,i)=0, so that U is exactly singular, then the routine -*> returns with INFO = i. Otherwise, the factored form of A is used -*> to estimate the condition number of the matrix A. If the -*> reciprocal of the condition number is less than machine precision, -*> INFO = N+1 is returned as a warning, but the routine still goes on -*> to solve for X and compute error bounds as described below. -*> -*> 4. The system of equations is solved for X using the factored form -*> of A. -*> -*> 5. Iterative refinement is applied to improve the computed solution -*> matrix and calculate error bounds and backward error estimates -*> for it. -*> -*> 6. If equilibration was used, the matrix X is premultiplied by -*> diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so -*> that it solves the original system before equilibration. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] FACT -*> \verbatim -*> FACT is CHARACTER*1 -*> Specifies whether or not the factored form of the matrix A is -*> supplied on entry, and if not, whether the matrix A should be -*> equilibrated before it is factored. -*> = 'F': On entry, AF and IPIV contain the factored form of A. -*> If EQUED is not 'N', the matrix A has been -*> equilibrated with scaling factors given by R and C. -*> A, AF, and IPIV are not modified. -*> = 'N': The matrix A will be copied to AF and factored. -*> = 'E': The matrix A will be equilibrated if necessary, then -*> copied to AF and factored. -*> \endverbatim -*> -*> \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**H * X = B (Transpose) -*> \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 matrices B and X. NRHS >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is -*> not 'N', then A must have been equilibrated by the scaling -*> factors in R and/or C. A is not modified if FACT = 'F' or -*> 'N', or if FACT = 'E' and EQUED = 'N' on exit. -*> -*> On exit, if EQUED .ne. 'N', A is scaled as follows: -*> EQUED = 'R': A := diag(R) * A -*> EQUED = 'C': A := A * diag(C) -*> EQUED = 'B': A := diag(R) * A * diag(C). -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in,out] AF -*> \verbatim -*> AF is DOUBLE PRECISION array, dimension (LDAF,N) -*> If FACT = 'F', then AF is an input argument and on entry -*> contains the factors L and U from the factorization -*> A = P*L*U as computed by DGETRF. If EQUED .ne. 'N', then -*> AF is the factored form of the equilibrated matrix A. -*> -*> If FACT = 'N', then AF is an output argument and on exit -*> returns the factors L and U from the factorization A = P*L*U -*> of the original matrix A. -*> -*> If FACT = 'E', then AF is an output argument and on exit -*> returns the factors L and U from the factorization A = P*L*U -*> of the equilibrated matrix A (see the description of A for -*> the form of the equilibrated matrix). -*> \endverbatim -*> -*> \param[in] LDAF -*> \verbatim -*> LDAF is INTEGER -*> The leading dimension of the array AF. LDAF >= max(1,N). -*> \endverbatim -*> -*> \param[in,out] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (N) -*> If FACT = 'F', then IPIV is an input argument and on entry -*> contains the pivot indices from the factorization A = P*L*U -*> as computed by DGETRF; row i of the matrix was interchanged -*> with row IPIV(i). -*> -*> If FACT = 'N', then IPIV is an output argument and on exit -*> contains the pivot indices from the factorization A = P*L*U -*> of the original matrix A. -*> -*> If FACT = 'E', then IPIV is an output argument and on exit -*> contains the pivot indices from the factorization A = P*L*U -*> of the equilibrated matrix A. -*> \endverbatim -*> -*> \param[in,out] EQUED -*> \verbatim -*> EQUED is CHARACTER*1 -*> Specifies the form of equilibration that was done. -*> = 'N': No equilibration (always true if FACT = 'N'). -*> = 'R': Row equilibration, i.e., A has been premultiplied by -*> diag(R). -*> = 'C': Column equilibration, i.e., A has been postmultiplied -*> by diag(C). -*> = 'B': Both row and column equilibration, i.e., A has been -*> replaced by diag(R) * A * diag(C). -*> EQUED is an input argument if FACT = 'F'; otherwise, it is an -*> output argument. -*> \endverbatim -*> -*> \param[in,out] R -*> \verbatim -*> R is DOUBLE PRECISION array, dimension (N) -*> The row scale factors for A. If EQUED = 'R' or 'B', A is -*> multiplied on the left by diag(R); if EQUED = 'N' or 'C', R -*> is not accessed. R is an input argument if FACT = 'F'; -*> otherwise, R is an output argument. If FACT = 'F' and -*> EQUED = 'R' or 'B', each element of R must be positive. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (N) -*> The column scale factors for A. If EQUED = 'C' or 'B', A is -*> multiplied on the right by diag(C); if EQUED = 'N' or 'R', C -*> is not accessed. C is an input argument if FACT = 'F'; -*> otherwise, C is an output argument. If FACT = 'F' and -*> EQUED = 'C' or 'B', each element of C must be positive. -*> \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 EQUED = 'N', B is not modified; -*> if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by -*> diag(R)*B; -*> if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is -*> overwritten by diag(C)*B. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,N). -*> \endverbatim -*> -*> \param[out] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) -*> If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X -*> to the original system of equations. Note that A and B are -*> modified on exit if EQUED .ne. 'N', and the solution to the -*> equilibrated system is inv(diag(C))*X if TRANS = 'N' and -*> EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' -*> and EQUED = 'R' or 'B'. -*> \endverbatim -*> -*> \param[in] LDX -*> \verbatim -*> LDX is INTEGER -*> The leading dimension of the array X. LDX >= max(1,N). -*> \endverbatim -*> -*> \param[out] RCOND -*> \verbatim -*> RCOND is DOUBLE PRECISION -*> The estimate of the reciprocal condition number of the matrix -*> A after equilibration (if done). If RCOND is less than the -*> machine precision (in particular, if RCOND = 0), the matrix -*> is singular to working precision. This condition is -*> indicated by a return code of INFO > 0. -*> \endverbatim -*> -*> \param[out] FERR -*> \verbatim -*> FERR is DOUBLE PRECISION array, dimension (NRHS) -*> The estimated forward error bound for each solution vector -*> X(j) (the j-th column of the solution matrix X). -*> If XTRUE is the true solution corresponding to X(j), FERR(j) -*> is an estimated upper bound for the magnitude of the largest -*> element in (X(j) - XTRUE) divided by the magnitude of the -*> largest element in X(j). The estimate is as reliable as -*> the estimate for RCOND, and is almost always a slight -*> overestimate of the true error. -*> \endverbatim -*> -*> \param[out] BERR -*> \verbatim -*> BERR is DOUBLE PRECISION array, dimension (NRHS) -*> The componentwise relative backward error of each solution -*> vector X(j) (i.e., the smallest relative change in -*> any element of A or B that makes X(j) an exact solution). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (4*N) -*> On exit, WORK(1) contains the reciprocal pivot growth -*> factor norm(A)/norm(U). The "max absolute element" norm is -*> used. If WORK(1) is much less than 1, then the stability -*> of the LU factorization of the (equilibrated) matrix A -*> could be poor. This also means that the solution X, condition -*> estimator RCOND, and forward error bound FERR could be -*> unreliable. If factorization fails with 0 WORK(1) contains the reciprocal pivot growth factor for the -*> leading INFO columns of A. -*> \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 -*> > 0: if INFO = i, and i is -*> <= N: U(i,i) is exactly zero. The factorization has -*> been completed, but the factor U is exactly -*> singular, so the solution and error bounds -*> could not be computed. RCOND = 0 is returned. -*> = N+1: U is nonsingular, but RCOND is less than machine -*> precision, meaning that the matrix is singular -*> to working precision. Nevertheless, the -*> solution and error bounds are computed because -*> there are a number of situations where the -*> computed solution can be more accurate than the -*> value of RCOND would suggest. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date April 2012 -* -*> \ingroup doubleGEsolve -* -* ===================================================================== - SUBROUTINE DGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, - $ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, - $ WORK, IWORK, INFO ) -* -* -- LAPACK driver routine (version 3.4.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 -* -* .. Scalar Arguments .. - CHARACTER EQUED, FACT, TRANS - INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS - DOUBLE PRECISION RCOND -* .. -* .. Array Arguments .. - INTEGER IPIV( * ), IWORK( * ) - DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), - $ BERR( * ), C( * ), FERR( * ), R( * ), - $ WORK( * ), X( LDX, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU - CHARACTER NORM - INTEGER I, INFEQU, J - DOUBLE PRECISION AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN, - $ ROWCND, RPVGRW, SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE, DLANTR - EXTERNAL LSAME, DLAMCH, DLANGE, DLANTR -* .. -* .. External Subroutines .. - EXTERNAL DGECON, DGEEQU, DGERFS, DGETRF, DGETRS, DLACPY, - $ DLAQGE, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* - INFO = 0 - NOFACT = LSAME( FACT, 'N' ) - EQUIL = LSAME( FACT, 'E' ) - NOTRAN = LSAME( TRANS, 'N' ) - IF( NOFACT .OR. EQUIL ) THEN - EQUED = 'N' - ROWEQU = .FALSE. - COLEQU = .FALSE. - ELSE - ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) - COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) - SMLNUM = DLAMCH( 'Safe minimum' ) - BIGNUM = ONE / SMLNUM - END IF -* -* Test the input parameters. -* - IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) ) - $ THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. - $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN - INFO = -10 - ELSE - IF( ROWEQU ) THEN - RCMIN = BIGNUM - RCMAX = ZERO - DO 10 J = 1, N - RCMIN = MIN( RCMIN, R( J ) ) - RCMAX = MAX( RCMAX, R( J ) ) - 10 CONTINUE - IF( RCMIN.LE.ZERO ) THEN - INFO = -11 - ELSE IF( N.GT.0 ) THEN - ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) - ELSE - ROWCND = ONE - END IF - END IF - IF( COLEQU .AND. INFO.EQ.0 ) THEN - RCMIN = BIGNUM - RCMAX = ZERO - DO 20 J = 1, N - RCMIN = MIN( RCMIN, C( J ) ) - RCMAX = MAX( RCMAX, C( J ) ) - 20 CONTINUE - IF( RCMIN.LE.ZERO ) THEN - INFO = -12 - ELSE IF( N.GT.0 ) THEN - COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) - ELSE - COLCND = ONE - END IF - END IF - IF( INFO.EQ.0 ) THEN - IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -16 - END IF - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGESVX', -INFO ) - RETURN - END IF -* - IF( EQUIL ) THEN -* -* Compute row and column scalings to equilibrate the matrix A. -* - CALL DGEEQU( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFEQU ) - IF( INFEQU.EQ.0 ) THEN -* -* Equilibrate the matrix. -* - CALL DLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, - $ EQUED ) - ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) - COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) - END IF - END IF -* -* Scale the right hand side. -* - IF( NOTRAN ) THEN - IF( ROWEQU ) THEN - DO 40 J = 1, NRHS - DO 30 I = 1, N - B( I, J ) = R( I )*B( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE IF( COLEQU ) THEN - DO 60 J = 1, NRHS - DO 50 I = 1, N - B( I, J ) = C( I )*B( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF -* - IF( NOFACT .OR. EQUIL ) THEN -* -* Compute the LU factorization of A. -* - CALL DLACPY( 'Full', N, N, A, LDA, AF, LDAF ) - CALL DGETRF( N, N, AF, LDAF, IPIV, INFO ) -* -* Return if INFO is non-zero. -* - IF( INFO.GT.0 ) THEN -* -* Compute the reciprocal pivot growth factor of the -* leading rank-deficient INFO columns of A. -* - RPVGRW = DLANTR( 'M', 'U', 'N', INFO, INFO, AF, LDAF, - $ WORK ) - IF( RPVGRW.EQ.ZERO ) THEN - RPVGRW = ONE - ELSE - RPVGRW = DLANGE( 'M', N, INFO, A, LDA, WORK ) / RPVGRW - END IF - WORK( 1 ) = RPVGRW - RCOND = ZERO - RETURN - END IF - END IF -* -* Compute the norm of the matrix A and the -* reciprocal pivot growth factor RPVGRW. -* - IF( NOTRAN ) THEN - NORM = '1' - ELSE - NORM = 'I' - END IF - ANORM = DLANGE( NORM, N, N, A, LDA, WORK ) - RPVGRW = DLANTR( 'M', 'U', 'N', N, N, AF, LDAF, WORK ) - IF( RPVGRW.EQ.ZERO ) THEN - RPVGRW = ONE - ELSE - RPVGRW = DLANGE( 'M', N, N, A, LDA, WORK ) / RPVGRW - END IF -* -* Compute the reciprocal of the condition number of A. -* - CALL DGECON( NORM, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO ) -* -* Compute the solution matrix X. -* - CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) - CALL DGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) -* -* Use iterative refinement to improve the computed solution and -* compute error bounds and backward error estimates for it. -* - CALL DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, - $ LDX, FERR, BERR, WORK, IWORK, INFO ) -* -* Transform the solution matrix X to a solution of the original -* system. -* - IF( NOTRAN ) THEN - IF( COLEQU ) THEN - DO 80 J = 1, NRHS - DO 70 I = 1, N - X( I, J ) = C( I )*X( I, J ) - 70 CONTINUE - 80 CONTINUE - DO 90 J = 1, NRHS - FERR( J ) = FERR( J ) / COLCND - 90 CONTINUE - END IF - ELSE IF( ROWEQU ) THEN - DO 110 J = 1, NRHS - DO 100 I = 1, N - X( I, J ) = R( I )*X( I, J ) - 100 CONTINUE - 110 CONTINUE - DO 120 J = 1, NRHS - FERR( J ) = FERR( J ) / ROWCND - 120 CONTINUE - END IF -* - WORK( 1 ) = RPVGRW -* -* Set INFO = N+1 if the matrix is singular to working precision. -* - IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) - $ INFO = N + 1 - RETURN -* -* End of DGESVX -* - END diff --git a/mtx/lapack_src/dgetf2.f b/mtx/lapack_src/dgetf2.f deleted file mode 100644 index ebe99ab93..000000000 --- a/mtx/lapack_src/dgetf2.f +++ /dev/null @@ -1,213 +0,0 @@ -*> \brief \b DGETF2 -* -* =========== 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. -* -*> \date November 2011 -* -*> \ingroup doubleGEcomputational -* -* ===================================================================== - SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER 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/mtx/lapack_src/dgetrf.f b/mtx/lapack_src/dgetrf.f deleted file mode 100644 index 45bb97f30..000000000 --- a/mtx/lapack_src/dgetrf.f +++ /dev/null @@ -1,225 +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. -* -*> \date November 2011 -* -*> \ingroup doubleGEcomputational -* -* ===================================================================== - SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER 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, DGETF2, 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 DGETF2( 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 DGETF2( 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/mtx/lapack_src/dgetri.f b/mtx/lapack_src/dgetri.f deleted file mode 100644 index ad5324c07..000000000 --- a/mtx/lapack_src/dgetri.f +++ /dev/null @@ -1,261 +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. -* -*> \date November 2011 -* -*> \ingroup doubleGEcomputational -* -* ===================================================================== - SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER 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/mtx/lapack_src/dgetrs.f b/mtx/lapack_src/dgetrs.f deleted file mode 100644 index 02e9832af..000000000 --- a/mtx/lapack_src/dgetrs.f +++ /dev/null @@ -1,225 +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. -* -*> \date November 2011 -* -*> \ingroup doubleGEcomputational -* -* ===================================================================== - SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER 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/mtx/lapack_src/dgtcon.f b/mtx/lapack_src/dgtcon.f deleted file mode 100644 index 500fa0dfb..000000000 --- a/mtx/lapack_src/dgtcon.f +++ /dev/null @@ -1,255 +0,0 @@ -*> \brief \b DGTCON -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGTCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, -* WORK, IWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER NORM -* INTEGER INFO, N -* DOUBLE PRECISION ANORM, RCOND -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ), IWORK( * ) -* DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGTCON estimates the reciprocal of the condition number of a real -*> tridiagonal matrix A using the LU factorization as computed by -*> DGTTRF. -*> -*> An estimate is obtained for norm(inv(A)), and the reciprocal of the -*> condition number is computed as RCOND = 1 / (ANORM * 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] DL -*> \verbatim -*> DL is DOUBLE PRECISION array, dimension (N-1) -*> The (n-1) multipliers that define the matrix L from the -*> LU factorization of A as computed by DGTTRF. -*> \endverbatim -*> -*> \param[in] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> The n diagonal elements of the upper triangular matrix U from -*> the LU factorization of A. -*> \endverbatim -*> -*> \param[in] DU -*> \verbatim -*> DU is DOUBLE PRECISION array, dimension (N-1) -*> The (n-1) elements of the first superdiagonal of U. -*> \endverbatim -*> -*> \param[in] DU2 -*> \verbatim -*> DU2 is DOUBLE PRECISION array, dimension (N-2) -*> The (n-2) elements of the second superdiagonal of U. -*> \endverbatim -*> -*> \param[in] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (N) -*> The pivot indices; for 1 <= i <= n, row i of the matrix was -*> interchanged with row IPIV(i). IPIV(i) will always be either -*> i or i+1; IPIV(i) = i indicates a row interchange was not -*> required. -*> \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/(ANORM * AINVNM), where AINVNM is an -*> estimate of the 1-norm of inv(A) computed in this routine. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (2*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. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, - $ WORK, IWORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER NORM - INTEGER INFO, N - DOUBLE PRECISION ANORM, RCOND -* .. -* .. Array Arguments .. - INTEGER IPIV( * ), IWORK( * ) - DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL ONENRM - INTEGER I, KASE, KASE1 - DOUBLE PRECISION AINVNM -* .. -* .. Local Arrays .. - INTEGER ISAVE( 3 ) -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DGTTRS, DLACN2, XERBLA -* .. -* .. Executable Statements .. -* -* Test the input arguments. -* - 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( ANORM.LT.ZERO ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGTCON', -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 -* -* Check that D(1:N) is non-zero. -* - DO 10 I = 1, N - IF( D( I ).EQ.ZERO ) - $ RETURN - 10 CONTINUE -* - AINVNM = ZERO - IF( ONENRM ) THEN - KASE1 = 1 - ELSE - KASE1 = 2 - END IF - KASE = 0 - 20 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(U)*inv(L). -* - CALL DGTTRS( 'No transpose', N, 1, DL, D, DU, DU2, IPIV, - $ WORK, N, INFO ) - ELSE -* -* Multiply by inv(L**T)*inv(U**T). -* - CALL DGTTRS( 'Transpose', N, 1, DL, D, DU, DU2, IPIV, WORK, - $ N, INFO ) - END IF - GO TO 20 - END IF -* -* Compute the estimate of the reciprocal condition number. -* - IF( AINVNM.NE.ZERO ) - $ RCOND = ( ONE / AINVNM ) / ANORM -* - RETURN -* -* End of DGTCON -* - END diff --git a/mtx/lapack_src/dgtrfs.f b/mtx/lapack_src/dgtrfs.f deleted file mode 100644 index 932945b1d..000000000 --- a/mtx/lapack_src/dgtrfs.f +++ /dev/null @@ -1,474 +0,0 @@ -*> \brief \b DGTRFS -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGTRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, -* IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, -* INFO ) -* -* .. Scalar Arguments .. -* CHARACTER TRANS -* INTEGER INFO, LDB, LDX, N, NRHS -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ), IWORK( * ) -* DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), -* $ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ), -* $ FERR( * ), WORK( * ), X( LDX, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGTRFS improves the computed solution to a system of linear -*> equations when the coefficient matrix is tridiagonal, and provides -*> error bounds and backward error estimates for the solution. -*> \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**H * 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] DL -*> \verbatim -*> DL is DOUBLE PRECISION array, dimension (N-1) -*> The (n-1) subdiagonal elements of A. -*> \endverbatim -*> -*> \param[in] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> The diagonal elements of A. -*> \endverbatim -*> -*> \param[in] DU -*> \verbatim -*> DU is DOUBLE PRECISION array, dimension (N-1) -*> The (n-1) superdiagonal elements of A. -*> \endverbatim -*> -*> \param[in] DLF -*> \verbatim -*> DLF is DOUBLE PRECISION array, dimension (N-1) -*> The (n-1) multipliers that define the matrix L from the -*> LU factorization of A as computed by DGTTRF. -*> \endverbatim -*> -*> \param[in] DF -*> \verbatim -*> DF is DOUBLE PRECISION array, dimension (N) -*> The n diagonal elements of the upper triangular matrix U from -*> the LU factorization of A. -*> \endverbatim -*> -*> \param[in] DUF -*> \verbatim -*> DUF is DOUBLE PRECISION array, dimension (N-1) -*> The (n-1) elements of the first superdiagonal of U. -*> \endverbatim -*> -*> \param[in] DU2 -*> \verbatim -*> DU2 is DOUBLE PRECISION array, dimension (N-2) -*> The (n-2) elements of the second superdiagonal of U. -*> \endverbatim -*> -*> \param[in] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (N) -*> The pivot indices; for 1 <= i <= n, row i of the matrix was -*> interchanged with row IPIV(i). IPIV(i) will always be either -*> i or i+1; IPIV(i) = i indicates a row interchange was not -*> required. -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) -*> The right hand side matrix B. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,N). -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) -*> On entry, the solution matrix X, as computed by DGTTRS. -*> On exit, the improved solution matrix X. -*> \endverbatim -*> -*> \param[in] LDX -*> \verbatim -*> LDX is INTEGER -*> The leading dimension of the array X. LDX >= max(1,N). -*> \endverbatim -*> -*> \param[out] FERR -*> \verbatim -*> FERR is DOUBLE PRECISION array, dimension (NRHS) -*> The estimated forward error bound for each solution vector -*> X(j) (the j-th column of the solution matrix X). -*> If XTRUE is the true solution corresponding to X(j), FERR(j) -*> is an estimated upper bound for the magnitude of the largest -*> element in (X(j) - XTRUE) divided by the magnitude of the -*> largest element in X(j). The estimate is as reliable as -*> the estimate for RCOND, and is almost always a slight -*> overestimate of the true error. -*> \endverbatim -*> -*> \param[out] BERR -*> \verbatim -*> BERR is DOUBLE PRECISION array, dimension (NRHS) -*> The componentwise relative backward error of each solution -*> vector X(j) (i.e., the smallest relative change in -*> any element of A or B that makes X(j) an exact solution). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (3*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 -* -*> \par Internal Parameters: -* ========================= -*> -*> \verbatim -*> ITMAX is the maximum number of steps of iterative refinement. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, - $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, - $ INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDB, LDX, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ), IWORK( * ) - DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), - $ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ), - $ FERR( * ), WORK( * ), X( LDX, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER ITMAX - PARAMETER ( ITMAX = 5 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D+0 ) - DOUBLE PRECISION THREE - PARAMETER ( THREE = 3.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN - CHARACTER TRANSN, TRANST - INTEGER COUNT, I, J, KASE, NZ - DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN -* .. -* .. Local Arrays .. - INTEGER ISAVE( 3 ) -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGTTRS, DLACN2, DLAGTM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, DLAMCH -* .. -* .. 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( LDB.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -15 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGTRFS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN - DO 10 J = 1, NRHS - FERR( J ) = ZERO - BERR( J ) = ZERO - 10 CONTINUE - RETURN - END IF -* - IF( NOTRAN ) THEN - TRANSN = 'N' - TRANST = 'T' - ELSE - TRANSN = 'T' - TRANST = 'N' - END IF -* -* NZ = maximum number of nonzero elements in each row of A, plus 1 -* - NZ = 4 - EPS = DLAMCH( 'Epsilon' ) - SAFMIN = DLAMCH( 'Safe minimum' ) - SAFE1 = NZ*SAFMIN - SAFE2 = SAFE1 / EPS -* -* Do for each right hand side -* - DO 110 J = 1, NRHS -* - COUNT = 1 - LSTRES = THREE - 20 CONTINUE -* -* Loop until stopping criterion is satisfied. -* -* Compute residual R = B - op(A) * X, -* where op(A) = A, A**T, or A**H, depending on TRANS. -* - CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 ) - CALL DLAGTM( TRANS, N, 1, -ONE, DL, D, DU, X( 1, J ), LDX, ONE, - $ WORK( N+1 ), N ) -* -* Compute abs(op(A))*abs(x) + abs(b) for use in the backward -* error bound. -* - IF( NOTRAN ) THEN - IF( N.EQ.1 ) THEN - WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) - ELSE - WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) + - $ ABS( DU( 1 )*X( 2, J ) ) - DO 30 I = 2, N - 1 - WORK( I ) = ABS( B( I, J ) ) + - $ ABS( DL( I-1 )*X( I-1, J ) ) + - $ ABS( D( I )*X( I, J ) ) + - $ ABS( DU( I )*X( I+1, J ) ) - 30 CONTINUE - WORK( N ) = ABS( B( N, J ) ) + - $ ABS( DL( N-1 )*X( N-1, J ) ) + - $ ABS( D( N )*X( N, J ) ) - END IF - ELSE - IF( N.EQ.1 ) THEN - WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) - ELSE - WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) + - $ ABS( DL( 1 )*X( 2, J ) ) - DO 40 I = 2, N - 1 - WORK( I ) = ABS( B( I, J ) ) + - $ ABS( DU( I-1 )*X( I-1, J ) ) + - $ ABS( D( I )*X( I, J ) ) + - $ ABS( DL( I )*X( I+1, J ) ) - 40 CONTINUE - WORK( N ) = ABS( B( N, J ) ) + - $ ABS( DU( N-1 )*X( N-1, J ) ) + - $ ABS( D( N )*X( N, J ) ) - END IF - END IF -* -* Compute componentwise relative backward error from formula -* -* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) -* -* where abs(Z) is the componentwise absolute value of the matrix -* or vector Z. If the i-th component of the denominator is less -* than SAFE2, then SAFE1 is added to the i-th components of the -* numerator and denominator before dividing. -* - S = ZERO - DO 50 I = 1, N - IF( WORK( I ).GT.SAFE2 ) THEN - S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) ) - ELSE - S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) / - $ ( WORK( I )+SAFE1 ) ) - END IF - 50 CONTINUE - BERR( J ) = S -* -* Test stopping criterion. Continue iterating if -* 1) The residual BERR(J) is larger than machine epsilon, and -* 2) BERR(J) decreased by at least a factor of 2 during the -* last iteration, and -* 3) At most ITMAX iterations tried. -* - IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND. - $ COUNT.LE.ITMAX ) THEN -* -* Update solution and try again. -* - CALL DGTTRS( TRANS, N, 1, DLF, DF, DUF, DU2, IPIV, - $ WORK( N+1 ), N, INFO ) - CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 ) - LSTRES = BERR( J ) - COUNT = COUNT + 1 - GO TO 20 - END IF -* -* Bound error from formula -* -* norm(X - XTRUE) / norm(X) .le. FERR = -* norm( abs(inv(op(A)))* -* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) -* -* where -* norm(Z) is the magnitude of the largest component of Z -* inv(op(A)) is the inverse of op(A) -* abs(Z) is the componentwise absolute value of the matrix or -* vector Z -* NZ is the maximum number of nonzeros in any row of A, plus 1 -* EPS is machine epsilon -* -* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) -* is incremented by SAFE1 if the i-th component of -* abs(op(A))*abs(X) + abs(B) is less than SAFE2. -* -* Use DLACN2 to estimate the infinity-norm of the matrix -* inv(op(A)) * diag(W), -* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) -* - DO 60 I = 1, N - IF( WORK( I ).GT.SAFE2 ) THEN - WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) - ELSE - WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1 - END IF - 60 CONTINUE -* - KASE = 0 - 70 CONTINUE - CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ), - $ KASE, ISAVE ) - IF( KASE.NE.0 ) THEN - IF( KASE.EQ.1 ) THEN -* -* Multiply by diag(W)*inv(op(A)**T). -* - CALL DGTTRS( TRANST, N, 1, DLF, DF, DUF, DU2, IPIV, - $ WORK( N+1 ), N, INFO ) - DO 80 I = 1, N - WORK( N+I ) = WORK( I )*WORK( N+I ) - 80 CONTINUE - ELSE -* -* Multiply by inv(op(A))*diag(W). -* - DO 90 I = 1, N - WORK( N+I ) = WORK( I )*WORK( N+I ) - 90 CONTINUE - CALL DGTTRS( TRANSN, N, 1, DLF, DF, DUF, DU2, IPIV, - $ WORK( N+1 ), N, INFO ) - END IF - GO TO 70 - END IF -* -* Normalize error. -* - LSTRES = ZERO - DO 100 I = 1, N - LSTRES = MAX( LSTRES, ABS( X( I, J ) ) ) - 100 CONTINUE - IF( LSTRES.NE.ZERO ) - $ FERR( J ) = FERR( J ) / LSTRES -* - 110 CONTINUE -* - RETURN -* -* End of DGTRFS -* - END diff --git a/mtx/lapack_src/dgtsv.f b/mtx/lapack_src/dgtsv.f deleted file mode 100644 index b170b92cf..000000000 --- a/mtx/lapack_src/dgtsv.f +++ /dev/null @@ -1,333 +0,0 @@ -*> \brief \b DGTSV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGTSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDB, N, NRHS -* .. -* .. Array Arguments .. -* DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGTSV solves the equation -*> -*> A*X = B, -*> -*> where A is an n by n tridiagonal matrix, by Gaussian elimination with -*> partial pivoting. -*> -*> Note that the equation A**T*X = B may be solved by interchanging the -*> order of the arguments DU and DL. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \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,out] DL -*> \verbatim -*> DL is DOUBLE PRECISION array, dimension (N-1) -*> On entry, DL must contain the (n-1) sub-diagonal elements of -*> A. -*> -*> On exit, DL is overwritten by the (n-2) elements of the -*> second super-diagonal of the upper triangular matrix U from -*> the LU factorization of A, in DL(1), ..., DL(n-2). -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, D must contain the diagonal elements of A. -*> -*> On exit, D is overwritten by the n diagonal elements of U. -*> \endverbatim -*> -*> \param[in,out] DU -*> \verbatim -*> DU is DOUBLE PRECISION array, dimension (N-1) -*> On entry, DU must contain the (n-1) super-diagonal elements -*> of A. -*> -*> On exit, DU is overwritten by the (n-1) elements of the first -*> super-diagonal of U. -*> \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, and the solution -*> has not been computed. The factorization has not been -*> completed unless i = N. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INFO, LDB, N, NRHS -* .. -* .. Array Arguments .. - DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION FACT, TEMP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -2 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGTSV ', -INFO ) - RETURN - END IF -* - IF( N.EQ.0 ) - $ RETURN -* - IF( NRHS.EQ.1 ) THEN - DO 10 I = 1, N - 2 - IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN -* -* No row interchange required -* - IF( D( I ).NE.ZERO ) THEN - FACT = DL( I ) / D( I ) - D( I+1 ) = D( I+1 ) - FACT*DU( I ) - B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 ) - ELSE - INFO = I - RETURN - END IF - DL( I ) = ZERO - ELSE -* -* Interchange rows I and I+1 -* - FACT = D( I ) / DL( I ) - D( I ) = DL( I ) - TEMP = D( I+1 ) - D( I+1 ) = DU( I ) - FACT*TEMP - DL( I ) = DU( I+1 ) - DU( I+1 ) = -FACT*DL( I ) - DU( I ) = TEMP - TEMP = B( I, 1 ) - B( I, 1 ) = B( I+1, 1 ) - B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 ) - END IF - 10 CONTINUE - IF( N.GT.1 ) THEN - I = N - 1 - IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN - IF( D( I ).NE.ZERO ) THEN - FACT = DL( I ) / D( I ) - D( I+1 ) = D( I+1 ) - FACT*DU( I ) - B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 ) - ELSE - INFO = I - RETURN - END IF - ELSE - FACT = D( I ) / DL( I ) - D( I ) = DL( I ) - TEMP = D( I+1 ) - D( I+1 ) = DU( I ) - FACT*TEMP - DU( I ) = TEMP - TEMP = B( I, 1 ) - B( I, 1 ) = B( I+1, 1 ) - B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 ) - END IF - END IF - IF( D( N ).EQ.ZERO ) THEN - INFO = N - RETURN - END IF - ELSE - DO 40 I = 1, N - 2 - IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN -* -* No row interchange required -* - IF( D( I ).NE.ZERO ) THEN - FACT = DL( I ) / D( I ) - D( I+1 ) = D( I+1 ) - FACT*DU( I ) - DO 20 J = 1, NRHS - B( I+1, J ) = B( I+1, J ) - FACT*B( I, J ) - 20 CONTINUE - ELSE - INFO = I - RETURN - END IF - DL( I ) = ZERO - ELSE -* -* Interchange rows I and I+1 -* - FACT = D( I ) / DL( I ) - D( I ) = DL( I ) - TEMP = D( I+1 ) - D( I+1 ) = DU( I ) - FACT*TEMP - DL( I ) = DU( I+1 ) - DU( I+1 ) = -FACT*DL( I ) - DU( I ) = TEMP - DO 30 J = 1, NRHS - TEMP = B( I, J ) - B( I, J ) = B( I+1, J ) - B( I+1, J ) = TEMP - FACT*B( I+1, J ) - 30 CONTINUE - END IF - 40 CONTINUE - IF( N.GT.1 ) THEN - I = N - 1 - IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN - IF( D( I ).NE.ZERO ) THEN - FACT = DL( I ) / D( I ) - D( I+1 ) = D( I+1 ) - FACT*DU( I ) - DO 50 J = 1, NRHS - B( I+1, J ) = B( I+1, J ) - FACT*B( I, J ) - 50 CONTINUE - ELSE - INFO = I - RETURN - END IF - ELSE - FACT = D( I ) / DL( I ) - D( I ) = DL( I ) - TEMP = D( I+1 ) - D( I+1 ) = DU( I ) - FACT*TEMP - DU( I ) = TEMP - DO 60 J = 1, NRHS - TEMP = B( I, J ) - B( I, J ) = B( I+1, J ) - B( I+1, J ) = TEMP - FACT*B( I+1, J ) - 60 CONTINUE - END IF - END IF - IF( D( N ).EQ.ZERO ) THEN - INFO = N - RETURN - END IF - END IF -* -* Back solve with the matrix U from the factorization. -* - IF( NRHS.LE.2 ) THEN - J = 1 - 70 CONTINUE - B( N, J ) = B( N, J ) / D( N ) - IF( N.GT.1 ) - $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / D( N-1 ) - DO 80 I = N - 2, 1, -1 - B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )* - $ B( I+2, J ) ) / D( I ) - 80 CONTINUE - IF( J.LT.NRHS ) THEN - J = J + 1 - GO TO 70 - END IF - ELSE - DO 100 J = 1, NRHS - B( N, J ) = B( N, J ) / D( N ) - IF( N.GT.1 ) - $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / - $ D( N-1 ) - DO 90 I = N - 2, 1, -1 - B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )* - $ B( I+2, J ) ) / D( I ) - 90 CONTINUE - 100 CONTINUE - END IF -* - RETURN -* -* End of DGTSV -* - END diff --git a/mtx/lapack_src/dgtsvx.f b/mtx/lapack_src/dgtsvx.f deleted file mode 100644 index 4f4818c7e..000000000 --- a/mtx/lapack_src/dgtsvx.f +++ /dev/null @@ -1,414 +0,0 @@ -*> \brief \b DGTSVX -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGTSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, -* DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, -* WORK, IWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER FACT, TRANS -* INTEGER INFO, LDB, LDX, N, NRHS -* DOUBLE PRECISION RCOND -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ), IWORK( * ) -* DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), -* $ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ), -* $ FERR( * ), WORK( * ), X( LDX, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGTSVX uses the LU factorization to compute the solution to a real -*> system of linear equations A * X = B or A**T * X = B, -*> where A is a tridiagonal matrix of order N and X and B are N-by-NRHS -*> matrices. -*> -*> Error bounds on the solution and a condition estimate are also -*> provided. -*> \endverbatim -* -*> \par Description: -* ================= -*> -*> \verbatim -*> -*> The following steps are performed: -*> -*> 1. If FACT = 'N', the LU decomposition is used to factor the matrix A -*> as A = L * U, where L is a product of permutation and unit lower -*> bidiagonal matrices and U is upper triangular with nonzeros in -*> only the main diagonal and first two superdiagonals. -*> -*> 2. If some U(i,i)=0, so that U is exactly singular, then the routine -*> returns with INFO = i. Otherwise, the factored form of A is used -*> to estimate the condition number of the matrix A. If the -*> reciprocal of the condition number is less than machine precision, -*> INFO = N+1 is returned as a warning, but the routine still goes on -*> to solve for X and compute error bounds as described below. -*> -*> 3. The system of equations is solved for X using the factored form -*> of A. -*> -*> 4. Iterative refinement is applied to improve the computed solution -*> matrix and calculate error bounds and backward error estimates -*> for it. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] FACT -*> \verbatim -*> FACT is CHARACTER*1 -*> Specifies whether or not the factored form of A has been -*> supplied on entry. -*> = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored -*> form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV -*> will not be modified. -*> = 'N': The matrix will be copied to DLF, DF, and DUF -*> and factored. -*> \endverbatim -*> -*> \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**H * 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] DL -*> \verbatim -*> DL is DOUBLE PRECISION array, dimension (N-1) -*> The (n-1) subdiagonal elements of A. -*> \endverbatim -*> -*> \param[in] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> The n diagonal elements of A. -*> \endverbatim -*> -*> \param[in] DU -*> \verbatim -*> DU is DOUBLE PRECISION array, dimension (N-1) -*> The (n-1) superdiagonal elements of A. -*> \endverbatim -*> -*> \param[in,out] DLF -*> \verbatim -*> DLF is DOUBLE PRECISION array, dimension (N-1) -*> If FACT = 'F', then DLF is an input argument and on entry -*> contains the (n-1) multipliers that define the matrix L from -*> the LU factorization of A as computed by DGTTRF. -*> -*> If FACT = 'N', then DLF is an output argument and on exit -*> contains the (n-1) multipliers that define the matrix L from -*> the LU factorization of A. -*> \endverbatim -*> -*> \param[in,out] DF -*> \verbatim -*> DF is DOUBLE PRECISION array, dimension (N) -*> If FACT = 'F', then DF is an input argument and on entry -*> contains the n diagonal elements of the upper triangular -*> matrix U from the LU factorization of A. -*> -*> If FACT = 'N', then DF is an output argument and on exit -*> contains the n diagonal elements of the upper triangular -*> matrix U from the LU factorization of A. -*> \endverbatim -*> -*> \param[in,out] DUF -*> \verbatim -*> DUF is DOUBLE PRECISION array, dimension (N-1) -*> If FACT = 'F', then DUF is an input argument and on entry -*> contains the (n-1) elements of the first superdiagonal of U. -*> -*> If FACT = 'N', then DUF is an output argument and on exit -*> contains the (n-1) elements of the first superdiagonal of U. -*> \endverbatim -*> -*> \param[in,out] DU2 -*> \verbatim -*> DU2 is DOUBLE PRECISION array, dimension (N-2) -*> If FACT = 'F', then DU2 is an input argument and on entry -*> contains the (n-2) elements of the second superdiagonal of -*> U. -*> -*> If FACT = 'N', then DU2 is an output argument and on exit -*> contains the (n-2) elements of the second superdiagonal of -*> U. -*> \endverbatim -*> -*> \param[in,out] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (N) -*> If FACT = 'F', then IPIV is an input argument and on entry -*> contains the pivot indices from the LU factorization of A as -*> computed by DGTTRF. -*> -*> If FACT = 'N', then IPIV is an output argument and on exit -*> contains the pivot indices from the LU factorization of A; -*> row i of the matrix was interchanged with row IPIV(i). -*> IPIV(i) will always be either i or i+1; IPIV(i) = i indicates -*> a row interchange was not required. -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) -*> The N-by-NRHS right hand side matrix B. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,N). -*> \endverbatim -*> -*> \param[out] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) -*> If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. -*> \endverbatim -*> -*> \param[in] LDX -*> \verbatim -*> LDX is INTEGER -*> The leading dimension of the array X. LDX >= max(1,N). -*> \endverbatim -*> -*> \param[out] RCOND -*> \verbatim -*> RCOND is DOUBLE PRECISION -*> The estimate of the reciprocal condition number of the matrix -*> A. If RCOND is less than the machine precision (in -*> particular, if RCOND = 0), the matrix is singular to working -*> precision. This condition is indicated by a return code of -*> INFO > 0. -*> \endverbatim -*> -*> \param[out] FERR -*> \verbatim -*> FERR is DOUBLE PRECISION array, dimension (NRHS) -*> The estimated forward error bound for each solution vector -*> X(j) (the j-th column of the solution matrix X). -*> If XTRUE is the true solution corresponding to X(j), FERR(j) -*> is an estimated upper bound for the magnitude of the largest -*> element in (X(j) - XTRUE) divided by the magnitude of the -*> largest element in X(j). The estimate is as reliable as -*> the estimate for RCOND, and is almost always a slight -*> overestimate of the true error. -*> \endverbatim -*> -*> \param[out] BERR -*> \verbatim -*> BERR is DOUBLE PRECISION array, dimension (NRHS) -*> The componentwise relative backward error of each solution -*> vector X(j) (i.e., the smallest relative change in -*> any element of A or B that makes X(j) an exact solution). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (3*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 -*> > 0: if INFO = i, and i is -*> <= N: U(i,i) is exactly zero. The factorization -*> has not been completed unless i = N, but the -*> factor U is exactly singular, so the solution -*> and error bounds could not be computed. -*> RCOND = 0 is returned. -*> = N+1: U is nonsingular, but RCOND is less than machine -*> precision, meaning that the matrix is singular -*> to working precision. Nevertheless, the -*> solution and error bounds are computed because -*> there are a number of situations where the -*> computed solution can be more accurate than the -*> value of RCOND would suggest. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date April 2012 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, - $ DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, - $ WORK, IWORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 -* -* .. Scalar Arguments .. - CHARACTER FACT, TRANS - INTEGER INFO, LDB, LDX, N, NRHS - DOUBLE PRECISION RCOND -* .. -* .. Array Arguments .. - INTEGER IPIV( * ), IWORK( * ) - DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), - $ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ), - $ FERR( * ), WORK( * ), X( LDX, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOFACT, NOTRAN - CHARACTER NORM - DOUBLE PRECISION ANORM -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGT - EXTERNAL LSAME, DLAMCH, DLANGT -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGTCON, DGTRFS, DGTTRF, DGTTRS, DLACPY, - $ XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* - INFO = 0 - NOFACT = LSAME( FACT, 'N' ) - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -4 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -16 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGTSVX', -INFO ) - RETURN - END IF -* - IF( NOFACT ) THEN -* -* Compute the LU factorization of A. -* - CALL DCOPY( N, D, 1, DF, 1 ) - IF( N.GT.1 ) THEN - CALL DCOPY( N-1, DL, 1, DLF, 1 ) - CALL DCOPY( N-1, DU, 1, DUF, 1 ) - END IF - CALL DGTTRF( N, DLF, DF, DUF, DU2, IPIV, INFO ) -* -* Return if INFO is non-zero. -* - IF( INFO.GT.0 )THEN - RCOND = ZERO - RETURN - END IF - END IF -* -* Compute the norm of the matrix A. -* - IF( NOTRAN ) THEN - NORM = '1' - ELSE - NORM = 'I' - END IF - ANORM = DLANGT( NORM, N, DL, D, DU ) -* -* Compute the reciprocal of the condition number of A. -* - CALL DGTCON( NORM, N, DLF, DF, DUF, DU2, IPIV, ANORM, RCOND, WORK, - $ IWORK, INFO ) -* -* Compute the solution vectors X. -* - CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) - CALL DGTTRS( TRANS, N, NRHS, DLF, DF, DUF, DU2, IPIV, X, LDX, - $ INFO ) -* -* Use iterative refinement to improve the computed solutions and -* compute error bounds and backward error estimates for them. -* - CALL DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, - $ B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) -* -* Set INFO = N+1 if the matrix is singular to working precision. -* - IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) - $ INFO = N + 1 -* - RETURN -* -* End of DGTSVX -* - END diff --git a/mtx/lapack_src/dgttrf.f b/mtx/lapack_src/dgttrf.f deleted file mode 100644 index 154fb31a4..000000000 --- a/mtx/lapack_src/dgttrf.f +++ /dev/null @@ -1,237 +0,0 @@ -*> \brief \b DGTTRF -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGTTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, N -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGTTRF computes an LU factorization of a real tridiagonal matrix A -*> using elimination with partial pivoting and row interchanges. -*> -*> The factorization has the form -*> A = L * U -*> where L is a product of permutation and unit lower bidiagonal -*> matrices and U is upper triangular with nonzeros in only the main -*> diagonal and first two superdiagonals. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. -*> \endverbatim -*> -*> \param[in,out] DL -*> \verbatim -*> DL is DOUBLE PRECISION array, dimension (N-1) -*> On entry, DL must contain the (n-1) sub-diagonal elements of -*> A. -*> -*> On exit, DL is overwritten by the (n-1) multipliers that -*> define the matrix L from the LU factorization of A. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, D must contain the diagonal elements of A. -*> -*> On exit, D is overwritten by the n diagonal elements of the -*> upper triangular matrix U from the LU factorization of A. -*> \endverbatim -*> -*> \param[in,out] DU -*> \verbatim -*> DU is DOUBLE PRECISION array, dimension (N-1) -*> On entry, DU must contain the (n-1) super-diagonal elements -*> of A. -*> -*> On exit, DU is overwritten by the (n-1) elements of the first -*> super-diagonal of U. -*> \endverbatim -*> -*> \param[out] DU2 -*> \verbatim -*> DU2 is DOUBLE PRECISION array, dimension (N-2) -*> On exit, DU2 is overwritten by the (n-2) elements of the -*> second super-diagonal of U. -*> \endverbatim -*> -*> \param[out] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (N) -*> The pivot indices; for 1 <= i <= n, row i of the matrix was -*> interchanged with row IPIV(i). IPIV(i) will always be either -*> i or i+1; IPIV(i) = i indicates a row interchange was not -*> required. -*> \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. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INFO, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I - DOUBLE PRECISION FACT, TEMP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - CALL XERBLA( 'DGTTRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Initialize IPIV(i) = i and DU2(I) = 0 -* - DO 10 I = 1, N - IPIV( I ) = I - 10 CONTINUE - DO 20 I = 1, N - 2 - DU2( I ) = ZERO - 20 CONTINUE -* - DO 30 I = 1, N - 2 - IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN -* -* No row interchange required, eliminate DL(I) -* - IF( D( I ).NE.ZERO ) THEN - FACT = DL( I ) / D( I ) - DL( I ) = FACT - D( I+1 ) = D( I+1 ) - FACT*DU( I ) - END IF - ELSE -* -* Interchange rows I and I+1, eliminate DL(I) -* - FACT = D( I ) / DL( I ) - D( I ) = DL( I ) - DL( I ) = FACT - TEMP = DU( I ) - DU( I ) = D( I+1 ) - D( I+1 ) = TEMP - FACT*D( I+1 ) - DU2( I ) = DU( I+1 ) - DU( I+1 ) = -FACT*DU( I+1 ) - IPIV( I ) = I + 1 - END IF - 30 CONTINUE - IF( N.GT.1 ) THEN - I = N - 1 - IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN - IF( D( I ).NE.ZERO ) THEN - FACT = DL( I ) / D( I ) - DL( I ) = FACT - D( I+1 ) = D( I+1 ) - FACT*DU( I ) - END IF - ELSE - FACT = D( I ) / DL( I ) - D( I ) = DL( I ) - DL( I ) = FACT - TEMP = DU( I ) - DU( I ) = D( I+1 ) - D( I+1 ) = TEMP - FACT*D( I+1 ) - IPIV( I ) = I + 1 - END IF - END IF -* -* Check for a zero on the diagonal of U. -* - DO 40 I = 1, N - IF( D( I ).EQ.ZERO ) THEN - INFO = I - GO TO 50 - END IF - 40 CONTINUE - 50 CONTINUE -* - RETURN -* -* End of DGTTRF -* - END diff --git a/mtx/lapack_src/dgttrs.f b/mtx/lapack_src/dgttrs.f deleted file mode 100644 index 6507c4963..000000000 --- a/mtx/lapack_src/dgttrs.f +++ /dev/null @@ -1,223 +0,0 @@ -*> \brief \b DGTTRS -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGTTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, -* INFO ) -* -* .. Scalar Arguments .. -* CHARACTER TRANS -* INTEGER INFO, LDB, N, NRHS -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGTTRS solves one of the systems of equations -*> A*X = B or A**T*X = B, -*> with a tridiagonal matrix A using the LU factorization computed -*> by DGTTRF. -*> \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. -*> \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] DL -*> \verbatim -*> DL is DOUBLE PRECISION array, dimension (N-1) -*> The (n-1) multipliers that define the matrix L from the -*> LU factorization of A. -*> \endverbatim -*> -*> \param[in] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> The n diagonal elements of the upper triangular matrix U from -*> the LU factorization of A. -*> \endverbatim -*> -*> \param[in] DU -*> \verbatim -*> DU is DOUBLE PRECISION array, dimension (N-1) -*> The (n-1) elements of the first super-diagonal of U. -*> \endverbatim -*> -*> \param[in] DU2 -*> \verbatim -*> DU2 is DOUBLE PRECISION array, dimension (N-2) -*> The (n-2) elements of the second super-diagonal of U. -*> \endverbatim -*> -*> \param[in] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (N) -*> The pivot indices; for 1 <= i <= n, row i of the matrix was -*> interchanged with row IPIV(i). IPIV(i) will always be either -*> i or i+1; IPIV(i) = i indicates a row interchange was not -*> required. -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) -*> On entry, the matrix of right hand side vectors B. -*> On exit, B is overwritten by the solution vectors 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. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, - $ INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL NOTRAN - INTEGER ITRANS, J, JB, NB -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DGTTS2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* - INFO = 0 - NOTRAN = ( TRANS.EQ.'N' .OR. TRANS.EQ.'n' ) - IF( .NOT.NOTRAN .AND. .NOT.( TRANS.EQ.'T' .OR. TRANS.EQ. - $ 't' ) .AND. .NOT.( TRANS.EQ.'C' .OR. TRANS.EQ.'c' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGTTRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* -* Decode TRANS -* - IF( NOTRAN ) THEN - ITRANS = 0 - ELSE - ITRANS = 1 - END IF -* -* Determine the number of right-hand sides to solve at a time. -* - IF( NRHS.EQ.1 ) THEN - NB = 1 - ELSE - NB = MAX( 1, ILAENV( 1, 'DGTTRS', TRANS, N, NRHS, -1, -1 ) ) - END IF -* - IF( NB.GE.NRHS ) THEN - CALL DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) - ELSE - DO 10 J = 1, NRHS, NB - JB = MIN( NRHS-J+1, NB ) - CALL DGTTS2( ITRANS, N, JB, DL, D, DU, DU2, IPIV, B( 1, J ), - $ LDB ) - 10 CONTINUE - END IF -* -* End of DGTTRS -* - END diff --git a/mtx/lapack_src/dgtts2.f b/mtx/lapack_src/dgtts2.f deleted file mode 100644 index a582b7331..000000000 --- a/mtx/lapack_src/dgtts2.f +++ /dev/null @@ -1,274 +0,0 @@ -*> \brief \b DGTTS2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGTTS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) -* -* .. Scalar Arguments .. -* INTEGER ITRANS, LDB, N, NRHS -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGTTS2 solves one of the systems of equations -*> A*X = B or A**T*X = B, -*> with a tridiagonal matrix A using the LU factorization computed -*> by DGTTRF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ITRANS -*> \verbatim -*> ITRANS is INTEGER -*> Specifies the form of the system of equations. -*> = 0: A * X = B (No transpose) -*> = 1: A**T* X = B (Transpose) -*> = 2: A**T* X = B (Conjugate transpose = Transpose) -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. -*> \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] DL -*> \verbatim -*> DL is DOUBLE PRECISION array, dimension (N-1) -*> The (n-1) multipliers that define the matrix L from the -*> LU factorization of A. -*> \endverbatim -*> -*> \param[in] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> The n diagonal elements of the upper triangular matrix U from -*> the LU factorization of A. -*> \endverbatim -*> -*> \param[in] DU -*> \verbatim -*> DU is DOUBLE PRECISION array, dimension (N-1) -*> The (n-1) elements of the first super-diagonal of U. -*> \endverbatim -*> -*> \param[in] DU2 -*> \verbatim -*> DU2 is DOUBLE PRECISION array, dimension (N-2) -*> The (n-2) elements of the second super-diagonal of U. -*> \endverbatim -*> -*> \param[in] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (N) -*> The pivot indices; for 1 <= i <= n, row i of the matrix was -*> interchanged with row IPIV(i). IPIV(i) will always be either -*> i or i+1; IPIV(i) = i indicates a row interchange was not -*> required. -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) -*> On entry, the matrix of right hand side vectors B. -*> On exit, B is overwritten by the solution vectors X. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,N). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER ITRANS, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IP, J - DOUBLE PRECISION TEMP -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( ITRANS.EQ.0 ) THEN -* -* Solve A*X = B using the LU factorization of A, -* overwriting each right hand side vector with its solution. -* - IF( NRHS.LE.1 ) THEN - J = 1 - 10 CONTINUE -* -* Solve L*x = b. -* - DO 20 I = 1, N - 1 - IP = IPIV( I ) - TEMP = B( I+1-IP+I, J ) - DL( I )*B( IP, J ) - B( I, J ) = B( IP, J ) - B( I+1, J ) = TEMP - 20 CONTINUE -* -* Solve U*x = b. -* - B( N, J ) = B( N, J ) / D( N ) - IF( N.GT.1 ) - $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / - $ D( N-1 ) - DO 30 I = N - 2, 1, -1 - B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* - $ B( I+2, J ) ) / D( I ) - 30 CONTINUE - IF( J.LT.NRHS ) THEN - J = J + 1 - GO TO 10 - END IF - ELSE - DO 60 J = 1, NRHS -* -* Solve L*x = b. -* - DO 40 I = 1, N - 1 - IF( IPIV( I ).EQ.I ) THEN - B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J ) - ELSE - TEMP = B( I, J ) - B( I, J ) = B( I+1, J ) - B( I+1, J ) = TEMP - DL( I )*B( I, J ) - END IF - 40 CONTINUE -* -* Solve U*x = b. -* - B( N, J ) = B( N, J ) / D( N ) - IF( N.GT.1 ) - $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / - $ D( N-1 ) - DO 50 I = N - 2, 1, -1 - B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* - $ B( I+2, J ) ) / D( I ) - 50 CONTINUE - 60 CONTINUE - END IF - ELSE -* -* Solve A**T * X = B. -* - IF( NRHS.LE.1 ) THEN -* -* Solve U**T*x = b. -* - J = 1 - 70 CONTINUE - B( 1, J ) = B( 1, J ) / D( 1 ) - IF( N.GT.1 ) - $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) - DO 80 I = 3, N - B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )* - $ B( I-2, J ) ) / D( I ) - 80 CONTINUE -* -* Solve L**T*x = b. -* - DO 90 I = N - 1, 1, -1 - IP = IPIV( I ) - TEMP = B( I, J ) - DL( I )*B( I+1, J ) - B( I, J ) = B( IP, J ) - B( IP, J ) = TEMP - 90 CONTINUE - IF( J.LT.NRHS ) THEN - J = J + 1 - GO TO 70 - END IF -* - ELSE - DO 120 J = 1, NRHS -* -* Solve U**T*x = b. -* - B( 1, J ) = B( 1, J ) / D( 1 ) - IF( N.GT.1 ) - $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) - DO 100 I = 3, N - B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )- - $ DU2( I-2 )*B( I-2, J ) ) / D( I ) - 100 CONTINUE - DO 110 I = N - 1, 1, -1 - IF( IPIV( I ).EQ.I ) THEN - B( I, J ) = B( I, J ) - DL( I )*B( I+1, J ) - ELSE - TEMP = B( I+1, J ) - B( I+1, J ) = B( I, J ) - DL( I )*TEMP - B( I, J ) = TEMP - END IF - 110 CONTINUE - 120 CONTINUE - END IF - END IF -* -* End of DGTTS2 -* - END diff --git a/mtx/lapack_src/dhseqr.f b/mtx/lapack_src/dhseqr.f deleted file mode 100644 index 3ee16cad3..000000000 --- a/mtx/lapack_src/dhseqr.f +++ /dev/null @@ -1,516 +0,0 @@ -*> \brief \b DHSEQR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DHSEQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, -* LDZ, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N -* CHARACTER COMPZ, JOB -* .. -* .. Array Arguments .. -* DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), -* $ Z( LDZ, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DHSEQR computes the eigenvalues of a Hessenberg matrix H -*> and, optionally, the matrices T and Z from the Schur decomposition -*> H = Z T Z**T, where T is an upper quasi-triangular matrix (the -*> Schur form), and Z is the orthogonal matrix of Schur vectors. -*> -*> Optionally Z may be postmultiplied into an input orthogonal -*> matrix Q so that this routine can give the Schur factorization -*> of a matrix A which has been reduced to the Hessenberg form H -*> by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] JOB -*> \verbatim -*> JOB is CHARACTER*1 -*> = 'E': compute eigenvalues only; -*> = 'S': compute eigenvalues and the Schur form T. -*> \endverbatim -*> -*> \param[in] COMPZ -*> \verbatim -*> COMPZ is CHARACTER*1 -*> = 'N': no Schur vectors are computed; -*> = 'I': Z is initialized to the unit matrix and the matrix Z -*> of Schur vectors of H is returned; -*> = 'V': Z must contain an orthogonal matrix Q on entry, and -*> the product Q*Z is returned. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix H. N .GE. 0. -*> \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. ILO and IHI are normally -*> set by a previous call to DGEBAL, and then passed to ZGEHRD -*> when the matrix output by DGEBAL is reduced to Hessenberg -*> form. Otherwise ILO and IHI should be set to 1 and N -*> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. -*> If N = 0, then ILO = 1 and IHI = 0. -*> \endverbatim -*> -*> \param[in,out] H -*> \verbatim -*> H is DOUBLE PRECISION array, dimension (LDH,N) -*> On entry, the upper Hessenberg matrix H. -*> On exit, if INFO = 0 and JOB = 'S', then H contains the -*> upper quasi-triangular matrix T from the Schur decomposition -*> (the Schur form); 2-by-2 diagonal blocks (corresponding to -*> complex conjugate pairs of eigenvalues) are returned in -*> standard form, with H(i,i) = H(i+1,i+1) and -*> H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the -*> contents of H are unspecified on exit. (The output value of -*> H when INFO.GT.0 is given under the description of INFO -*> below.) -*> -*> Unlike earlier versions of DHSEQR, this subroutine may -*> explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 -*> or j = IHI+1, IHI+2, ... N. -*> \endverbatim -*> -*> \param[in] LDH -*> \verbatim -*> LDH is INTEGER -*> The leading dimension of the array H. LDH .GE. max(1,N). -*> \endverbatim -*> -*> \param[out] WR -*> \verbatim -*> WR is DOUBLE PRECISION array, dimension (N) -*> \endverbatim -*> -*> \param[out] WI -*> \verbatim -*> WI is DOUBLE PRECISION array, dimension (N) -*> -*> The real and imaginary parts, respectively, of the computed -*> eigenvalues. If two eigenvalues are computed as a complex -*> conjugate pair, they are stored in consecutive elements of -*> WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and -*> WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in -*> the same order as on the diagonal of the Schur form returned -*> in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 -*> diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and -*> WI(i+1) = -WI(i). -*> \endverbatim -*> -*> \param[in,out] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (LDZ,N) -*> If COMPZ = 'N', Z is not referenced. -*> If COMPZ = 'I', on entry Z need not be set and on exit, -*> if INFO = 0, Z contains the orthogonal matrix Z of the Schur -*> vectors of H. If COMPZ = 'V', on entry Z must contain an -*> N-by-N matrix Q, which is assumed to be equal to the unit -*> matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, -*> if INFO = 0, Z contains Q*Z. -*> Normally Q is the orthogonal matrix generated by DORGHR -*> after the call to DGEHRD which formed the Hessenberg matrix -*> H. (The output value of Z when INFO.GT.0 is given under -*> the description of INFO below.) -*> \endverbatim -*> -*> \param[in] LDZ -*> \verbatim -*> LDZ is INTEGER -*> The leading dimension of the array Z. if COMPZ = 'I' or -*> COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (LWORK) -*> On exit, if INFO = 0, WORK(1) returns an estimate of -*> the optimal value for LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. LWORK .GE. max(1,N) -*> is sufficient and delivers very good and sometimes -*> optimal performance. However, LWORK as large as 11*N -*> may be required for optimal performance. A workspace -*> query is recommended to determine the optimal workspace -*> size. -*> -*> If LWORK = -1, then DHSEQR does a workspace query. -*> In this case, DHSEQR checks the input parameters and -*> estimates the optimal workspace size for the given -*> values of N, ILO and IHI. The estimate is returned -*> in WORK(1). No error message related to LWORK is -*> issued by XERBLA. Neither H nor Z are accessed. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> .LT. 0: if INFO = -i, the i-th argument had an illegal -*> value -*> .GT. 0: if INFO = i, DHSEQR failed to compute all of -*> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR -*> and WI contain those eigenvalues which have been -*> successfully computed. (Failures are rare.) -*> -*> If INFO .GT. 0 and JOB = 'E', then on exit, the -*> remaining unconverged eigenvalues are the eigen- -*> values of the upper Hessenberg matrix rows and -*> columns ILO through INFO of the final, output -*> value of H. -*> -*> If INFO .GT. 0 and JOB = 'S', then on exit -*> -*> (*) (initial value of H)*U = U*(final value of H) -*> -*> where U is an orthogonal matrix. The final -*> value of H is upper Hessenberg and quasi-triangular -*> in rows and columns INFO+1 through IHI. -*> -*> If INFO .GT. 0 and COMPZ = 'V', then on exit -*> -*> (final value of Z) = (initial value of Z)*U -*> -*> where U is the orthogonal matrix in (*) (regard- -*> less of the value of JOB.) -*> -*> If INFO .GT. 0 and COMPZ = 'I', then on exit -*> (final value of Z) = U -*> where U is the orthogonal matrix in (*) (regard- -*> less of the value of JOB.) -*> -*> If INFO .GT. 0 and COMPZ = 'N', then Z is not -*> accessed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Karen Braman and Ralph Byers, Department of Mathematics, -*> University of Kansas, USA -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Default values supplied by -*> ILAENV(ISPEC,'DHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). -*> It is suggested that these defaults be adjusted in order -*> to attain best performance in each particular -*> computational environment. -*> -*> ISPEC=12: The DLAHQR vs DLAQR0 crossover point. -*> Default: 75. (Must be at least 11.) -*> -*> ISPEC=13: Recommended deflation window size. -*> This depends on ILO, IHI and NS. NS is the -*> number of simultaneous shifts returned -*> by ILAENV(ISPEC=15). (See ISPEC=15 below.) -*> The default for (IHI-ILO+1).LE.500 is NS. -*> The default for (IHI-ILO+1).GT.500 is 3*NS/2. -*> -*> ISPEC=14: Nibble crossover point. (See IPARMQ for -*> details.) Default: 14% of deflation window -*> size. -*> -*> ISPEC=15: Number of simultaneous shifts in a multishift -*> QR iteration. -*> -*> If IHI-ILO+1 is ... -*> -*> greater than ...but less ... the -*> or equal to ... than default is -*> -*> 1 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 some or all matrices of this order -*> are passed to the implicit double shift routine -*> DLAHQR and this parameter is ignored. See -*> ISPEC=12 above and comments in IPARMQ for -*> details. -*> -*> (**) The asterisks (**) indicate an ad-hoc -*> function of N increasing from 10 to 64. -*> -*> ISPEC=16: Select structured matrix multiply. -*> If the number of simultaneous shifts (specified -*> by ISPEC=15) is less than 14, then the default -*> for ISPEC=16 is 0. Otherwise the default for -*> ISPEC=16 is 2. -*> \endverbatim -* -*> \par References: -* ================ -*> -*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR -*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 -*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages -*> 929--947, 2002. -*> \n -*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR -*> Algorithm Part II: Aggressive Early Deflation, SIAM Journal -*> of Matrix Analysis, volume 23, pages 948--973, 2002. -* -* ===================================================================== - SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, - $ LDZ, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N - CHARACTER COMPZ, JOB -* .. -* .. Array Arguments .. - DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), - $ Z( LDZ, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. -* -* ==== Matrices of order NTINY or smaller must be processed by -* . DLAHQR because of insufficient subdiagonal scratch space. -* . (This is a hard limit.) ==== - INTEGER NTINY - PARAMETER ( NTINY = 11 ) -* -* ==== NL allocates some local workspace to help small matrices -* . through a rare DLAHQR failure. NL .GT. NTINY = 11 is -* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- -* . mended. (The default value of NMIN is 75.) Using NL = 49 -* . allows up to six simultaneous shifts and a 16-by-16 -* . deflation window. ==== - INTEGER NL - PARAMETER ( NL = 49 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) -* .. -* .. Local Arrays .. - DOUBLE PRECISION HL( NL, NL ), WORKL( NL ) -* .. -* .. Local Scalars .. - INTEGER I, KBOT, NMIN - LOGICAL INITZ, LQUERY, WANTT, WANTZ -* .. -* .. External Functions .. - INTEGER ILAENV - LOGICAL LSAME - EXTERNAL ILAENV, LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLACPY, DLAHQR, DLAQR0, DLASET, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -* .. -* .. Executable Statements .. -* -* ==== Decode and check the input parameters. ==== -* - WANTT = LSAME( JOB, 'S' ) - INITZ = LSAME( COMPZ, 'I' ) - WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) - WORK( 1 ) = DBLE( MAX( 1, N ) ) - LQUERY = LWORK.EQ.-1 -* - INFO = 0 - IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN - INFO = -1 - ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN - INFO = -5 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN - INFO = -11 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF -* - IF( INFO.NE.0 ) THEN -* -* ==== Quick return in case of invalid argument. ==== -* - CALL XERBLA( 'DHSEQR', -INFO ) - RETURN -* - ELSE IF( N.EQ.0 ) THEN -* -* ==== Quick return in case N = 0; nothing to do. ==== -* - RETURN -* - ELSE IF( LQUERY ) THEN -* -* ==== Quick return in case of a workspace query ==== -* - CALL DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, - $ IHI, Z, LDZ, WORK, LWORK, INFO ) -* ==== Ensure reported workspace size is backward-compatible with -* . previous LAPACK versions. ==== - WORK( 1 ) = MAX( DBLE( MAX( 1, N ) ), WORK( 1 ) ) - RETURN -* - ELSE -* -* ==== copy eigenvalues isolated by DGEBAL ==== -* - DO 10 I = 1, ILO - 1 - WR( I ) = H( I, I ) - WI( I ) = ZERO - 10 CONTINUE - DO 20 I = IHI + 1, N - WR( I ) = H( I, I ) - WI( I ) = ZERO - 20 CONTINUE -* -* ==== Initialize Z, if requested ==== -* - IF( INITZ ) - $ CALL DLASET( 'A', N, N, ZERO, ONE, Z, LDZ ) -* -* ==== Quick return if possible ==== -* - IF( ILO.EQ.IHI ) THEN - WR( ILO ) = H( ILO, ILO ) - WI( ILO ) = ZERO - RETURN - END IF -* -* ==== DLAHQR/DLAQR0 crossover point ==== -* - NMIN = ILAENV( 12, 'DHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, - $ ILO, IHI, LWORK ) - NMIN = MAX( NTINY, NMIN ) -* -* ==== DLAQR0 for big matrices; DLAHQR for small ones ==== -* - IF( N.GT.NMIN ) THEN - CALL DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, - $ IHI, Z, LDZ, WORK, LWORK, INFO ) - ELSE -* -* ==== Small matrix ==== -* - CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, - $ IHI, Z, LDZ, INFO ) -* - IF( INFO.GT.0 ) THEN -* -* ==== A rare DLAHQR failure! DLAQR0 sometimes succeeds -* . when DLAHQR fails. ==== -* - KBOT = INFO -* - IF( N.GE.NL ) THEN -* -* ==== Larger matrices have enough subdiagonal scratch -* . space to call DLAQR0 directly. ==== -* - CALL DLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, WR, - $ WI, ILO, IHI, Z, LDZ, WORK, LWORK, INFO ) -* - ELSE -* -* ==== Tiny matrices don't have enough subdiagonal -* . scratch space to benefit from DLAQR0. Hence, -* . tiny matrices must be copied into a larger -* . array before calling DLAQR0. ==== -* - CALL DLACPY( 'A', N, N, H, LDH, HL, NL ) - HL( N+1, N ) = ZERO - CALL DLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ), - $ NL ) - CALL DLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, WR, - $ WI, ILO, IHI, Z, LDZ, WORKL, NL, INFO ) - IF( WANTT .OR. INFO.NE.0 ) - $ CALL DLACPY( 'A', N, N, HL, NL, H, LDH ) - END IF - END IF - END IF -* -* ==== Clear out the trash, if necessary. ==== -* - IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 ) - $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH ) -* -* ==== Ensure reported workspace size is backward-compatible with -* . previous LAPACK versions. ==== -* - WORK( 1 ) = MAX( DBLE( MAX( 1, N ) ), WORK( 1 ) ) - END IF -* -* ==== End of DHSEQR ==== -* - END diff --git a/mtx/lapack_src/disnan.f b/mtx/lapack_src/disnan.f deleted file mode 100644 index f6a02bf1f..000000000 --- a/mtx/lapack_src/disnan.f +++ /dev/null @@ -1,80 +0,0 @@ -*> \brief \b DISNAN -* -* =========== 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 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. -* -*> \date November 2011 -* -*> \ingroup auxOTHERauxiliary -* -* ===================================================================== - LOGICAL FUNCTION DISNAN( DIN ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - DOUBLE PRECISION DIN -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL DLAISNAN - EXTERNAL DLAISNAN -* .. -* .. Executable Statements .. - DISNAN = DLAISNAN(DIN,DIN) - RETURN - END diff --git a/mtx/lapack_src/dlabad.f b/mtx/lapack_src/dlabad.f deleted file mode 100644 index 9eda3c91d..000000000 --- a/mtx/lapack_src/dlabad.f +++ /dev/null @@ -1,105 +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. -* -*> \date November 2011 -* -*> \ingroup auxOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLABAD( SMALL, LARGE ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - DOUBLE PRECISION 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/mtx/lapack_src/dlabrd.f b/mtx/lapack_src/dlabrd.f deleted file mode 100644 index 4e56f1e37..000000000 --- a/mtx/lapack_src/dlabrd.f +++ /dev/null @@ -1,381 +0,0 @@ -*> \brief \b DLABRD -* -* =========== 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. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER 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/mtx/lapack_src/dlacn2.f b/mtx/lapack_src/dlacn2.f deleted file mode 100644 index 60959c6e1..000000000 --- a/mtx/lapack_src/dlacn2.f +++ /dev/null @@ -1,294 +0,0 @@ -*> \brief \b DLACN2 -* -* =========== 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. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER 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 -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DASUM - EXTERNAL IDAMAX, DASUM -* .. -* .. External Subroutines .. - EXTERNAL DCOPY -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, NINT, SIGN -* .. -* .. 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 - X( I ) = SIGN( ONE, X( I ) ) - 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( NINT( SIGN( ONE, X( I ) ) ).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 - X( I ) = SIGN( ONE, X( I ) ) - 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/mtx/lapack_src/dlacpy.f b/mtx/lapack_src/dlacpy.f deleted file mode 100644 index f9c7a7597..000000000 --- a/mtx/lapack_src/dlacpy.f +++ /dev/null @@ -1,156 +0,0 @@ -*> \brief \b DLACPY -* -* =========== 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. -* -*> \date November 2011 -* -*> \ingroup auxOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER 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/mtx/lapack_src/dladiv.f b/mtx/lapack_src/dladiv.f deleted file mode 100644 index 090a90654..000000000 --- a/mtx/lapack_src/dladiv.f +++ /dev/null @@ -1,128 +0,0 @@ -*> \brief \b DLADIV -* -* =========== 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 Robert L. Smith and can be found -*> in D. Knuth, The art of Computer Programming, Vol.2, p.195 -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] C -*> \verbatim -*> C is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] D -*> \verbatim -*> D is DOUBLE PRECISION -*> The scalars a, b, c, and d in the above expression. -*> \endverbatim -*> -*> \param[out] P -*> \verbatim -*> P is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[out] Q -*> \verbatim -*> Q is DOUBLE PRECISION -*> The scalars p and q in the above expression. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup auxOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLADIV( A, B, C, D, P, Q ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - DOUBLE PRECISION A, B, C, D, P, Q -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION E, F -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Executable Statements .. -* - IF( ABS( D ).LT.ABS( C ) ) THEN - E = D / C - F = C + D*E - P = ( A+B*E ) / F - Q = ( B-A*E ) / F - ELSE - E = C / D - F = D + C*E - P = ( B+A*E ) / F - Q = ( -A+B*E ) / F - END IF -* - RETURN -* -* End of DLADIV -* - END diff --git a/mtx/lapack_src/dlaexc.f b/mtx/lapack_src/dlaexc.f deleted file mode 100644 index b12e10597..000000000 --- a/mtx/lapack_src/dlaexc.f +++ /dev/null @@ -1,436 +0,0 @@ -*> \brief \b DLAEXC -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAEXC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, -* INFO ) -* -* .. Scalar Arguments .. -* LOGICAL WANTQ -* INTEGER INFO, J1, LDQ, LDT, N, N1, N2 -* .. -* .. Array Arguments .. -* DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in -*> an upper quasi-triangular matrix T by an orthogonal similarity -*> transformation. -*> -*> T must be in Schur canonical form, that is, block upper triangular -*> with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block -*> has its diagonal elemnts equal and its off-diagonal elements of -*> opposite sign. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] WANTQ -*> \verbatim -*> WANTQ is LOGICAL -*> = .TRUE. : accumulate the transformation in the matrix Q; -*> = .FALSE.: do not accumulate the transformation. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix T. N >= 0. -*> \endverbatim -*> -*> \param[in,out] T -*> \verbatim -*> T is DOUBLE PRECISION array, dimension (LDT,N) -*> On entry, the upper quasi-triangular matrix T, in Schur -*> canonical form. -*> On exit, the updated matrix T, again in Schur canonical form. -*> \endverbatim -*> -*> \param[in] LDT -*> \verbatim -*> LDT is INTEGER -*> The leading dimension of the array T. LDT >= max(1,N). -*> \endverbatim -*> -*> \param[in,out] Q -*> \verbatim -*> Q is DOUBLE PRECISION array, dimension (LDQ,N) -*> On entry, if WANTQ is .TRUE., the orthogonal matrix Q. -*> On exit, if WANTQ is .TRUE., the updated matrix Q. -*> If WANTQ is .FALSE., Q is not referenced. -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. -*> LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N. -*> \endverbatim -*> -*> \param[in] J1 -*> \verbatim -*> J1 is INTEGER -*> The index of the first row of the first block T11. -*> \endverbatim -*> -*> \param[in] N1 -*> \verbatim -*> N1 is INTEGER -*> The order of the first block T11. N1 = 0, 1 or 2. -*> \endverbatim -*> -*> \param[in] N2 -*> \verbatim -*> N2 is INTEGER -*> The order of the second block T22. N2 = 0, 1 or 2. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (N) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> = 1: the transformed matrix T would be too far from Schur -*> form; the blocks are not swapped and T and Q are -*> unchanged. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, - $ INFO ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - LOGICAL WANTQ - INTEGER INFO, J1, LDQ, LDT, N, N1, N2 -* .. -* .. Array Arguments .. - DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - DOUBLE PRECISION TEN - PARAMETER ( TEN = 1.0D+1 ) - INTEGER LDD, LDX - PARAMETER ( LDD = 4, LDX = 2 ) -* .. -* .. Local Scalars .. - INTEGER IERR, J2, J3, J4, K, ND - DOUBLE PRECISION CS, DNORM, EPS, SCALE, SMLNUM, SN, T11, T22, - $ T33, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2, - $ WR1, WR2, XNORM -* .. -* .. Local Arrays .. - DOUBLE PRECISION D( LDD, 4 ), U( 3 ), U1( 3 ), U2( 3 ), - $ X( LDX, 2 ) -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE -* .. -* .. External Subroutines .. - EXTERNAL DLACPY, DLANV2, DLARFG, DLARFX, DLARTG, DLASY2, - $ DROT -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. -* .. Executable Statements .. -* - INFO = 0 -* -* Quick return if possible -* - IF( N.EQ.0 .OR. N1.EQ.0 .OR. N2.EQ.0 ) - $ RETURN - IF( J1+N1.GT.N ) - $ RETURN -* - J2 = J1 + 1 - J3 = J1 + 2 - J4 = J1 + 3 -* - IF( N1.EQ.1 .AND. N2.EQ.1 ) THEN -* -* Swap two 1-by-1 blocks. -* - T11 = T( J1, J1 ) - T22 = T( J2, J2 ) -* -* Determine the transformation to perform the interchange. -* - CALL DLARTG( T( J1, J2 ), T22-T11, CS, SN, TEMP ) -* -* Apply transformation to the matrix T. -* - IF( J3.LE.N ) - $ CALL DROT( N-J1-1, T( J1, J3 ), LDT, T( J2, J3 ), LDT, CS, - $ SN ) - CALL DROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN ) -* - T( J1, J1 ) = T22 - T( J2, J2 ) = T11 -* - IF( WANTQ ) THEN -* -* Accumulate transformation in the matrix Q. -* - CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN ) - END IF -* - ELSE -* -* Swapping involves at least one 2-by-2 block. -* -* Copy the diagonal block of order N1+N2 to the local array D -* and compute its norm. -* - ND = N1 + N2 - CALL DLACPY( 'Full', ND, ND, T( J1, J1 ), LDT, D, LDD ) - DNORM = DLANGE( 'Max', ND, ND, D, LDD, WORK ) -* -* Compute machine-dependent threshold for test for accepting -* swap. -* - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) / EPS - THRESH = MAX( TEN*EPS*DNORM, SMLNUM ) -* -* Solve T11*X - X*T22 = scale*T12 for X. -* - CALL DLASY2( .FALSE., .FALSE., -1, N1, N2, D, LDD, - $ D( N1+1, N1+1 ), LDD, D( 1, N1+1 ), LDD, SCALE, X, - $ LDX, XNORM, IERR ) -* -* Swap the adjacent diagonal blocks. -* - K = N1 + N1 + N2 - 3 - GO TO ( 10, 20, 30 )K -* - 10 CONTINUE -* -* N1 = 1, N2 = 2: generate elementary reflector H so that: -* -* ( scale, X11, X12 ) H = ( 0, 0, * ) -* - U( 1 ) = SCALE - U( 2 ) = X( 1, 1 ) - U( 3 ) = X( 1, 2 ) - CALL DLARFG( 3, U( 3 ), U, 1, TAU ) - U( 3 ) = ONE - T11 = T( J1, J1 ) -* -* Perform swap provisionally on diagonal block in D. -* - CALL DLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK ) - CALL DLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK ) -* -* Test whether to reject swap. -* - IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 3, - $ 3 )-T11 ) ).GT.THRESH )GO TO 50 -* -* Accept swap: apply transformation to the entire matrix T. -* - CALL DLARFX( 'L', 3, N-J1+1, U, TAU, T( J1, J1 ), LDT, WORK ) - CALL DLARFX( 'R', J2, 3, U, TAU, T( 1, J1 ), LDT, WORK ) -* - T( J3, J1 ) = ZERO - T( J3, J2 ) = ZERO - T( J3, J3 ) = T11 -* - IF( WANTQ ) THEN -* -* Accumulate transformation in the matrix Q. -* - CALL DLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK ) - END IF - GO TO 40 -* - 20 CONTINUE -* -* N1 = 2, N2 = 1: generate elementary reflector H so that: -* -* H ( -X11 ) = ( * ) -* ( -X21 ) = ( 0 ) -* ( scale ) = ( 0 ) -* - U( 1 ) = -X( 1, 1 ) - U( 2 ) = -X( 2, 1 ) - U( 3 ) = SCALE - CALL DLARFG( 3, U( 1 ), U( 2 ), 1, TAU ) - U( 1 ) = ONE - T33 = T( J3, J3 ) -* -* Perform swap provisionally on diagonal block in D. -* - CALL DLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK ) - CALL DLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK ) -* -* Test whether to reject swap. -* - IF( MAX( ABS( D( 2, 1 ) ), ABS( D( 3, 1 ) ), ABS( D( 1, - $ 1 )-T33 ) ).GT.THRESH )GO TO 50 -* -* Accept swap: apply transformation to the entire matrix T. -* - CALL DLARFX( 'R', J3, 3, U, TAU, T( 1, J1 ), LDT, WORK ) - CALL DLARFX( 'L', 3, N-J1, U, TAU, T( J1, J2 ), LDT, WORK ) -* - T( J1, J1 ) = T33 - T( J2, J1 ) = ZERO - T( J3, J1 ) = ZERO -* - IF( WANTQ ) THEN -* -* Accumulate transformation in the matrix Q. -* - CALL DLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK ) - END IF - GO TO 40 -* - 30 CONTINUE -* -* N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so -* that: -* -* H(2) H(1) ( -X11 -X12 ) = ( * * ) -* ( -X21 -X22 ) ( 0 * ) -* ( scale 0 ) ( 0 0 ) -* ( 0 scale ) ( 0 0 ) -* - U1( 1 ) = -X( 1, 1 ) - U1( 2 ) = -X( 2, 1 ) - U1( 3 ) = SCALE - CALL DLARFG( 3, U1( 1 ), U1( 2 ), 1, TAU1 ) - U1( 1 ) = ONE -* - TEMP = -TAU1*( X( 1, 2 )+U1( 2 )*X( 2, 2 ) ) - U2( 1 ) = -TEMP*U1( 2 ) - X( 2, 2 ) - U2( 2 ) = -TEMP*U1( 3 ) - U2( 3 ) = SCALE - CALL DLARFG( 3, U2( 1 ), U2( 2 ), 1, TAU2 ) - U2( 1 ) = ONE -* -* Perform swap provisionally on diagonal block in D. -* - CALL DLARFX( 'L', 3, 4, U1, TAU1, D, LDD, WORK ) - CALL DLARFX( 'R', 4, 3, U1, TAU1, D, LDD, WORK ) - CALL DLARFX( 'L', 3, 4, U2, TAU2, D( 2, 1 ), LDD, WORK ) - CALL DLARFX( 'R', 4, 3, U2, TAU2, D( 1, 2 ), LDD, WORK ) -* -* Test whether to reject swap. -* - IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 4, 1 ) ), - $ ABS( D( 4, 2 ) ) ).GT.THRESH )GO TO 50 -* -* Accept swap: apply transformation to the entire matrix T. -* - CALL DLARFX( 'L', 3, N-J1+1, U1, TAU1, T( J1, J1 ), LDT, WORK ) - CALL DLARFX( 'R', J4, 3, U1, TAU1, T( 1, J1 ), LDT, WORK ) - CALL DLARFX( 'L', 3, N-J1+1, U2, TAU2, T( J2, J1 ), LDT, WORK ) - CALL DLARFX( 'R', J4, 3, U2, TAU2, T( 1, J2 ), LDT, WORK ) -* - T( J3, J1 ) = ZERO - T( J3, J2 ) = ZERO - T( J4, J1 ) = ZERO - T( J4, J2 ) = ZERO -* - IF( WANTQ ) THEN -* -* Accumulate transformation in the matrix Q. -* - CALL DLARFX( 'R', N, 3, U1, TAU1, Q( 1, J1 ), LDQ, WORK ) - CALL DLARFX( 'R', N, 3, U2, TAU2, Q( 1, J2 ), LDQ, WORK ) - END IF -* - 40 CONTINUE -* - IF( N2.EQ.2 ) THEN -* -* Standardize new 2-by-2 block T11 -* - CALL DLANV2( T( J1, J1 ), T( J1, J2 ), T( J2, J1 ), - $ T( J2, J2 ), WR1, WI1, WR2, WI2, CS, SN ) - CALL DROT( N-J1-1, T( J1, J1+2 ), LDT, T( J2, J1+2 ), LDT, - $ CS, SN ) - CALL DROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN ) - IF( WANTQ ) - $ CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN ) - END IF -* - IF( N1.EQ.2 ) THEN -* -* Standardize new 2-by-2 block T22 -* - J3 = J1 + N2 - J4 = J3 + 1 - CALL DLANV2( T( J3, J3 ), T( J3, J4 ), T( J4, J3 ), - $ T( J4, J4 ), WR1, WI1, WR2, WI2, CS, SN ) - IF( J3+2.LE.N ) - $ CALL DROT( N-J3-1, T( J3, J3+2 ), LDT, T( J4, J3+2 ), - $ LDT, CS, SN ) - CALL DROT( J3-1, T( 1, J3 ), 1, T( 1, J4 ), 1, CS, SN ) - IF( WANTQ ) - $ CALL DROT( N, Q( 1, J3 ), 1, Q( 1, J4 ), 1, CS, SN ) - END IF -* - END IF - RETURN -* -* Exit with INFO = 1 if swap was rejected. -* - 50 CONTINUE - INFO = 1 - RETURN -* -* End of DLAEXC -* - END diff --git a/mtx/lapack_src/dlagtm.f b/mtx/lapack_src/dlagtm.f deleted file mode 100644 index 937caf129..000000000 --- a/mtx/lapack_src/dlagtm.f +++ /dev/null @@ -1,278 +0,0 @@ -*> \brief \b DLAGTM -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAGTM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, -* B, LDB ) -* -* .. Scalar Arguments .. -* CHARACTER TRANS -* INTEGER LDB, LDX, N, NRHS -* DOUBLE PRECISION ALPHA, BETA -* .. -* .. Array Arguments .. -* DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), -* $ X( LDX, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAGTM performs a matrix-vector product of the form -*> -*> B := alpha * A * X + beta * B -*> -*> where A is a tridiagonal matrix of order N, B and X are N by NRHS -*> matrices, and alpha and beta are real scalars, each of which may be -*> 0., 1., or -1. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> Specifies the operation applied to A. -*> = 'N': No transpose, B := alpha * A * X + beta * B -*> = 'T': Transpose, B := alpha * A'* X + beta * B -*> = 'C': 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 matrices X and B. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION -*> The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise, -*> it is assumed to be 0. -*> \endverbatim -*> -*> \param[in] DL -*> \verbatim -*> DL is DOUBLE PRECISION array, dimension (N-1) -*> The (n-1) sub-diagonal elements of T. -*> \endverbatim -*> -*> \param[in] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> The diagonal elements of T. -*> \endverbatim -*> -*> \param[in] DU -*> \verbatim -*> DU is DOUBLE PRECISION array, dimension (N-1) -*> The (n-1) super-diagonal elements of T. -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) -*> The N by NRHS matrix X. -*> \endverbatim -*> -*> \param[in] LDX -*> \verbatim -*> LDX is INTEGER -*> The leading dimension of the array X. LDX >= max(N,1). -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is DOUBLE PRECISION -*> The scalar beta. BETA must be 0., 1., or -1.; otherwise, -*> it is assumed to be 1. -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) -*> On entry, the N by NRHS matrix B. -*> On exit, B is overwritten by the matrix expression -*> B := alpha * A * X + beta * B. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(N,1). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, - $ B, LDB ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER LDB, LDX, N, NRHS - DOUBLE PRECISION ALPHA, BETA -* .. -* .. Array Arguments .. - DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), - $ X( LDX, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* - IF( N.EQ.0 ) - $ RETURN -* -* Multiply B by BETA if BETA.NE.1. -* - IF( BETA.EQ.ZERO ) THEN - DO 20 J = 1, NRHS - DO 10 I = 1, N - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE IF( BETA.EQ.-ONE ) THEN - DO 40 J = 1, NRHS - DO 30 I = 1, N - B( I, J ) = -B( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF -* - IF( ALPHA.EQ.ONE ) THEN - IF( LSAME( TRANS, 'N' ) ) THEN -* -* Compute B := B + A*X -* - DO 60 J = 1, NRHS - IF( N.EQ.1 ) THEN - B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) - ELSE - B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) + - $ DU( 1 )*X( 2, J ) - B( N, J ) = B( N, J ) + DL( N-1 )*X( N-1, J ) + - $ D( N )*X( N, J ) - DO 50 I = 2, N - 1 - B( I, J ) = B( I, J ) + DL( I-1 )*X( I-1, J ) + - $ D( I )*X( I, J ) + DU( I )*X( I+1, J ) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE -* -* Compute B := B + A**T*X -* - DO 80 J = 1, NRHS - IF( N.EQ.1 ) THEN - B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) - ELSE - B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) + - $ DL( 1 )*X( 2, J ) - B( N, J ) = B( N, J ) + DU( N-1 )*X( N-1, J ) + - $ D( N )*X( N, J ) - DO 70 I = 2, N - 1 - B( I, J ) = B( I, J ) + DU( I-1 )*X( I-1, J ) + - $ D( I )*X( I, J ) + DL( I )*X( I+1, J ) - 70 CONTINUE - END IF - 80 CONTINUE - END IF - ELSE IF( ALPHA.EQ.-ONE ) THEN - IF( LSAME( TRANS, 'N' ) ) THEN -* -* Compute B := B - A*X -* - DO 100 J = 1, NRHS - IF( N.EQ.1 ) THEN - B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) - ELSE - B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) - - $ DU( 1 )*X( 2, J ) - B( N, J ) = B( N, J ) - DL( N-1 )*X( N-1, J ) - - $ D( N )*X( N, J ) - DO 90 I = 2, N - 1 - B( I, J ) = B( I, J ) - DL( I-1 )*X( I-1, J ) - - $ D( I )*X( I, J ) - DU( I )*X( I+1, J ) - 90 CONTINUE - END IF - 100 CONTINUE - ELSE -* -* Compute B := B - A**T*X -* - DO 120 J = 1, NRHS - IF( N.EQ.1 ) THEN - B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) - ELSE - B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) - - $ DL( 1 )*X( 2, J ) - B( N, J ) = B( N, J ) - DU( N-1 )*X( N-1, J ) - - $ D( N )*X( N, J ) - DO 110 I = 2, N - 1 - B( I, J ) = B( I, J ) - DU( I-1 )*X( I-1, J ) - - $ D( I )*X( I, J ) - DL( I )*X( I+1, J ) - 110 CONTINUE - END IF - 120 CONTINUE - END IF - END IF - RETURN -* -* End of DLAGTM -* - END diff --git a/mtx/lapack_src/dlahqr.f b/mtx/lapack_src/dlahqr.f deleted file mode 100644 index 8cbf03082..000000000 --- a/mtx/lapack_src/dlahqr.f +++ /dev/null @@ -1,611 +0,0 @@ -*> \brief \b DLAHQR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAHQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, -* ILOZ, IHIZ, Z, LDZ, INFO ) -* -* .. Scalar Arguments .. -* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N -* LOGICAL WANTT, WANTZ -* .. -* .. Array Arguments .. -* DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAHQR is an auxiliary routine called by DHSEQR to update the -*> eigenvalues and Schur decomposition already computed by DHSEQR, by -*> dealing with the Hessenberg submatrix in rows and columns ILO to -*> IHI. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] WANTT -*> \verbatim -*> WANTT is LOGICAL -*> = .TRUE. : the full Schur form T is required; -*> = .FALSE.: only eigenvalues are required. -*> \endverbatim -*> -*> \param[in] WANTZ -*> \verbatim -*> WANTZ is LOGICAL -*> = .TRUE. : the matrix of Schur vectors Z is required; -*> = .FALSE.: Schur vectors are not required. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix H. N >= 0. -*> \endverbatim -*> -*> \param[in] ILO -*> \verbatim -*> ILO is INTEGER -*> \endverbatim -*> -*> \param[in] IHI -*> \verbatim -*> IHI is INTEGER -*> It is assumed that H is already upper quasi-triangular in -*> rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless -*> ILO = 1). DLAHQR works primarily with the Hessenberg -*> submatrix in rows and columns ILO to IHI, but applies -*> transformations to all of H if WANTT is .TRUE.. -*> 1 <= ILO <= max(1,IHI); IHI <= N. -*> \endverbatim -*> -*> \param[in,out] H -*> \verbatim -*> H is DOUBLE PRECISION array, dimension (LDH,N) -*> On entry, the upper Hessenberg matrix H. -*> On exit, if INFO is zero and if WANTT is .TRUE., H is upper -*> quasi-triangular in rows and columns ILO:IHI, with any -*> 2-by-2 diagonal blocks in standard form. If INFO is zero -*> and WANTT is .FALSE., the contents of H are unspecified on -*> exit. The output state of H if INFO is nonzero is given -*> below under the description of INFO. -*> \endverbatim -*> -*> \param[in] LDH -*> \verbatim -*> LDH is INTEGER -*> The leading dimension of the array H. LDH >= max(1,N). -*> \endverbatim -*> -*> \param[out] WR -*> \verbatim -*> WR is DOUBLE PRECISION array, dimension (N) -*> \endverbatim -*> -*> \param[out] WI -*> \verbatim -*> WI is DOUBLE PRECISION array, dimension (N) -*> The real and imaginary parts, respectively, of the computed -*> eigenvalues ILO to IHI are stored in the corresponding -*> elements of WR and WI. If two eigenvalues are computed as a -*> complex conjugate pair, they are stored in consecutive -*> elements of WR and WI, say the i-th and (i+1)th, with -*> WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the -*> eigenvalues are stored in the same order as on the diagonal -*> of the Schur form returned in H, with WR(i) = H(i,i), and, if -*> H(i:i+1,i:i+1) is a 2-by-2 diagonal block, -*> WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). -*> \endverbatim -*> -*> \param[in] ILOZ -*> \verbatim -*> ILOZ is INTEGER -*> \endverbatim -*> -*> \param[in] IHIZ -*> \verbatim -*> IHIZ is INTEGER -*> Specify the rows of Z to which transformations must be -*> applied if WANTZ is .TRUE.. -*> 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. -*> \endverbatim -*> -*> \param[in,out] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (LDZ,N) -*> If WANTZ is .TRUE., on entry Z must contain the current -*> matrix Z of transformations accumulated by DHSEQR, and on -*> exit Z has been updated; transformations are applied only to -*> the submatrix Z(ILOZ:IHIZ,ILO:IHI). -*> If WANTZ is .FALSE., Z is not referenced. -*> \endverbatim -*> -*> \param[in] LDZ -*> \verbatim -*> LDZ is INTEGER -*> The leading dimension of the array Z. LDZ >= max(1,N). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> .GT. 0: If INFO = i, DLAHQR failed to compute all the -*> eigenvalues ILO to IHI in a total of 30 iterations -*> per eigenvalue; elements i+1:ihi of WR and WI -*> contain those eigenvalues which have been -*> successfully computed. -*> -*> If INFO .GT. 0 and WANTT is .FALSE., then on exit, -*> the remaining unconverged eigenvalues are the -*> eigenvalues of the upper Hessenberg matrix rows -*> and columns ILO thorugh INFO of the final, output -*> value of H. -*> -*> If INFO .GT. 0 and WANTT is .TRUE., then on exit -*> (*) (initial value of H)*U = U*(final value of H) -*> where U is an orthognal matrix. The final -*> value of H is upper Hessenberg and triangular in -*> rows and columns INFO+1 through IHI. -*> -*> If INFO .GT. 0 and WANTZ is .TRUE., then on exit -*> (final value of Z) = (initial value of Z)*U -*> where U is the orthogonal matrix in (*) -*> (regardless of the value of WANTT.) -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> 02-96 Based on modifications by -*> David Day, Sandia National Laboratory, USA -*> -*> 12-04 Further modifications by -*> Ralph Byers, University of Kansas, USA -*> This is a modified version of DLAHQR from LAPACK version 3.0. -*> It is (1) more robust against overflow and underflow and -*> (2) adopts the more conservative Ahues & Tisseur stopping -*> criterion (LAWN 122, 1997). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, - $ ILOZ, IHIZ, Z, LDZ, INFO ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N - LOGICAL WANTT, WANTZ -* .. -* .. Array Arguments .. - DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) -* .. -* -* ========================================================= -* -* .. Parameters .. - INTEGER ITMAX - PARAMETER ( ITMAX = 30 ) - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0, TWO = 2.0d0 ) - DOUBLE PRECISION DAT1, DAT2 - PARAMETER ( DAT1 = 3.0d0 / 4.0d0, DAT2 = -0.4375d0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION AA, AB, BA, BB, CS, DET, H11, H12, H21, H21S, - $ H22, RT1I, RT1R, RT2I, RT2R, RTDISC, S, SAFMAX, - $ SAFMIN, SMLNUM, SN, SUM, T1, T2, T3, TR, TST, - $ ULP, V2, V3 - INTEGER I, I1, I2, ITS, J, K, L, M, NH, NR, NZ -* .. -* .. Local Arrays .. - DOUBLE PRECISION V( 3 ) -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLABAD, DLANV2, DLARFG, DROT -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - INFO = 0 -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN - IF( ILO.EQ.IHI ) THEN - WR( ILO ) = H( ILO, ILO ) - WI( ILO ) = ZERO - RETURN - END IF -* -* ==== clear out the trash ==== - DO 10 J = ILO, IHI - 3 - H( J+2, J ) = ZERO - H( J+3, J ) = ZERO - 10 CONTINUE - IF( ILO.LE.IHI-2 ) - $ H( IHI, IHI-2 ) = ZERO -* - NH = IHI - ILO + 1 - NZ = IHIZ - ILOZ + 1 -* -* Set machine-dependent constants for the stopping criterion. -* - SAFMIN = DLAMCH( 'SAFE MINIMUM' ) - SAFMAX = ONE / SAFMIN - CALL DLABAD( SAFMIN, SAFMAX ) - ULP = DLAMCH( 'PRECISION' ) - SMLNUM = SAFMIN*( DBLE( NH ) / ULP ) -* -* I1 and I2 are the indices of the first row and last column of H -* to which transformations must be applied. If eigenvalues only are -* being computed, I1 and I2 are set inside the main loop. -* - IF( WANTT ) THEN - I1 = 1 - I2 = N - END IF -* -* The main loop begins here. I is the loop index and decreases from -* IHI to ILO in steps of 1 or 2. Each iteration of the loop works -* with the active submatrix in rows and columns L to I. -* Eigenvalues I+1 to IHI have already converged. Either L = ILO or -* H(L,L-1) is negligible so that the matrix splits. -* - I = IHI - 20 CONTINUE - L = ILO - IF( I.LT.ILO ) - $ GO TO 160 -* -* Perform QR iterations on rows and columns ILO to I until a -* submatrix of order 1 or 2 splits off at the bottom because a -* subdiagonal element has become negligible. -* - DO 140 ITS = 0, ITMAX -* -* Look for a single small subdiagonal element. -* - DO 30 K = I, L + 1, -1 - IF( ABS( H( K, K-1 ) ).LE.SMLNUM ) - $ GO TO 40 - TST = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) ) - IF( TST.EQ.ZERO ) THEN - IF( K-2.GE.ILO ) - $ TST = TST + ABS( H( K-1, K-2 ) ) - IF( K+1.LE.IHI ) - $ TST = TST + ABS( H( K+1, K ) ) - END IF -* ==== The following is a conservative small subdiagonal -* . deflation criterion due to Ahues & Tisseur (LAWN 122, -* . 1997). It has better mathematical foundation and -* . improves accuracy in some cases. ==== - IF( ABS( H( K, K-1 ) ).LE.ULP*TST ) THEN - AB = MAX( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) ) - BA = MIN( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) ) - AA = MAX( ABS( H( K, K ) ), - $ ABS( H( K-1, K-1 )-H( K, K ) ) ) - BB = MIN( ABS( H( K, K ) ), - $ ABS( H( K-1, K-1 )-H( K, K ) ) ) - S = AA + AB - IF( BA*( AB / S ).LE.MAX( SMLNUM, - $ ULP*( BB*( AA / S ) ) ) )GO TO 40 - END IF - 30 CONTINUE - 40 CONTINUE - L = K - IF( L.GT.ILO ) THEN -* -* H(L,L-1) is negligible -* - H( L, L-1 ) = ZERO - END IF -* -* Exit from loop if a submatrix of order 1 or 2 has split off. -* - IF( L.GE.I-1 ) - $ GO TO 150 -* -* Now the active submatrix is in rows and columns L to I. If -* eigenvalues only are being computed, only the active submatrix -* need be transformed. -* - IF( .NOT.WANTT ) THEN - I1 = L - I2 = I - END IF -* - IF( ITS.EQ.10 ) THEN -* -* Exceptional shift. -* - S = ABS( H( L+1, L ) ) + ABS( H( L+2, L+1 ) ) - H11 = DAT1*S + H( L, L ) - H12 = DAT2*S - H21 = S - H22 = H11 - ELSE IF( ITS.EQ.20 ) THEN -* -* Exceptional shift. -* - S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) - H11 = DAT1*S + H( I, I ) - H12 = DAT2*S - H21 = S - H22 = H11 - ELSE -* -* Prepare to use Francis' double shift -* (i.e. 2nd degree generalized Rayleigh quotient) -* - H11 = H( I-1, I-1 ) - H21 = H( I, I-1 ) - H12 = H( I-1, I ) - H22 = H( I, I ) - END IF - S = ABS( H11 ) + ABS( H12 ) + ABS( H21 ) + ABS( H22 ) - IF( S.EQ.ZERO ) THEN - RT1R = ZERO - RT1I = ZERO - RT2R = ZERO - RT2I = ZERO - ELSE - H11 = H11 / S - H21 = H21 / S - H12 = H12 / S - H22 = H22 / S - TR = ( H11+H22 ) / TWO - DET = ( H11-TR )*( H22-TR ) - H12*H21 - RTDISC = SQRT( ABS( DET ) ) - IF( DET.GE.ZERO ) THEN -* -* ==== complex conjugate shifts ==== -* - RT1R = TR*S - RT2R = RT1R - RT1I = RTDISC*S - RT2I = -RT1I - ELSE -* -* ==== real shifts (use only one of them) ==== -* - RT1R = TR + RTDISC - RT2R = TR - RTDISC - IF( ABS( RT1R-H22 ).LE.ABS( RT2R-H22 ) ) THEN - RT1R = RT1R*S - RT2R = RT1R - ELSE - RT2R = RT2R*S - RT1R = RT2R - END IF - RT1I = ZERO - RT2I = ZERO - END IF - END IF -* -* Look for two consecutive small subdiagonal elements. -* - DO 50 M = I - 2, L, -1 -* Determine the effect of starting the double-shift QR -* iteration at row M, and see if this would make H(M,M-1) -* negligible. (The following uses scaling to avoid -* overflows and most underflows.) -* - H21S = H( M+1, M ) - S = ABS( H( M, M )-RT2R ) + ABS( RT2I ) + ABS( H21S ) - H21S = H( M+1, M ) / S - V( 1 ) = H21S*H( M, M+1 ) + ( H( M, M )-RT1R )* - $ ( ( H( M, M )-RT2R ) / S ) - RT1I*( RT2I / S ) - V( 2 ) = H21S*( H( M, M )+H( M+1, M+1 )-RT1R-RT2R ) - V( 3 ) = H21S*H( M+2, M+1 ) - S = ABS( V( 1 ) ) + ABS( V( 2 ) ) + ABS( V( 3 ) ) - V( 1 ) = V( 1 ) / S - V( 2 ) = V( 2 ) / S - V( 3 ) = V( 3 ) / S - IF( M.EQ.L ) - $ GO TO 60 - IF( ABS( H( M, M-1 ) )*( ABS( V( 2 ) )+ABS( V( 3 ) ) ).LE. - $ ULP*ABS( V( 1 ) )*( ABS( H( M-1, M-1 ) )+ABS( H( M, - $ M ) )+ABS( H( M+1, M+1 ) ) ) )GO TO 60 - 50 CONTINUE - 60 CONTINUE -* -* Double-shift QR step -* - DO 130 K = M, I - 1 -* -* The first iteration of this loop determines a reflection G -* from the vector V and applies it from left and right to H, -* thus creating a nonzero bulge below the subdiagonal. -* -* Each subsequent iteration determines a reflection G to -* restore the Hessenberg form in the (K-1)th column, and thus -* chases the bulge one step toward the bottom of the active -* submatrix. NR is the order of G. -* - NR = MIN( 3, I-K+1 ) - IF( K.GT.M ) - $ CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 ) - CALL DLARFG( NR, V( 1 ), V( 2 ), 1, T1 ) - IF( K.GT.M ) THEN - H( K, K-1 ) = V( 1 ) - H( K+1, K-1 ) = ZERO - IF( K.LT.I-1 ) - $ H( K+2, K-1 ) = ZERO - ELSE IF( M.GT.L ) THEN -* ==== Use the following instead of -* . H( K, K-1 ) = -H( K, K-1 ) to -* . avoid a bug when v(2) and v(3) -* . underflow. ==== - H( K, K-1 ) = H( K, K-1 )*( ONE-T1 ) - END IF - V2 = V( 2 ) - T2 = T1*V2 - IF( NR.EQ.3 ) THEN - V3 = V( 3 ) - T3 = T1*V3 -* -* Apply G from the left to transform the rows of the matrix -* in columns K to I2. -* - DO 70 J = K, I2 - SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J ) - H( K, J ) = H( K, J ) - SUM*T1 - H( K+1, J ) = H( K+1, J ) - SUM*T2 - H( K+2, J ) = H( K+2, J ) - SUM*T3 - 70 CONTINUE -* -* Apply G from the right to transform the columns of the -* matrix in rows I1 to min(K+3,I). -* - DO 80 J = I1, MIN( K+3, I ) - SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 ) - H( J, K ) = H( J, K ) - SUM*T1 - H( J, K+1 ) = H( J, K+1 ) - SUM*T2 - H( J, K+2 ) = H( J, K+2 ) - SUM*T3 - 80 CONTINUE -* - IF( WANTZ ) THEN -* -* Accumulate transformations in the matrix Z -* - DO 90 J = ILOZ, IHIZ - SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 ) - Z( J, K ) = Z( J, K ) - SUM*T1 - Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 - Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3 - 90 CONTINUE - END IF - ELSE IF( NR.EQ.2 ) THEN -* -* Apply G from the left to transform the rows of the matrix -* in columns K to I2. -* - DO 100 J = K, I2 - SUM = H( K, J ) + V2*H( K+1, J ) - H( K, J ) = H( K, J ) - SUM*T1 - H( K+1, J ) = H( K+1, J ) - SUM*T2 - 100 CONTINUE -* -* Apply G from the right to transform the columns of the -* matrix in rows I1 to min(K+3,I). -* - DO 110 J = I1, I - SUM = H( J, K ) + V2*H( J, K+1 ) - H( J, K ) = H( J, K ) - SUM*T1 - H( J, K+1 ) = H( J, K+1 ) - SUM*T2 - 110 CONTINUE -* - IF( WANTZ ) THEN -* -* Accumulate transformations in the matrix Z -* - DO 120 J = ILOZ, IHIZ - SUM = Z( J, K ) + V2*Z( J, K+1 ) - Z( J, K ) = Z( J, K ) - SUM*T1 - Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 - 120 CONTINUE - END IF - END IF - 130 CONTINUE -* - 140 CONTINUE -* -* Failure to converge in remaining number of iterations -* - INFO = I - RETURN -* - 150 CONTINUE -* - IF( L.EQ.I ) THEN -* -* H(I,I-1) is negligible: one eigenvalue has converged. -* - WR( I ) = H( I, I ) - WI( I ) = ZERO - ELSE IF( L.EQ.I-1 ) THEN -* -* H(I-1,I-2) is negligible: a pair of eigenvalues have converged. -* -* Transform the 2-by-2 submatrix to standard Schur form, -* and compute and store the eigenvalues. -* - CALL DLANV2( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ), - $ H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ), - $ CS, SN ) -* - IF( WANTT ) THEN -* -* Apply the transformation to the rest of H. -* - IF( I2.GT.I ) - $ CALL DROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH, - $ CS, SN ) - CALL DROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN ) - END IF - IF( WANTZ ) THEN -* -* Apply the transformation to Z. -* - CALL DROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN ) - END IF - END IF -* -* return to start of the main loop with new value of I. -* - I = L - 1 - GO TO 20 -* - 160 CONTINUE - RETURN -* -* End of DLAHQR -* - END diff --git a/mtx/lapack_src/dlahr2.f b/mtx/lapack_src/dlahr2.f deleted file mode 100644 index 31ea1bb0e..000000000 --- a/mtx/lapack_src/dlahr2.f +++ /dev/null @@ -1,326 +0,0 @@ -*> \brief \b DLAHR2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAHR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) -* -* .. Scalar Arguments .. -* INTEGER K, LDA, LDT, LDY, N, NB -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), -* $ Y( LDY, NB ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1) -*> matrix A so that elements below the k-th subdiagonal are zero. The -*> reduction is performed by an orthogonal similarity transformation -*> Q**T * A * Q. The routine returns the matrices V and T which determine -*> Q as a block reflector I - V*T*V**T, and also the matrix Y = A * V * T. -*> -*> This is an auxiliary routine called by DGEHRD. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The offset for the reduction. Elements below the k-th -*> subdiagonal in the first NB columns are reduced to zero. -*> K < N. -*> \endverbatim -*> -*> \param[in] NB -*> \verbatim -*> NB is INTEGER -*> The number of columns to be reduced. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N-K+1) -*> On entry, the n-by-(n-k+1) general matrix A. -*> On exit, the elements on and above the k-th subdiagonal in -*> the first NB columns are overwritten with the corresponding -*> elements of the reduced matrix; the elements below the k-th -*> subdiagonal, with the array TAU, represent the matrix Q as a -*> product of elementary reflectors. The other columns of A are -*> unchanged. 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] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (NB) -*> The scalar factors of the elementary reflectors. See Further -*> Details. -*> \endverbatim -*> -*> \param[out] T -*> \verbatim -*> T is DOUBLE PRECISION array, dimension (LDT,NB) -*> The upper triangular matrix T. -*> \endverbatim -*> -*> \param[in] LDT -*> \verbatim -*> LDT is INTEGER -*> The leading dimension of the array T. LDT >= NB. -*> \endverbatim -*> -*> \param[out] Y -*> \verbatim -*> Y is DOUBLE PRECISION array, dimension (LDY,NB) -*> The n-by-nb matrix Y. -*> \endverbatim -*> -*> \param[in] LDY -*> \verbatim -*> LDY is INTEGER -*> The leading dimension of the array Y. LDY >= N. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The matrix Q is represented as a product of nb 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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in -*> A(i+k+1:n,i), and tau in TAU(i). -*> -*> The elements of the vectors v together form the (n-k+1)-by-nb matrix -*> V which is needed, with T and Y, to apply the transformation to the -*> unreduced part of the matrix, using an update of the form: -*> A := (I - V*T*V**T) * (A - Y*V**T). -*> -*> The contents of A on exit are illustrated by the following example -*> with n = 7, k = 3 and nb = 2: -*> -*> ( a a a a a ) -*> ( a a a a a ) -*> ( a a a a a ) -*> ( h h a a a ) -*> ( v1 h a a a ) -*> ( v1 v2 a a a ) -*> ( v1 v2 a a a ) -*> -*> where a denotes an element of the original matrix A, h denotes a -*> modified element of the upper Hessenberg matrix H, and vi denotes an -*> element of the vector defining H(i). -*> -*> This subroutine is a slight modification of LAPACK-3.0's DLAHRD -*> incorporating improvements proposed by Quintana-Orti and Van de -*> Gejin. Note that the entries of A(1:K,2:NB) differ from those -*> returned by the original LAPACK-3.0's DLAHRD routine. (This -*> subroutine is not backward compatible with LAPACK-3.0's DLAHRD.) -*> \endverbatim -* -*> \par References: -* ================ -*> -*> Gregorio Quintana-Orti and Robert van de Geijn, "Improving the -*> performance of reduction to Hessenberg form," ACM Transactions on -*> Mathematical Software, 32(2):180-194, June 2006. -*> -* ===================================================================== - SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER K, LDA, LDT, LDY, N, NB -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), - $ Y( LDY, NB ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, - $ ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I - DOUBLE PRECISION EI -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DLACPY, - $ DLARFG, DSCAL, DTRMM, DTRMV -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.LE.1 ) - $ RETURN -* - DO 10 I = 1, NB - IF( I.GT.1 ) THEN -* -* Update A(K+1:N,I) -* -* Update I-th column of A - Y * V**T -* - CALL DGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY, - $ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 ) -* -* Apply I - V * T**T * V**T to this column (call it b) from the -* left, using the last column of T as workspace -* -* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) -* ( V2 ) ( b2 ) -* -* where V1 is unit lower triangular -* -* w := V1**T * b1 -* - CALL DCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) - CALL DTRMV( 'Lower', 'Transpose', 'UNIT', - $ I-1, A( K+1, 1 ), - $ LDA, T( 1, NB ), 1 ) -* -* w := w + V2**T * b2 -* - CALL DGEMV( 'Transpose', N-K-I+1, I-1, - $ ONE, A( K+I, 1 ), - $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 ) -* -* w := T**T * w -* - CALL DTRMV( 'Upper', 'Transpose', 'NON-UNIT', - $ I-1, T, LDT, - $ T( 1, NB ), 1 ) -* -* b2 := b2 - V2*w -* - CALL DGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, - $ A( K+I, 1 ), - $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) -* -* b1 := b1 - V1*w -* - CALL DTRMV( 'Lower', 'NO TRANSPOSE', - $ 'UNIT', I-1, - $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) - CALL DAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) -* - A( K+I-1, I-1 ) = EI - END IF -* -* Generate the elementary reflector H(I) to annihilate -* A(K+I+1:N,I) -* - CALL DLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, - $ TAU( I ) ) - EI = A( K+I, I ) - A( K+I, I ) = ONE -* -* Compute Y(K+1:N,I) -* - CALL DGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, - $ ONE, A( K+1, I+1 ), - $ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 ) - CALL DGEMV( 'Transpose', N-K-I+1, I-1, - $ ONE, A( K+I, 1 ), LDA, - $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 ) - CALL DGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, - $ Y( K+1, 1 ), LDY, - $ T( 1, I ), 1, ONE, Y( K+1, I ), 1 ) - CALL DSCAL( N-K, TAU( I ), Y( K+1, I ), 1 ) -* -* Compute T(1:I,I) -* - CALL DSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) - CALL DTRMV( 'Upper', 'No Transpose', 'NON-UNIT', - $ I-1, T, LDT, - $ T( 1, I ), 1 ) - T( I, I ) = TAU( I ) -* - 10 CONTINUE - A( K+NB, NB ) = EI -* -* Compute Y(1:K,1:NB) -* - CALL DLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) - CALL DTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', - $ 'UNIT', K, NB, - $ ONE, A( K+1, 1 ), LDA, Y, LDY ) - IF( N.GT.K+NB ) - $ CALL DGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, - $ NB, N-K-NB, ONE, - $ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y, - $ LDY ) - CALL DTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', - $ 'NON-UNIT', K, NB, - $ ONE, T, LDT, Y, LDY ) -* - RETURN -* -* End of DLAHR2 -* - END diff --git a/mtx/lapack_src/dlaisnan.f b/mtx/lapack_src/dlaisnan.f deleted file mode 100644 index c3cd27803..000000000 --- a/mtx/lapack_src/dlaisnan.f +++ /dev/null @@ -1,91 +0,0 @@ -*> \brief \b DLAISNAN -* -* =========== 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 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. -* -*> \date November 2011 -* -*> \ingroup auxOTHERauxiliary -* -* ===================================================================== - LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - DOUBLE PRECISION DIN1, DIN2 -* .. -* -* ===================================================================== -* -* .. Executable Statements .. - DLAISNAN = (DIN1.NE.DIN2) - RETURN - END diff --git a/mtx/lapack_src/dlaln2.f b/mtx/lapack_src/dlaln2.f deleted file mode 100644 index f20624c87..000000000 --- a/mtx/lapack_src/dlaln2.f +++ /dev/null @@ -1,611 +0,0 @@ -*> \brief \b DLALN2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLALN2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, -* LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) -* -* .. Scalar Arguments .. -* LOGICAL LTRANS -* INTEGER INFO, LDA, LDB, LDX, NA, NW -* DOUBLE PRECISION CA, D1, D2, SCALE, SMIN, WI, WR, XNORM -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLALN2 solves a system of the form (ca A - w D ) X = s B -*> or (ca A**T - w D) X = s B with possible scaling ("s") and -*> perturbation of A. (A**T means A-transpose.) -*> -*> A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA -*> real diagonal matrix, w is a real or complex value, and X and B are -*> NA x 1 matrices -- real if w is real, complex if w is complex. NA -*> may be 1 or 2. -*> -*> If w is complex, X and B are represented as NA x 2 matrices, -*> the first column of each being the real part and the second -*> being the imaginary part. -*> -*> "s" is a scaling factor (.LE. 1), computed by DLALN2, which is -*> so chosen that X can be computed without overflow. X is further -*> scaled if necessary to assure that norm(ca A - w D)*norm(X) is less -*> than overflow. -*> -*> If both singular values of (ca A - w D) are less than SMIN, -*> SMIN*identity will be used instead of (ca A - w D). If only one -*> singular value is less than SMIN, one element of (ca A - w D) will be -*> perturbed enough to make the smallest singular value roughly SMIN. -*> If both singular values are at least SMIN, (ca A - w D) will not be -*> perturbed. In any case, the perturbation will be at most some small -*> multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values -*> are computed by infinity-norm approximations, and thus will only be -*> correct to a factor of 2 or so. -*> -*> Note: all input quantities are assumed to be smaller than overflow -*> by a reasonable factor. (See BIGNUM.) -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] LTRANS -*> \verbatim -*> LTRANS is LOGICAL -*> =.TRUE.: A-transpose will be used. -*> =.FALSE.: A will be used (not transposed.) -*> \endverbatim -*> -*> \param[in] NA -*> \verbatim -*> NA is INTEGER -*> The size of the matrix A. It may (only) be 1 or 2. -*> \endverbatim -*> -*> \param[in] NW -*> \verbatim -*> NW is INTEGER -*> 1 if "w" is real, 2 if "w" is complex. It may only be 1 -*> or 2. -*> \endverbatim -*> -*> \param[in] SMIN -*> \verbatim -*> SMIN is DOUBLE PRECISION -*> The desired lower bound on the singular values of A. This -*> should be a safe distance away from underflow or overflow, -*> say, between (underflow/machine precision) and (machine -*> precision * overflow ). (See BIGNUM and ULP.) -*> \endverbatim -*> -*> \param[in] CA -*> \verbatim -*> CA is DOUBLE PRECISION -*> The coefficient c, which A is multiplied by. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,NA) -*> The NA x NA matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of A. It must be at least NA. -*> \endverbatim -*> -*> \param[in] D1 -*> \verbatim -*> D1 is DOUBLE PRECISION -*> The 1,1 element in the diagonal matrix D. -*> \endverbatim -*> -*> \param[in] D2 -*> \verbatim -*> D2 is DOUBLE PRECISION -*> The 2,2 element in the diagonal matrix D. Not used if NW=1. -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NW) -*> The NA x NW matrix B (right-hand side). If NW=2 ("w" is -*> complex), column 1 contains the real part of B and column 2 -*> contains the imaginary part. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of B. It must be at least NA. -*> \endverbatim -*> -*> \param[in] WR -*> \verbatim -*> WR is DOUBLE PRECISION -*> The real part of the scalar "w". -*> \endverbatim -*> -*> \param[in] WI -*> \verbatim -*> WI is DOUBLE PRECISION -*> The imaginary part of the scalar "w". Not used if NW=1. -*> \endverbatim -*> -*> \param[out] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension (LDX,NW) -*> The NA x NW matrix X (unknowns), as computed by DLALN2. -*> If NW=2 ("w" is complex), on exit, column 1 will contain -*> the real part of X and column 2 will contain the imaginary -*> part. -*> \endverbatim -*> -*> \param[in] LDX -*> \verbatim -*> LDX is INTEGER -*> The leading dimension of X. It must be at least NA. -*> \endverbatim -*> -*> \param[out] SCALE -*> \verbatim -*> SCALE is DOUBLE PRECISION -*> The scale factor that B must be multiplied by to insure -*> that overflow does not occur when computing X. Thus, -*> (ca A - w D) X will be SCALE*B, not B (ignoring -*> perturbations of A.) It will be at most 1. -*> \endverbatim -*> -*> \param[out] XNORM -*> \verbatim -*> XNORM is DOUBLE PRECISION -*> The infinity-norm of X, when X is regarded as an NA x NW -*> real matrix. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> An error flag. It will be set to zero if no error occurs, -*> a negative number if an argument is in error, or a positive -*> number if ca A - w D had to be perturbed. -*> The possible values are: -*> = 0: No error occurred, and (ca A - w D) did not have to be -*> perturbed. -*> = 1: (ca A - w D) had to be perturbed to make its smallest -*> (or only) singular value greater than SMIN. -*> NOTE: In the interests of speed, this routine does not -*> check the inputs for errors. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, - $ LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - LOGICAL LTRANS - INTEGER INFO, LDA, LDB, LDX, NA, NW - DOUBLE PRECISION CA, D1, D2, SCALE, SMIN, WI, WR, XNORM -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) -* .. -* .. Local Scalars .. - INTEGER ICMAX, J - DOUBLE PRECISION BBND, BI1, BI2, BIGNUM, BNORM, BR1, BR2, CI21, - $ CI22, CMAX, CNORM, CR21, CR22, CSI, CSR, LI21, - $ LR21, SMINI, SMLNUM, TEMP, U22ABS, UI11, UI11R, - $ UI12, UI12S, UI22, UR11, UR11R, UR12, UR12S, - $ UR22, XI1, XI2, XR1, XR2 -* .. -* .. Local Arrays .. - LOGICAL RSWAP( 4 ), ZSWAP( 4 ) - INTEGER IPIVOT( 4, 4 ) - DOUBLE PRECISION CI( 2, 2 ), CIV( 4 ), CR( 2, 2 ), CRV( 4 ) -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DLADIV -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. -* .. Equivalences .. - EQUIVALENCE ( CI( 1, 1 ), CIV( 1 ) ), - $ ( CR( 1, 1 ), CRV( 1 ) ) -* .. -* .. Data statements .. - DATA ZSWAP / .FALSE., .FALSE., .TRUE., .TRUE. / - DATA RSWAP / .FALSE., .TRUE., .FALSE., .TRUE. / - DATA IPIVOT / 1, 2, 3, 4, 2, 1, 4, 3, 3, 4, 1, 2, 4, - $ 3, 2, 1 / -* .. -* .. Executable Statements .. -* -* Compute BIGNUM -* - SMLNUM = TWO*DLAMCH( 'Safe minimum' ) - BIGNUM = ONE / SMLNUM - SMINI = MAX( SMIN, SMLNUM ) -* -* Don't check for input errors -* - INFO = 0 -* -* Standard Initializations -* - SCALE = ONE -* - IF( NA.EQ.1 ) THEN -* -* 1 x 1 (i.e., scalar) system C X = B -* - IF( NW.EQ.1 ) THEN -* -* Real 1x1 system. -* -* C = ca A - w D -* - CSR = CA*A( 1, 1 ) - WR*D1 - CNORM = ABS( CSR ) -* -* If | C | < SMINI, use C = SMINI -* - IF( CNORM.LT.SMINI ) THEN - CSR = SMINI - CNORM = SMINI - INFO = 1 - END IF -* -* Check scaling for X = B / C -* - BNORM = ABS( B( 1, 1 ) ) - IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN - IF( BNORM.GT.BIGNUM*CNORM ) - $ SCALE = ONE / BNORM - END IF -* -* Compute X -* - X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / CSR - XNORM = ABS( X( 1, 1 ) ) - ELSE -* -* Complex 1x1 system (w is complex) -* -* C = ca A - w D -* - CSR = CA*A( 1, 1 ) - WR*D1 - CSI = -WI*D1 - CNORM = ABS( CSR ) + ABS( CSI ) -* -* If | C | < SMINI, use C = SMINI -* - IF( CNORM.LT.SMINI ) THEN - CSR = SMINI - CSI = ZERO - CNORM = SMINI - INFO = 1 - END IF -* -* Check scaling for X = B / C -* - BNORM = ABS( B( 1, 1 ) ) + ABS( B( 1, 2 ) ) - IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN - IF( BNORM.GT.BIGNUM*CNORM ) - $ SCALE = ONE / BNORM - END IF -* -* Compute X -* - CALL DLADIV( SCALE*B( 1, 1 ), SCALE*B( 1, 2 ), CSR, CSI, - $ X( 1, 1 ), X( 1, 2 ) ) - XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) ) - END IF -* - ELSE -* -* 2x2 System -* -* Compute the real part of C = ca A - w D (or ca A**T - w D ) -* - CR( 1, 1 ) = CA*A( 1, 1 ) - WR*D1 - CR( 2, 2 ) = CA*A( 2, 2 ) - WR*D2 - IF( LTRANS ) THEN - CR( 1, 2 ) = CA*A( 2, 1 ) - CR( 2, 1 ) = CA*A( 1, 2 ) - ELSE - CR( 2, 1 ) = CA*A( 2, 1 ) - CR( 1, 2 ) = CA*A( 1, 2 ) - END IF -* - IF( NW.EQ.1 ) THEN -* -* Real 2x2 system (w is real) -* -* Find the largest element in C -* - CMAX = ZERO - ICMAX = 0 -* - DO 10 J = 1, 4 - IF( ABS( CRV( J ) ).GT.CMAX ) THEN - CMAX = ABS( CRV( J ) ) - ICMAX = J - END IF - 10 CONTINUE -* -* If norm(C) < SMINI, use SMINI*identity. -* - IF( CMAX.LT.SMINI ) THEN - BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 2, 1 ) ) ) - IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN - IF( BNORM.GT.BIGNUM*SMINI ) - $ SCALE = ONE / BNORM - END IF - TEMP = SCALE / SMINI - X( 1, 1 ) = TEMP*B( 1, 1 ) - X( 2, 1 ) = TEMP*B( 2, 1 ) - XNORM = TEMP*BNORM - INFO = 1 - RETURN - END IF -* -* Gaussian elimination with complete pivoting. -* - UR11 = CRV( ICMAX ) - CR21 = CRV( IPIVOT( 2, ICMAX ) ) - UR12 = CRV( IPIVOT( 3, ICMAX ) ) - CR22 = CRV( IPIVOT( 4, ICMAX ) ) - UR11R = ONE / UR11 - LR21 = UR11R*CR21 - UR22 = CR22 - UR12*LR21 -* -* If smaller pivot < SMINI, use SMINI -* - IF( ABS( UR22 ).LT.SMINI ) THEN - UR22 = SMINI - INFO = 1 - END IF - IF( RSWAP( ICMAX ) ) THEN - BR1 = B( 2, 1 ) - BR2 = B( 1, 1 ) - ELSE - BR1 = B( 1, 1 ) - BR2 = B( 2, 1 ) - END IF - BR2 = BR2 - LR21*BR1 - BBND = MAX( ABS( BR1*( UR22*UR11R ) ), ABS( BR2 ) ) - IF( BBND.GT.ONE .AND. ABS( UR22 ).LT.ONE ) THEN - IF( BBND.GE.BIGNUM*ABS( UR22 ) ) - $ SCALE = ONE / BBND - END IF -* - XR2 = ( BR2*SCALE ) / UR22 - XR1 = ( SCALE*BR1 )*UR11R - XR2*( UR11R*UR12 ) - IF( ZSWAP( ICMAX ) ) THEN - X( 1, 1 ) = XR2 - X( 2, 1 ) = XR1 - ELSE - X( 1, 1 ) = XR1 - X( 2, 1 ) = XR2 - END IF - XNORM = MAX( ABS( XR1 ), ABS( XR2 ) ) -* -* Further scaling if norm(A) norm(X) > overflow -* - IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN - IF( XNORM.GT.BIGNUM / CMAX ) THEN - TEMP = CMAX / BIGNUM - X( 1, 1 ) = TEMP*X( 1, 1 ) - X( 2, 1 ) = TEMP*X( 2, 1 ) - XNORM = TEMP*XNORM - SCALE = TEMP*SCALE - END IF - END IF - ELSE -* -* Complex 2x2 system (w is complex) -* -* Find the largest element in C -* - CI( 1, 1 ) = -WI*D1 - CI( 2, 1 ) = ZERO - CI( 1, 2 ) = ZERO - CI( 2, 2 ) = -WI*D2 - CMAX = ZERO - ICMAX = 0 -* - DO 20 J = 1, 4 - IF( ABS( CRV( J ) )+ABS( CIV( J ) ).GT.CMAX ) THEN - CMAX = ABS( CRV( J ) ) + ABS( CIV( J ) ) - ICMAX = J - END IF - 20 CONTINUE -* -* If norm(C) < SMINI, use SMINI*identity. -* - IF( CMAX.LT.SMINI ) THEN - BNORM = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ), - $ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) ) - IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN - IF( BNORM.GT.BIGNUM*SMINI ) - $ SCALE = ONE / BNORM - END IF - TEMP = SCALE / SMINI - X( 1, 1 ) = TEMP*B( 1, 1 ) - X( 2, 1 ) = TEMP*B( 2, 1 ) - X( 1, 2 ) = TEMP*B( 1, 2 ) - X( 2, 2 ) = TEMP*B( 2, 2 ) - XNORM = TEMP*BNORM - INFO = 1 - RETURN - END IF -* -* Gaussian elimination with complete pivoting. -* - UR11 = CRV( ICMAX ) - UI11 = CIV( ICMAX ) - CR21 = CRV( IPIVOT( 2, ICMAX ) ) - CI21 = CIV( IPIVOT( 2, ICMAX ) ) - UR12 = CRV( IPIVOT( 3, ICMAX ) ) - UI12 = CIV( IPIVOT( 3, ICMAX ) ) - CR22 = CRV( IPIVOT( 4, ICMAX ) ) - CI22 = CIV( IPIVOT( 4, ICMAX ) ) - IF( ICMAX.EQ.1 .OR. ICMAX.EQ.4 ) THEN -* -* Code when off-diagonals of pivoted C are real -* - IF( ABS( UR11 ).GT.ABS( UI11 ) ) THEN - TEMP = UI11 / UR11 - UR11R = ONE / ( UR11*( ONE+TEMP**2 ) ) - UI11R = -TEMP*UR11R - ELSE - TEMP = UR11 / UI11 - UI11R = -ONE / ( UI11*( ONE+TEMP**2 ) ) - UR11R = -TEMP*UI11R - END IF - LR21 = CR21*UR11R - LI21 = CR21*UI11R - UR12S = UR12*UR11R - UI12S = UR12*UI11R - UR22 = CR22 - UR12*LR21 - UI22 = CI22 - UR12*LI21 - ELSE -* -* Code when diagonals of pivoted C are real -* - UR11R = ONE / UR11 - UI11R = ZERO - LR21 = CR21*UR11R - LI21 = CI21*UR11R - UR12S = UR12*UR11R - UI12S = UI12*UR11R - UR22 = CR22 - UR12*LR21 + UI12*LI21 - UI22 = -UR12*LI21 - UI12*LR21 - END IF - U22ABS = ABS( UR22 ) + ABS( UI22 ) -* -* If smaller pivot < SMINI, use SMINI -* - IF( U22ABS.LT.SMINI ) THEN - UR22 = SMINI - UI22 = ZERO - INFO = 1 - END IF - IF( RSWAP( ICMAX ) ) THEN - BR2 = B( 1, 1 ) - BR1 = B( 2, 1 ) - BI2 = B( 1, 2 ) - BI1 = B( 2, 2 ) - ELSE - BR1 = B( 1, 1 ) - BR2 = B( 2, 1 ) - BI1 = B( 1, 2 ) - BI2 = B( 2, 2 ) - END IF - BR2 = BR2 - LR21*BR1 + LI21*BI1 - BI2 = BI2 - LI21*BR1 - LR21*BI1 - BBND = MAX( ( ABS( BR1 )+ABS( BI1 ) )* - $ ( U22ABS*( ABS( UR11R )+ABS( UI11R ) ) ), - $ ABS( BR2 )+ABS( BI2 ) ) - IF( BBND.GT.ONE .AND. U22ABS.LT.ONE ) THEN - IF( BBND.GE.BIGNUM*U22ABS ) THEN - SCALE = ONE / BBND - BR1 = SCALE*BR1 - BI1 = SCALE*BI1 - BR2 = SCALE*BR2 - BI2 = SCALE*BI2 - END IF - END IF -* - CALL DLADIV( BR2, BI2, UR22, UI22, XR2, XI2 ) - XR1 = UR11R*BR1 - UI11R*BI1 - UR12S*XR2 + UI12S*XI2 - XI1 = UI11R*BR1 + UR11R*BI1 - UI12S*XR2 - UR12S*XI2 - IF( ZSWAP( ICMAX ) ) THEN - X( 1, 1 ) = XR2 - X( 2, 1 ) = XR1 - X( 1, 2 ) = XI2 - X( 2, 2 ) = XI1 - ELSE - X( 1, 1 ) = XR1 - X( 2, 1 ) = XR2 - X( 1, 2 ) = XI1 - X( 2, 2 ) = XI2 - END IF - XNORM = MAX( ABS( XR1 )+ABS( XI1 ), ABS( XR2 )+ABS( XI2 ) ) -* -* Further scaling if norm(A) norm(X) > overflow -* - IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN - IF( XNORM.GT.BIGNUM / CMAX ) THEN - TEMP = CMAX / BIGNUM - X( 1, 1 ) = TEMP*X( 1, 1 ) - X( 2, 1 ) = TEMP*X( 2, 1 ) - X( 1, 2 ) = TEMP*X( 1, 2 ) - X( 2, 2 ) = TEMP*X( 2, 2 ) - XNORM = TEMP*XNORM - SCALE = TEMP*SCALE - END IF - END IF - END IF - END IF -* - RETURN -* -* End of DLALN2 -* - END diff --git a/mtx/lapack_src/dlangb.f b/mtx/lapack_src/dlangb.f deleted file mode 100644 index abf7c2bae..000000000 --- a/mtx/lapack_src/dlangb.f +++ /dev/null @@ -1,223 +0,0 @@ -*> \brief \b DLANGB -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLANGB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB, -* WORK ) -* -* .. Scalar Arguments .. -* CHARACTER NORM -* INTEGER KL, KU, LDAB, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION AB( LDAB, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLANGB returns the value of the one norm, or the Frobenius norm, or -*> the infinity norm, or the element of largest absolute value of an -*> n by n band matrix A, with kl sub-diagonals and ku super-diagonals. -*> \endverbatim -*> -*> \return DLANGB -*> \verbatim -*> -*> DLANGB = ( 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 DLANGB as described -*> above. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. When N = 0, DLANGB is -*> set to zero. -*> \endverbatim -*> -*> \param[in] KL -*> \verbatim -*> KL is INTEGER -*> The number of sub-diagonals of the matrix A. KL >= 0. -*> \endverbatim -*> -*> \param[in] KU -*> \verbatim -*> KU is INTEGER -*> The number of super-diagonals of the matrix A. KU >= 0. -*> \endverbatim -*> -*> \param[in] AB -*> \verbatim -*> AB is DOUBLE PRECISION array, dimension (LDAB,N) -*> The band matrix A, stored in rows 1 to KL+KU+1. The j-th -*> column of A is stored in the j-th column of the array AB as -*> follows: -*> AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). -*> \endverbatim -*> -*> \param[in] LDAB -*> \verbatim -*> LDAB is INTEGER -*> The leading dimension of the array AB. LDAB >= KL+KU+1. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), -*> where LWORK >= N 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. -* -*> \date November 2011 -* -*> \ingroup doubleGBauxiliary -* -* ===================================================================== - DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB, - $ WORK ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER NORM - INTEGER KL, KU, LDAB, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION AB( LDAB, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, K, L - DOUBLE PRECISION SCALE, SUM, VALUE -* .. -* .. External Subroutines .. - EXTERNAL DLASSQ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - IF( 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 = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 ) - VALUE = MAX( VALUE, ABS( AB( I, J ) ) ) - 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 = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 ) - SUM = SUM + ABS( AB( I, J ) ) - 30 CONTINUE - VALUE = MAX( VALUE, SUM ) - 40 CONTINUE - ELSE IF( LSAME( NORM, 'I' ) ) THEN -* -* Find normI(A). -* - DO 50 I = 1, N - WORK( I ) = ZERO - 50 CONTINUE - DO 70 J = 1, N - K = KU + 1 - J - DO 60 I = MAX( 1, J-KU ), MIN( N, J+KL ) - WORK( I ) = WORK( I ) + ABS( AB( K+I, J ) ) - 60 CONTINUE - 70 CONTINUE - VALUE = ZERO - DO 80 I = 1, N - VALUE = MAX( VALUE, WORK( I ) ) - 80 CONTINUE - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - DO 90 J = 1, N - L = MAX( 1, J-KU ) - K = KU + 1 - J + L - CALL DLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, SCALE, SUM ) - 90 CONTINUE - VALUE = SCALE*SQRT( SUM ) - END IF -* - DLANGB = VALUE - RETURN -* -* End of DLANGB -* - END diff --git a/mtx/lapack_src/dlange.f b/mtx/lapack_src/dlange.f deleted file mode 100644 index 47200c16b..000000000 --- a/mtx/lapack_src/dlange.f +++ /dev/null @@ -1,209 +0,0 @@ -*> \brief \b DLANGE -* -* =========== 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. -* -*> \date November 2011 -* -*> \ingroup doubleGEauxiliary -* -* ===================================================================== - DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER 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 -* .. -* .. External Subroutines .. - EXTERNAL DLASSQ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, 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 - VALUE = MAX( VALUE, ABS( A( I, J ) ) ) - 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 - VALUE = MAX( 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 - VALUE = MAX( VALUE, WORK( I ) ) - 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/mtx/lapack_src/dlangt.f b/mtx/lapack_src/dlangt.f deleted file mode 100644 index aa562ab67..000000000 --- a/mtx/lapack_src/dlangt.f +++ /dev/null @@ -1,203 +0,0 @@ -*> \brief \b DLANGT -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLANGT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DLANGT( NORM, N, DL, D, DU ) -* -* .. Scalar Arguments .. -* CHARACTER NORM -* INTEGER N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ), DL( * ), DU( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLANGT 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 tridiagonal matrix A. -*> \endverbatim -*> -*> \return DLANGT -*> \verbatim -*> -*> DLANGT = ( 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 DLANGT as described -*> above. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. When N = 0, DLANGT is -*> set to zero. -*> \endverbatim -*> -*> \param[in] DL -*> \verbatim -*> DL is DOUBLE PRECISION array, dimension (N-1) -*> The (n-1) sub-diagonal elements of A. -*> \endverbatim -*> -*> \param[in] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> The diagonal elements of A. -*> \endverbatim -*> -*> \param[in] DU -*> \verbatim -*> DU is DOUBLE PRECISION array, dimension (N-1) -*> The (n-1) super-diagonal elements of A. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERauxiliary -* -* ===================================================================== - DOUBLE PRECISION FUNCTION DLANGT( NORM, N, DL, D, DU ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER NORM - INTEGER N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), DL( * ), DU( * ) -* .. -* -* ===================================================================== -* -* .. 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 - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLASSQ -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, 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 - ANORM = MAX( ANORM, ABS( DL( I ) ) ) - ANORM = MAX( ANORM, ABS( D( I ) ) ) - ANORM = MAX( ANORM, ABS( DU( I ) ) ) - 10 CONTINUE - ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN -* -* Find norm1(A). -* - IF( N.EQ.1 ) THEN - ANORM = ABS( D( 1 ) ) - ELSE - ANORM = MAX( ABS( D( 1 ) )+ABS( DL( 1 ) ), - $ ABS( D( N ) )+ABS( DU( N-1 ) ) ) - DO 20 I = 2, N - 1 - ANORM = MAX( ANORM, ABS( D( I ) )+ABS( DL( I ) )+ - $ ABS( DU( I-1 ) ) ) - 20 CONTINUE - END IF - ELSE IF( LSAME( NORM, 'I' ) ) THEN -* -* Find normI(A). -* - IF( N.EQ.1 ) THEN - ANORM = ABS( D( 1 ) ) - ELSE - ANORM = MAX( ABS( D( 1 ) )+ABS( DU( 1 ) ), - $ ABS( D( N ) )+ABS( DL( N-1 ) ) ) - DO 30 I = 2, N - 1 - ANORM = MAX( ANORM, ABS( D( I ) )+ABS( DU( I ) )+ - $ ABS( DL( I-1 ) ) ) - 30 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - CALL DLASSQ( N, D, 1, SCALE, SUM ) - IF( N.GT.1 ) THEN - CALL DLASSQ( N-1, DL, 1, SCALE, SUM ) - CALL DLASSQ( N-1, DU, 1, SCALE, SUM ) - END IF - ANORM = SCALE*SQRT( SUM ) - END IF -* - DLANGT = ANORM - RETURN -* -* End of DLANGT -* - END diff --git a/mtx/lapack_src/dlantb.f b/mtx/lapack_src/dlantb.f deleted file mode 100644 index 08e72b0ff..000000000 --- a/mtx/lapack_src/dlantb.f +++ /dev/null @@ -1,356 +0,0 @@ -*> \brief \b DLANTB -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLANTB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DLANTB( NORM, UPLO, DIAG, N, K, AB, -* LDAB, WORK ) -* -* .. Scalar Arguments .. -* CHARACTER DIAG, NORM, UPLO -* INTEGER K, LDAB, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION AB( LDAB, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLANTB returns the value of the one norm, or the Frobenius norm, or -*> the infinity norm, or the element of largest absolute value of an -*> n by n triangular band matrix A, with ( k + 1 ) diagonals. -*> \endverbatim -*> -*> \return DLANTB -*> \verbatim -*> -*> DLANTB = ( 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 DLANTB as described -*> above. -*> \endverbatim -*> -*> \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. When N = 0, DLANTB is -*> set to zero. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of super-diagonals of the matrix A if UPLO = 'U', -*> or the number of sub-diagonals of the matrix A if UPLO = 'L'. -*> K >= 0. -*> \endverbatim -*> -*> \param[in] AB -*> \verbatim -*> AB is DOUBLE PRECISION array, dimension (LDAB,N) -*> The upper or lower triangular band matrix A, stored in the -*> first k+1 rows of AB. The j-th column of A is stored -*> in the j-th column of the array AB as follows: -*> if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; -*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). -*> Note that when DIAG = 'U', the elements of the array AB -*> corresponding to the diagonal elements of the matrix A are -*> not referenced, but are assumed to be one. -*> \endverbatim -*> -*> \param[in] LDAB -*> \verbatim -*> LDAB is INTEGER -*> The leading dimension of the array AB. LDAB >= K+1. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), -*> where LWORK >= N 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. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERauxiliary -* -* ===================================================================== - DOUBLE PRECISION FUNCTION DLANTB( NORM, UPLO, DIAG, N, K, AB, - $ LDAB, WORK ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER DIAG, NORM, UPLO - INTEGER K, LDAB, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION AB( LDAB, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UDIAG - INTEGER I, J, L - DOUBLE PRECISION SCALE, SUM, VALUE -* .. -* .. External Subroutines .. - EXTERNAL DLASSQ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - IF( N.EQ.0 ) THEN - VALUE = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - IF( LSAME( DIAG, 'U' ) ) THEN - VALUE = ONE - IF( LSAME( UPLO, 'U' ) ) THEN - DO 20 J = 1, N - DO 10 I = MAX( K+2-J, 1 ), K - VALUE = MAX( VALUE, ABS( AB( I, J ) ) ) - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1, N - DO 30 I = 2, MIN( N+1-J, K+1 ) - VALUE = MAX( VALUE, ABS( AB( I, J ) ) ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - DO 60 J = 1, N - DO 50 I = MAX( K+2-J, 1 ), K + 1 - VALUE = MAX( VALUE, ABS( AB( I, J ) ) ) - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80 J = 1, N - DO 70 I = 1, MIN( N+1-J, K+1 ) - VALUE = MAX( VALUE, ABS( AB( I, J ) ) ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN -* -* Find norm1(A). -* - VALUE = ZERO - UDIAG = LSAME( DIAG, 'U' ) - IF( LSAME( UPLO, 'U' ) ) THEN - DO 110 J = 1, N - IF( UDIAG ) THEN - SUM = ONE - DO 90 I = MAX( K+2-J, 1 ), K - SUM = SUM + ABS( AB( I, J ) ) - 90 CONTINUE - ELSE - SUM = ZERO - DO 100 I = MAX( K+2-J, 1 ), K + 1 - SUM = SUM + ABS( AB( I, J ) ) - 100 CONTINUE - END IF - VALUE = MAX( VALUE, SUM ) - 110 CONTINUE - ELSE - DO 140 J = 1, N - IF( UDIAG ) THEN - SUM = ONE - DO 120 I = 2, MIN( N+1-J, K+1 ) - SUM = SUM + ABS( AB( I, J ) ) - 120 CONTINUE - ELSE - SUM = ZERO - DO 130 I = 1, MIN( N+1-J, K+1 ) - SUM = SUM + ABS( AB( I, J ) ) - 130 CONTINUE - END IF - VALUE = MAX( VALUE, SUM ) - 140 CONTINUE - END IF - ELSE IF( LSAME( NORM, 'I' ) ) THEN -* -* Find normI(A). -* - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - IF( LSAME( DIAG, 'U' ) ) THEN - DO 150 I = 1, N - WORK( I ) = ONE - 150 CONTINUE - DO 170 J = 1, N - L = K + 1 - J - DO 160 I = MAX( 1, J-K ), J - 1 - WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) - 160 CONTINUE - 170 CONTINUE - ELSE - DO 180 I = 1, N - WORK( I ) = ZERO - 180 CONTINUE - DO 200 J = 1, N - L = K + 1 - J - DO 190 I = MAX( 1, J-K ), J - WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) - 190 CONTINUE - 200 CONTINUE - END IF - ELSE - IF( LSAME( DIAG, 'U' ) ) THEN - DO 210 I = 1, N - WORK( I ) = ONE - 210 CONTINUE - DO 230 J = 1, N - L = 1 - J - DO 220 I = J + 1, MIN( N, J+K ) - WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) - 220 CONTINUE - 230 CONTINUE - ELSE - DO 240 I = 1, N - WORK( I ) = ZERO - 240 CONTINUE - DO 260 J = 1, N - L = 1 - J - DO 250 I = J, MIN( N, J+K ) - WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) - 250 CONTINUE - 260 CONTINUE - END IF - END IF - DO 270 I = 1, N - VALUE = MAX( VALUE, WORK( I ) ) - 270 CONTINUE - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - IF( LSAME( UPLO, 'U' ) ) THEN - IF( LSAME( DIAG, 'U' ) ) THEN - SCALE = ONE - SUM = N - IF( K.GT.0 ) THEN - DO 280 J = 2, N - CALL DLASSQ( MIN( J-1, K ), - $ AB( MAX( K+2-J, 1 ), J ), 1, SCALE, - $ SUM ) - 280 CONTINUE - END IF - ELSE - SCALE = ZERO - SUM = ONE - DO 290 J = 1, N - CALL DLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ), J ), - $ 1, SCALE, SUM ) - 290 CONTINUE - END IF - ELSE - IF( LSAME( DIAG, 'U' ) ) THEN - SCALE = ONE - SUM = N - IF( K.GT.0 ) THEN - DO 300 J = 1, N - 1 - CALL DLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE, - $ SUM ) - 300 CONTINUE - END IF - ELSE - SCALE = ZERO - SUM = ONE - DO 310 J = 1, N - CALL DLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, SCALE, - $ SUM ) - 310 CONTINUE - END IF - END IF - VALUE = SCALE*SQRT( SUM ) - END IF -* - DLANTB = VALUE - RETURN -* -* End of DLANTB -* - END diff --git a/mtx/lapack_src/dlantr.f b/mtx/lapack_src/dlantr.f deleted file mode 100644 index 7d7969b04..000000000 --- a/mtx/lapack_src/dlantr.f +++ /dev/null @@ -1,348 +0,0 @@ -*> \brief \b DLANTR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLANTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, -* WORK ) -* -* .. Scalar Arguments .. -* CHARACTER DIAG, NORM, UPLO -* INTEGER LDA, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLANTR returns the value of the one norm, or the Frobenius norm, or -*> the infinity norm, or the element of largest absolute value of a -*> trapezoidal or triangular matrix A. -*> \endverbatim -*> -*> \return DLANTR -*> \verbatim -*> -*> DLANTR = ( 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 DLANTR as described -*> above. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies whether the matrix A is upper or lower trapezoidal. -*> = 'U': Upper trapezoidal -*> = 'L': Lower trapezoidal -*> Note that A is triangular instead of trapezoidal if M = N. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> Specifies whether or not the matrix A has unit diagonal. -*> = 'N': Non-unit diagonal -*> = 'U': Unit diagonal -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. M >= 0, and if -*> UPLO = 'U', M <= N. When M = 0, DLANTR is set to zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. N >= 0, and if -*> UPLO = 'L', N <= M. When N = 0, DLANTR is set to zero. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The trapezoidal matrix A (A is triangular if M = N). -*> If UPLO = 'U', the leading m by n upper trapezoidal part of -*> the array A contains the upper trapezoidal matrix, and the -*> strictly lower triangular part of A is not referenced. -*> If UPLO = 'L', the leading m by n lower trapezoidal part of -*> the array A contains the lower trapezoidal matrix, and the -*> strictly upper triangular part of A is not referenced. Note -*> that when DIAG = 'U', the diagonal elements of A are not -*> referenced and are assumed to be one. -*> \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. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERauxiliary -* -* ===================================================================== - DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, - $ WORK ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER DIAG, NORM, UPLO - 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 .. - LOGICAL UDIAG - INTEGER I, J - DOUBLE PRECISION SCALE, SUM, VALUE -* .. -* .. External Subroutines .. - EXTERNAL DLASSQ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, 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))). -* - IF( LSAME( DIAG, 'U' ) ) THEN - VALUE = ONE - IF( LSAME( UPLO, 'U' ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, MIN( M, J-1 ) - VALUE = MAX( VALUE, ABS( A( I, J ) ) ) - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1, N - DO 30 I = J + 1, M - VALUE = MAX( VALUE, ABS( A( I, J ) ) ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - DO 60 J = 1, N - DO 50 I = 1, MIN( M, J ) - VALUE = MAX( VALUE, ABS( A( I, J ) ) ) - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80 J = 1, N - DO 70 I = J, M - VALUE = MAX( VALUE, ABS( A( I, J ) ) ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN -* -* Find norm1(A). -* - VALUE = ZERO - UDIAG = LSAME( DIAG, 'U' ) - IF( LSAME( UPLO, 'U' ) ) THEN - DO 110 J = 1, N - IF( ( UDIAG ) .AND. ( J.LE.M ) ) THEN - SUM = ONE - DO 90 I = 1, J - 1 - SUM = SUM + ABS( A( I, J ) ) - 90 CONTINUE - ELSE - SUM = ZERO - DO 100 I = 1, MIN( M, J ) - SUM = SUM + ABS( A( I, J ) ) - 100 CONTINUE - END IF - VALUE = MAX( VALUE, SUM ) - 110 CONTINUE - ELSE - DO 140 J = 1, N - IF( UDIAG ) THEN - SUM = ONE - DO 120 I = J + 1, M - SUM = SUM + ABS( A( I, J ) ) - 120 CONTINUE - ELSE - SUM = ZERO - DO 130 I = J, M - SUM = SUM + ABS( A( I, J ) ) - 130 CONTINUE - END IF - VALUE = MAX( VALUE, SUM ) - 140 CONTINUE - END IF - ELSE IF( LSAME( NORM, 'I' ) ) THEN -* -* Find normI(A). -* - IF( LSAME( UPLO, 'U' ) ) THEN - IF( LSAME( DIAG, 'U' ) ) THEN - DO 150 I = 1, M - WORK( I ) = ONE - 150 CONTINUE - DO 170 J = 1, N - DO 160 I = 1, MIN( M, J-1 ) - WORK( I ) = WORK( I ) + ABS( A( I, J ) ) - 160 CONTINUE - 170 CONTINUE - ELSE - DO 180 I = 1, M - WORK( I ) = ZERO - 180 CONTINUE - DO 200 J = 1, N - DO 190 I = 1, MIN( M, J ) - WORK( I ) = WORK( I ) + ABS( A( I, J ) ) - 190 CONTINUE - 200 CONTINUE - END IF - ELSE - IF( LSAME( DIAG, 'U' ) ) THEN - DO 210 I = 1, N - WORK( I ) = ONE - 210 CONTINUE - DO 220 I = N + 1, M - WORK( I ) = ZERO - 220 CONTINUE - DO 240 J = 1, N - DO 230 I = J + 1, M - WORK( I ) = WORK( I ) + ABS( A( I, J ) ) - 230 CONTINUE - 240 CONTINUE - ELSE - DO 250 I = 1, M - WORK( I ) = ZERO - 250 CONTINUE - DO 270 J = 1, N - DO 260 I = J, M - WORK( I ) = WORK( I ) + ABS( A( I, J ) ) - 260 CONTINUE - 270 CONTINUE - END IF - END IF - VALUE = ZERO - DO 280 I = 1, M - VALUE = MAX( VALUE, WORK( I ) ) - 280 CONTINUE - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - IF( LSAME( UPLO, 'U' ) ) THEN - IF( LSAME( DIAG, 'U' ) ) THEN - SCALE = ONE - SUM = MIN( M, N ) - DO 290 J = 2, N - CALL DLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM ) - 290 CONTINUE - ELSE - SCALE = ZERO - SUM = ONE - DO 300 J = 1, N - CALL DLASSQ( MIN( M, J ), A( 1, J ), 1, SCALE, SUM ) - 300 CONTINUE - END IF - ELSE - IF( LSAME( DIAG, 'U' ) ) THEN - SCALE = ONE - SUM = MIN( M, N ) - DO 310 J = 1, N - CALL DLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE, - $ SUM ) - 310 CONTINUE - ELSE - SCALE = ZERO - SUM = ONE - DO 320 J = 1, N - CALL DLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM ) - 320 CONTINUE - END IF - END IF - VALUE = SCALE*SQRT( SUM ) - END IF -* - DLANTR = VALUE - RETURN -* -* End of DLANTR -* - END diff --git a/mtx/lapack_src/dlanv2.f b/mtx/lapack_src/dlanv2.f deleted file mode 100644 index b5a97b2fb..000000000 --- a/mtx/lapack_src/dlanv2.f +++ /dev/null @@ -1,289 +0,0 @@ -*> \brief \b DLANV2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLANV2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric -*> matrix in standard form: -*> -*> [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] -*> [ C D ] [ SN CS ] [ CC DD ] [-SN CS ] -*> -*> where either -*> 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or -*> 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex -*> conjugate eigenvalues. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION -*> On entry, the elements of the input matrix. -*> On exit, they are overwritten by the elements of the -*> standardised Schur form. -*> \endverbatim -*> -*> \param[out] RT1R -*> \verbatim -*> RT1R is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[out] RT1I -*> \verbatim -*> RT1I is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[out] RT2R -*> \verbatim -*> RT2R is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[out] RT2I -*> \verbatim -*> RT2I is DOUBLE PRECISION -*> The real and imaginary parts of the eigenvalues. If the -*> eigenvalues are a complex conjugate pair, RT1I > 0. -*> \endverbatim -*> -*> \param[out] CS -*> \verbatim -*> CS is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[out] SN -*> \verbatim -*> SN is DOUBLE PRECISION -*> Parameters of the rotation matrix. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Modified by V. Sima, Research Institute for Informatics, Bucharest, -*> Romania, to reduce the risk of cancellation errors, -*> when computing real eigenvalues, and to ensure, if possible, that -*> abs(RT1R) >= abs(RT2R). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) - DOUBLE PRECISION MULTPL - PARAMETER ( MULTPL = 4.0D+0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION AA, BB, BCMAX, BCMIS, CC, CS1, DD, EPS, P, SAB, - $ SAC, SCALE, SIGMA, SN1, TAU, TEMP, Z -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2 - EXTERNAL DLAMCH, DLAPY2 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SIGN, SQRT -* .. -* .. Executable Statements .. -* - EPS = DLAMCH( 'P' ) - IF( C.EQ.ZERO ) THEN - CS = ONE - SN = ZERO - GO TO 10 -* - ELSE IF( B.EQ.ZERO ) THEN -* -* Swap rows and columns -* - CS = ZERO - SN = ONE - TEMP = D - D = A - A = TEMP - B = -C - C = ZERO - GO TO 10 - ELSE IF( ( A-D ).EQ.ZERO .AND. SIGN( ONE, B ).NE.SIGN( ONE, C ) ) - $ THEN - CS = ONE - SN = ZERO - GO TO 10 - ELSE -* - TEMP = A - D - P = HALF*TEMP - BCMAX = MAX( ABS( B ), ABS( C ) ) - BCMIS = MIN( ABS( B ), ABS( C ) )*SIGN( ONE, B )*SIGN( ONE, C ) - SCALE = MAX( ABS( P ), BCMAX ) - Z = ( P / SCALE )*P + ( BCMAX / SCALE )*BCMIS -* -* If Z is of the order of the machine accuracy, postpone the -* decision on the nature of eigenvalues -* - IF( Z.GE.MULTPL*EPS ) THEN -* -* Real eigenvalues. Compute A and D. -* - Z = P + SIGN( SQRT( SCALE )*SQRT( Z ), P ) - A = D + Z - D = D - ( BCMAX / Z )*BCMIS -* -* Compute B and the rotation matrix -* - TAU = DLAPY2( C, Z ) - CS = Z / TAU - SN = C / TAU - B = B - C - C = ZERO - ELSE -* -* Complex eigenvalues, or real (almost) equal eigenvalues. -* Make diagonal elements equal. -* - SIGMA = B + C - TAU = DLAPY2( SIGMA, TEMP ) - CS = SQRT( HALF*( ONE+ABS( SIGMA ) / TAU ) ) - SN = -( P / ( TAU*CS ) )*SIGN( ONE, SIGMA ) -* -* Compute [ AA BB ] = [ A B ] [ CS -SN ] -* [ CC DD ] [ C D ] [ SN CS ] -* - AA = A*CS + B*SN - BB = -A*SN + B*CS - CC = C*CS + D*SN - DD = -C*SN + D*CS -* -* Compute [ A B ] = [ CS SN ] [ AA BB ] -* [ C D ] [-SN CS ] [ CC DD ] -* - A = AA*CS + CC*SN - B = BB*CS + DD*SN - C = -AA*SN + CC*CS - D = -BB*SN + DD*CS -* - TEMP = HALF*( A+D ) - A = TEMP - D = TEMP -* - IF( C.NE.ZERO ) THEN - IF( B.NE.ZERO ) THEN - IF( SIGN( ONE, B ).EQ.SIGN( ONE, C ) ) THEN -* -* Real eigenvalues: reduce to upper triangular form -* - SAB = SQRT( ABS( B ) ) - SAC = SQRT( ABS( C ) ) - P = SIGN( SAB*SAC, C ) - TAU = ONE / SQRT( ABS( B+C ) ) - A = TEMP + P - D = TEMP - P - B = B - C - C = ZERO - CS1 = SAB*TAU - SN1 = SAC*TAU - TEMP = CS*CS1 - SN*SN1 - SN = CS*SN1 + SN*CS1 - CS = TEMP - END IF - ELSE - B = -C - C = ZERO - TEMP = CS - CS = -SN - SN = TEMP - END IF - END IF - END IF -* - END IF -* - 10 CONTINUE -* -* Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). -* - RT1R = A - RT2R = D - IF( C.EQ.ZERO ) THEN - RT1I = ZERO - RT2I = ZERO - ELSE - RT1I = SQRT( ABS( B ) )*SQRT( ABS( C ) ) - RT2I = -RT1I - END IF - RETURN -* -* End of DLANV2 -* - END diff --git a/mtx/lapack_src/dlapy2.f b/mtx/lapack_src/dlapy2.f deleted file mode 100644 index e6a62bf4a..000000000 --- a/mtx/lapack_src/dlapy2.f +++ /dev/null @@ -1,104 +0,0 @@ -*> \brief \b DLAPY2 -* -* =========== 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. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] X -*> \verbatim -*> X is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] Y -*> \verbatim -*> Y is DOUBLE PRECISION -*> X and Y specify the values x and y. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup auxOTHERauxiliary -* -* ===================================================================== - DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - DOUBLE PRECISION X, Y -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION W, XABS, YABS, Z -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - XABS = ABS( X ) - YABS = ABS( Y ) - W = MAX( XABS, YABS ) - Z = MIN( XABS, YABS ) - IF( Z.EQ.ZERO ) THEN - DLAPY2 = W - ELSE - DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) - END IF - RETURN -* -* End of DLAPY2 -* - END diff --git a/mtx/lapack_src/dlaqgb.f b/mtx/lapack_src/dlaqgb.f deleted file mode 100644 index da2a08a03..000000000 --- a/mtx/lapack_src/dlaqgb.f +++ /dev/null @@ -1,256 +0,0 @@ -*> \brief \b DLAQGB -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAQGB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, -* AMAX, EQUED ) -* -* .. Scalar Arguments .. -* CHARACTER EQUED -* INTEGER KL, KU, LDAB, M, N -* DOUBLE PRECISION AMAX, COLCND, ROWCND -* .. -* .. Array Arguments .. -* DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAQGB equilibrates a general M by N band matrix A with KL -*> subdiagonals and KU superdiagonals using the row and scaling factors -*> in the vectors R and C. -*> \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] KL -*> \verbatim -*> KL is INTEGER -*> The number of subdiagonals within the band of A. KL >= 0. -*> \endverbatim -*> -*> \param[in] KU -*> \verbatim -*> KU is INTEGER -*> The number of superdiagonals within the band of A. KU >= 0. -*> \endverbatim -*> -*> \param[in,out] AB -*> \verbatim -*> AB is DOUBLE PRECISION array, dimension (LDAB,N) -*> On entry, the matrix A in band storage, in rows 1 to KL+KU+1. -*> The j-th column of A is stored in the j-th column of the -*> array AB as follows: -*> AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) -*> -*> On exit, the equilibrated matrix, in the same storage format -*> as A. See EQUED for the form of the equilibrated matrix. -*> \endverbatim -*> -*> \param[in] LDAB -*> \verbatim -*> LDAB is INTEGER -*> The leading dimension of the array AB. LDA >= KL+KU+1. -*> \endverbatim -*> -*> \param[in] R -*> \verbatim -*> R is DOUBLE PRECISION array, dimension (M) -*> The row scale factors for A. -*> \endverbatim -*> -*> \param[in] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (N) -*> The column scale factors for A. -*> \endverbatim -*> -*> \param[in] ROWCND -*> \verbatim -*> ROWCND is DOUBLE PRECISION -*> Ratio of the smallest R(i) to the largest R(i). -*> \endverbatim -*> -*> \param[in] COLCND -*> \verbatim -*> COLCND is DOUBLE PRECISION -*> Ratio of the smallest C(i) to the largest C(i). -*> \endverbatim -*> -*> \param[in] AMAX -*> \verbatim -*> AMAX is DOUBLE PRECISION -*> Absolute value of largest matrix entry. -*> \endverbatim -*> -*> \param[out] EQUED -*> \verbatim -*> EQUED is CHARACTER*1 -*> Specifies the form of equilibration that was done. -*> = 'N': No equilibration -*> = 'R': Row equilibration, i.e., A has been premultiplied by -*> diag(R). -*> = 'C': Column equilibration, i.e., A has been postmultiplied -*> by diag(C). -*> = 'B': Both row and column equilibration, i.e., A has been -*> replaced by diag(R) * A * diag(C). -*> \endverbatim -* -*> \par Internal Parameters: -* ========================= -*> -*> \verbatim -*> THRESH is a threshold value used to decide if row or column scaling -*> should be done based on the ratio of the row or column scaling -*> factors. If ROWCND < THRESH, row scaling is done, and if -*> COLCND < THRESH, column scaling is done. -*> -*> LARGE and SMALL are threshold values used to decide if row scaling -*> should be done based on the absolute size of the largest matrix -*> element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleGBauxiliary -* -* ===================================================================== - SUBROUTINE DLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, - $ AMAX, EQUED ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER EQUED - INTEGER KL, KU, LDAB, M, N - DOUBLE PRECISION AMAX, COLCND, ROWCND -* .. -* .. Array Arguments .. - DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, THRESH - PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION CJ, LARGE, SMALL -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) THEN - EQUED = 'N' - RETURN - END IF -* -* Initialize LARGE and SMALL. -* - SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - LARGE = ONE / SMALL -* - IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) - $ THEN -* -* No row scaling -* - IF( COLCND.GE.THRESH ) THEN -* -* No column scaling -* - EQUED = 'N' - ELSE -* -* Column scaling -* - DO 20 J = 1, N - CJ = C( J ) - DO 10 I = MAX( 1, J-KU ), MIN( M, J+KL ) - AB( KU+1+I-J, J ) = CJ*AB( KU+1+I-J, J ) - 10 CONTINUE - 20 CONTINUE - EQUED = 'C' - END IF - ELSE IF( COLCND.GE.THRESH ) THEN -* -* Row scaling, no column scaling -* - DO 40 J = 1, N - DO 30 I = MAX( 1, J-KU ), MIN( M, J+KL ) - AB( KU+1+I-J, J ) = R( I )*AB( KU+1+I-J, J ) - 30 CONTINUE - 40 CONTINUE - EQUED = 'R' - ELSE -* -* Row and column scaling -* - DO 60 J = 1, N - CJ = C( J ) - DO 50 I = MAX( 1, J-KU ), MIN( M, J+KL ) - AB( KU+1+I-J, J ) = CJ*R( I )*AB( KU+1+I-J, J ) - 50 CONTINUE - 60 CONTINUE - EQUED = 'B' - END IF -* - RETURN -* -* End of DLAQGB -* - END diff --git a/mtx/lapack_src/dlaqge.f b/mtx/lapack_src/dlaqge.f deleted file mode 100644 index 568cc5ae8..000000000 --- a/mtx/lapack_src/dlaqge.f +++ /dev/null @@ -1,236 +0,0 @@ -*> \brief \b DLAQGE -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAQGE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, -* EQUED ) -* -* .. Scalar Arguments .. -* CHARACTER EQUED -* INTEGER LDA, M, N -* DOUBLE PRECISION AMAX, COLCND, ROWCND -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAQGE equilibrates a general M by N matrix A using the row and -*> column scaling factors in the vectors R and C. -*> \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 equilibrated matrix. See EQUED for the form of -*> the equilibrated matrix. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(M,1). -*> \endverbatim -*> -*> \param[in] R -*> \verbatim -*> R is DOUBLE PRECISION array, dimension (M) -*> The row scale factors for A. -*> \endverbatim -*> -*> \param[in] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (N) -*> The column scale factors for A. -*> \endverbatim -*> -*> \param[in] ROWCND -*> \verbatim -*> ROWCND is DOUBLE PRECISION -*> Ratio of the smallest R(i) to the largest R(i). -*> \endverbatim -*> -*> \param[in] COLCND -*> \verbatim -*> COLCND is DOUBLE PRECISION -*> Ratio of the smallest C(i) to the largest C(i). -*> \endverbatim -*> -*> \param[in] AMAX -*> \verbatim -*> AMAX is DOUBLE PRECISION -*> Absolute value of largest matrix entry. -*> \endverbatim -*> -*> \param[out] EQUED -*> \verbatim -*> EQUED is CHARACTER*1 -*> Specifies the form of equilibration that was done. -*> = 'N': No equilibration -*> = 'R': Row equilibration, i.e., A has been premultiplied by -*> diag(R). -*> = 'C': Column equilibration, i.e., A has been postmultiplied -*> by diag(C). -*> = 'B': Both row and column equilibration, i.e., A has been -*> replaced by diag(R) * A * diag(C). -*> \endverbatim -* -*> \par Internal Parameters: -* ========================= -*> -*> \verbatim -*> THRESH is a threshold value used to decide if row or column scaling -*> should be done based on the ratio of the row or column scaling -*> factors. If ROWCND < THRESH, row scaling is done, and if -*> COLCND < THRESH, column scaling is done. -*> -*> LARGE and SMALL are threshold values used to decide if row scaling -*> should be done based on the absolute size of the largest matrix -*> element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleGEauxiliary -* -* ===================================================================== - SUBROUTINE DLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, - $ EQUED ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER EQUED - INTEGER LDA, M, N - DOUBLE PRECISION AMAX, COLCND, ROWCND -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, THRESH - PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION CJ, LARGE, SMALL -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) THEN - EQUED = 'N' - RETURN - END IF -* -* Initialize LARGE and SMALL. -* - SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - LARGE = ONE / SMALL -* - IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) - $ THEN -* -* No row scaling -* - IF( COLCND.GE.THRESH ) THEN -* -* No column scaling -* - EQUED = 'N' - ELSE -* -* Column scaling -* - DO 20 J = 1, N - CJ = C( J ) - DO 10 I = 1, M - A( I, J ) = CJ*A( I, J ) - 10 CONTINUE - 20 CONTINUE - EQUED = 'C' - END IF - ELSE IF( COLCND.GE.THRESH ) THEN -* -* Row scaling, no column scaling -* - DO 40 J = 1, N - DO 30 I = 1, M - A( I, J ) = R( I )*A( I, J ) - 30 CONTINUE - 40 CONTINUE - EQUED = 'R' - ELSE -* -* Row and column scaling -* - DO 60 J = 1, N - CJ = C( J ) - DO 50 I = 1, M - A( I, J ) = CJ*R( I )*A( I, J ) - 50 CONTINUE - 60 CONTINUE - EQUED = 'B' - END IF -* - RETURN -* -* End of DLAQGE -* - END diff --git a/mtx/lapack_src/dlaqr0.f b/mtx/lapack_src/dlaqr0.f deleted file mode 100644 index b1affb331..000000000 --- a/mtx/lapack_src/dlaqr0.f +++ /dev/null @@ -1,740 +0,0 @@ -*> \brief \b DLAQR0 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAQR0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, -* ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N -* LOGICAL WANTT, WANTZ -* .. -* .. Array Arguments .. -* DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), -* $ Z( LDZ, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAQR0 computes the eigenvalues of a Hessenberg matrix H -*> and, optionally, the matrices T and Z from the Schur decomposition -*> H = Z T Z**T, where T is an upper quasi-triangular matrix (the -*> Schur form), and Z is the orthogonal matrix of Schur vectors. -*> -*> Optionally Z may be postmultiplied into an input orthogonal -*> matrix Q so that this routine can give the Schur factorization -*> of a matrix A which has been reduced to the Hessenberg form H -*> by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] WANTT -*> \verbatim -*> WANTT is LOGICAL -*> = .TRUE. : the full Schur form T is required; -*> = .FALSE.: only eigenvalues are required. -*> \endverbatim -*> -*> \param[in] WANTZ -*> \verbatim -*> WANTZ is LOGICAL -*> = .TRUE. : the matrix of Schur vectors Z is required; -*> = .FALSE.: Schur vectors are not required. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix H. N .GE. 0. -*> \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 and, if ILO.GT.1, -*> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a -*> previous call to DGEBAL, and then passed to DGEHRD when the -*> matrix output by DGEBAL is reduced to Hessenberg form. -*> Otherwise, ILO and IHI should be set to 1 and N, -*> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. -*> If N = 0, then ILO = 1 and IHI = 0. -*> \endverbatim -*> -*> \param[in,out] H -*> \verbatim -*> H is DOUBLE PRECISION array, dimension (LDH,N) -*> On entry, the upper Hessenberg matrix H. -*> On exit, if INFO = 0 and WANTT is .TRUE., then H contains -*> the upper quasi-triangular matrix T from the Schur -*> decomposition (the Schur form); 2-by-2 diagonal blocks -*> (corresponding to complex conjugate pairs of eigenvalues) -*> are returned in standard form, with H(i,i) = H(i+1,i+1) -*> and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is -*> .FALSE., then the contents of H are unspecified on exit. -*> (The output value of H when INFO.GT.0 is given under the -*> description of INFO below.) -*> -*> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and -*> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. -*> \endverbatim -*> -*> \param[in] LDH -*> \verbatim -*> LDH is INTEGER -*> The leading dimension of the array H. LDH .GE. max(1,N). -*> \endverbatim -*> -*> \param[out] WR -*> \verbatim -*> WR is DOUBLE PRECISION array, dimension (IHI) -*> \endverbatim -*> -*> \param[out] WI -*> \verbatim -*> WI is DOUBLE PRECISION array, dimension (IHI) -*> The real and imaginary parts, respectively, of the computed -*> eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) -*> and WI(ILO:IHI). If two eigenvalues are computed as a -*> complex conjugate pair, they are stored in consecutive -*> elements of WR and WI, say the i-th and (i+1)th, with -*> WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then -*> the eigenvalues are stored in the same order as on the -*> diagonal of the Schur form returned in H, with -*> WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal -*> block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and -*> WI(i+1) = -WI(i). -*> \endverbatim -*> -*> \param[in] ILOZ -*> \verbatim -*> ILOZ is INTEGER -*> \endverbatim -*> -*> \param[in] IHIZ -*> \verbatim -*> IHIZ is INTEGER -*> Specify the rows of Z to which transformations must be -*> applied if WANTZ is .TRUE.. -*> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. -*> \endverbatim -*> -*> \param[in,out] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (LDZ,IHI) -*> If WANTZ is .FALSE., then Z is not referenced. -*> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is -*> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the -*> orthogonal Schur factor of H(ILO:IHI,ILO:IHI). -*> (The output value of Z when INFO.GT.0 is given under -*> the description of INFO below.) -*> \endverbatim -*> -*> \param[in] LDZ -*> \verbatim -*> LDZ is INTEGER -*> The leading dimension of the array Z. if WANTZ is .TRUE. -*> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension LWORK -*> On exit, if LWORK = -1, WORK(1) returns an estimate of -*> the optimal value for LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. LWORK .GE. max(1,N) -*> is sufficient, but LWORK typically as large as 6*N may -*> be required for optimal performance. A workspace query -*> to determine the optimal workspace size is recommended. -*> -*> If LWORK = -1, then DLAQR0 does a workspace query. -*> In this case, DLAQR0 checks the input parameters and -*> estimates the optimal workspace size for the given -*> values of N, ILO and IHI. The estimate is returned -*> in WORK(1). No error message related to LWORK is -*> issued by XERBLA. Neither H nor Z are accessed. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> .GT. 0: if INFO = i, DLAQR0 failed to compute all of -*> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR -*> and WI contain those eigenvalues which have been -*> successfully computed. (Failures are rare.) -*> -*> If INFO .GT. 0 and WANT is .FALSE., then on exit, -*> the remaining unconverged eigenvalues are the eigen- -*> values of the upper Hessenberg matrix rows and -*> columns ILO through INFO of the final, output -*> value of H. -*> -*> If INFO .GT. 0 and WANTT is .TRUE., then on exit -*> -*> (*) (initial value of H)*U = U*(final value of H) -*> -*> where U is an orthogonal matrix. The final -*> value of H is upper Hessenberg and quasi-triangular -*> in rows and columns INFO+1 through IHI. -*> -*> If INFO .GT. 0 and WANTZ is .TRUE., then on exit -*> -*> (final value of Z(ILO:IHI,ILOZ:IHIZ) -*> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U -*> -*> where U is the orthogonal matrix in (*) (regard- -*> less of the value of WANTT.) -*> -*> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not -*> accessed. -*> \endverbatim -* -*> \par Contributors: -* ================== -*> -*> Karen Braman and Ralph Byers, Department of Mathematics, -*> University of Kansas, USA -* -*> \par References: -* ================ -*> -*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR -*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 -*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages -*> 929--947, 2002. -*> \n -*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR -*> Algorithm Part II: Aggressive Early Deflation, SIAM Journal -*> of Matrix Analysis, volume 23, pages 948--973, 2002. -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, - $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N - LOGICAL WANTT, WANTZ -* .. -* .. Array Arguments .. - DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), - $ Z( LDZ, * ) -* .. -* -* ================================================================ -* -* .. Parameters .. -* -* ==== Matrices of order NTINY or smaller must be processed by -* . DLAHQR because of insufficient subdiagonal scratch space. -* . (This is a hard limit.) ==== - INTEGER NTINY - PARAMETER ( NTINY = 11 ) -* -* ==== Exceptional deflation windows: try to cure rare -* . slow convergence by varying the size of the -* . deflation window after KEXNW iterations. ==== - INTEGER KEXNW - PARAMETER ( KEXNW = 5 ) -* -* ==== Exceptional shifts: try to cure rare slow convergence -* . with ad-hoc exceptional shifts every KEXSH iterations. -* . ==== - INTEGER KEXSH - PARAMETER ( KEXSH = 6 ) -* -* ==== The constants WILK1 and WILK2 are used to form the -* . exceptional shifts. ==== - DOUBLE PRECISION WILK1, WILK2 - PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP - INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, - $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, - $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, - $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD - LOGICAL SORTED - CHARACTER JBCMPZ*2 -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Local Arrays .. - DOUBLE PRECISION ZDUM( 1, 1 ) -* .. -* .. External Subroutines .. - EXTERNAL DLACPY, DLAHQR, DLANV2, DLAQR3, DLAQR4, DLAQR5 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD -* .. -* .. Executable Statements .. - INFO = 0 -* -* ==== Quick return for N = 0: nothing to do. ==== -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = ONE - RETURN - END IF -* - IF( N.LE.NTINY ) THEN -* -* ==== Tiny matrices must use DLAHQR. ==== -* - LWKOPT = 1 - IF( LWORK.NE.-1 ) - $ CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, - $ ILOZ, IHIZ, Z, LDZ, INFO ) - ELSE -* -* ==== Use small bulge multi-shift QR with aggressive early -* . deflation on larger-than-tiny matrices. ==== -* -* ==== Hope for the best. ==== -* - INFO = 0 -* -* ==== Set up job flags for ILAENV. ==== -* - IF( WANTT ) THEN - JBCMPZ( 1: 1 ) = 'S' - ELSE - JBCMPZ( 1: 1 ) = 'E' - END IF - IF( WANTZ ) THEN - JBCMPZ( 2: 2 ) = 'V' - ELSE - JBCMPZ( 2: 2 ) = 'N' - END IF -* -* ==== NWR = recommended deflation window size. At this -* . point, N .GT. NTINY = 11, so there is enough -* . subdiagonal workspace for NWR.GE.2 as required. -* . (In fact, there is enough subdiagonal space for -* . NWR.GE.3.) ==== -* - NWR = ILAENV( 13, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) - NWR = MAX( 2, NWR ) - NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) -* -* ==== NSR = recommended number of simultaneous shifts. -* . At this point N .GT. NTINY = 11, so there is at -* . enough subdiagonal workspace for NSR to be even -* . and greater than or equal to two as required. ==== -* - NSR = ILAENV( 15, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) - NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) - NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) -* -* ==== Estimate optimal workspace ==== -* -* ==== Workspace query call to DLAQR3 ==== -* - CALL DLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, - $ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH, - $ N, H, LDH, WORK, -1 ) -* -* ==== Optimal workspace = MAX(DLAQR5, DLAQR3) ==== -* - LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) -* -* ==== Quick return in case of workspace query. ==== -* - IF( LWORK.EQ.-1 ) THEN - WORK( 1 ) = DBLE( LWKOPT ) - RETURN - END IF -* -* ==== DLAHQR/DLAQR0 crossover point ==== -* - NMIN = ILAENV( 12, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) - NMIN = MAX( NTINY, NMIN ) -* -* ==== Nibble crossover point ==== -* - NIBBLE = ILAENV( 14, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) - NIBBLE = MAX( 0, NIBBLE ) -* -* ==== Accumulate reflections during ttswp? Use block -* . 2-by-2 structure during matrix-matrix multiply? ==== -* - KACC22 = ILAENV( 16, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) - KACC22 = MAX( 0, KACC22 ) - KACC22 = MIN( 2, KACC22 ) -* -* ==== NWMAX = the largest possible deflation window for -* . which there is sufficient workspace. ==== -* - NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) - NW = NWMAX -* -* ==== NSMAX = the Largest number of simultaneous shifts -* . for which there is sufficient workspace. ==== -* - NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) - NSMAX = NSMAX - MOD( NSMAX, 2 ) -* -* ==== NDFL: an iteration count restarted at deflation. ==== -* - NDFL = 1 -* -* ==== ITMAX = iteration limit ==== -* - ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) -* -* ==== Last row and column in the active block ==== -* - KBOT = IHI -* -* ==== Main Loop ==== -* - DO 80 IT = 1, ITMAX -* -* ==== Done when KBOT falls below ILO ==== -* - IF( KBOT.LT.ILO ) - $ GO TO 90 -* -* ==== Locate active block ==== -* - DO 10 K = KBOT, ILO + 1, -1 - IF( H( K, K-1 ).EQ.ZERO ) - $ GO TO 20 - 10 CONTINUE - K = ILO - 20 CONTINUE - KTOP = K -* -* ==== Select deflation window size: -* . Typical Case: -* . If possible and advisable, nibble the entire -* . active block. If not, use size MIN(NWR,NWMAX) -* . or MIN(NWR+1,NWMAX) depending upon which has -* . the smaller corresponding subdiagonal entry -* . (a heuristic). -* . -* . Exceptional Case: -* . If there have been no deflations in KEXNW or -* . more iterations, then vary the deflation window -* . size. At first, because, larger windows are, -* . in general, more powerful than smaller ones, -* . rapidly increase the window to the maximum possible. -* . Then, gradually reduce the window size. ==== -* - NH = KBOT - KTOP + 1 - NWUPBD = MIN( NH, NWMAX ) - IF( NDFL.LT.KEXNW ) THEN - NW = MIN( NWUPBD, NWR ) - ELSE - NW = MIN( NWUPBD, 2*NW ) - END IF - IF( NW.LT.NWMAX ) THEN - IF( NW.GE.NH-1 ) THEN - NW = NH - ELSE - KWTOP = KBOT - NW + 1 - IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. - $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 - END IF - END IF - IF( NDFL.LT.KEXNW ) THEN - NDEC = -1 - ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN - NDEC = NDEC + 1 - IF( NW-NDEC.LT.2 ) - $ NDEC = 0 - NW = NW - NDEC - END IF -* -* ==== Aggressive early deflation: -* . split workspace under the subdiagonal into -* . - an nw-by-nw work array V in the lower -* . left-hand-corner, -* . - an NW-by-at-least-NW-but-more-is-better -* . (NW-by-NHO) horizontal work array along -* . the bottom edge, -* . - an at-least-NW-but-more-is-better (NHV-by-NW) -* . vertical work array along the left-hand-edge. -* . ==== -* - KV = N - NW + 1 - KT = NW + 1 - NHO = ( N-NW-1 ) - KT + 1 - KWV = NW + 2 - NVE = ( N-NW ) - KWV + 1 -* -* ==== Aggressive early deflation ==== -* - CALL DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, - $ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH, - $ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, - $ WORK, LWORK ) -* -* ==== Adjust KBOT accounting for new deflations. ==== -* - KBOT = KBOT - LD -* -* ==== KS points to the shifts. ==== -* - KS = KBOT - LS + 1 -* -* ==== Skip an expensive QR sweep if there is a (partly -* . heuristic) reason to expect that many eigenvalues -* . will deflate without it. Here, the QR sweep is -* . skipped if many eigenvalues have just been deflated -* . or if the remaining active block is small. -* - IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- - $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN -* -* ==== NS = nominal number of simultaneous shifts. -* . This may be lowered (slightly) if DLAQR3 -* . did not provide that many shifts. ==== -* - NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) - NS = NS - MOD( NS, 2 ) -* -* ==== If there have been no deflations -* . in a multiple of KEXSH iterations, -* . then try exceptional shifts. -* . Otherwise use shifts provided by -* . DLAQR3 above or from the eigenvalues -* . of a trailing principal submatrix. ==== -* - IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN - KS = KBOT - NS + 1 - DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2 - SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) - AA = WILK1*SS + H( I, I ) - BB = SS - CC = WILK2*SS - DD = AA - CALL DLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ), - $ WR( I ), WI( I ), CS, SN ) - 30 CONTINUE - IF( KS.EQ.KTOP ) THEN - WR( KS+1 ) = H( KS+1, KS+1 ) - WI( KS+1 ) = ZERO - WR( KS ) = WR( KS+1 ) - WI( KS ) = WI( KS+1 ) - END IF - ELSE -* -* ==== Got NS/2 or fewer shifts? Use DLAQR4 or -* . DLAHQR on a trailing principal submatrix to -* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, -* . there is enough space below the subdiagonal -* . to fit an NS-by-NS scratch array.) ==== -* - IF( KBOT-KS+1.LE.NS / 2 ) THEN - KS = KBOT - NS + 1 - KT = N - NS + 1 - CALL DLACPY( 'A', NS, NS, H( KS, KS ), LDH, - $ H( KT, 1 ), LDH ) - IF( NS.GT.NMIN ) THEN - CALL DLAQR4( .false., .false., NS, 1, NS, - $ H( KT, 1 ), LDH, WR( KS ), - $ WI( KS ), 1, 1, ZDUM, 1, WORK, - $ LWORK, INF ) - ELSE - CALL DLAHQR( .false., .false., NS, 1, NS, - $ H( KT, 1 ), LDH, WR( KS ), - $ WI( KS ), 1, 1, ZDUM, 1, INF ) - END IF - KS = KS + INF -* -* ==== In case of a rare QR failure use -* . eigenvalues of the trailing 2-by-2 -* . principal submatrix. ==== -* - IF( KS.GE.KBOT ) THEN - AA = H( KBOT-1, KBOT-1 ) - CC = H( KBOT, KBOT-1 ) - BB = H( KBOT-1, KBOT ) - DD = H( KBOT, KBOT ) - CALL DLANV2( AA, BB, CC, DD, WR( KBOT-1 ), - $ WI( KBOT-1 ), WR( KBOT ), - $ WI( KBOT ), CS, SN ) - KS = KBOT - 1 - END IF - END IF -* - IF( KBOT-KS+1.GT.NS ) THEN -* -* ==== Sort the shifts (Helps a little) -* . Bubble sort keeps complex conjugate -* . pairs together. ==== -* - SORTED = .false. - DO 50 K = KBOT, KS + 1, -1 - IF( SORTED ) - $ GO TO 60 - SORTED = .true. - DO 40 I = KS, K - 1 - IF( ABS( WR( I ) )+ABS( WI( I ) ).LT. - $ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN - SORTED = .false. -* - SWAP = WR( I ) - WR( I ) = WR( I+1 ) - WR( I+1 ) = SWAP -* - SWAP = WI( I ) - WI( I ) = WI( I+1 ) - WI( I+1 ) = SWAP - END IF - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - END IF -* -* ==== Shuffle shifts into pairs of real shifts -* . and pairs of complex conjugate shifts -* . assuming complex conjugate shifts are -* . already adjacent to one another. (Yes, -* . they are.) ==== -* - DO 70 I = KBOT, KS + 2, -2 - IF( WI( I ).NE.-WI( I-1 ) ) THEN -* - SWAP = WR( I ) - WR( I ) = WR( I-1 ) - WR( I-1 ) = WR( I-2 ) - WR( I-2 ) = SWAP -* - SWAP = WI( I ) - WI( I ) = WI( I-1 ) - WI( I-1 ) = WI( I-2 ) - WI( I-2 ) = SWAP - END IF - 70 CONTINUE - END IF -* -* ==== If there are only two shifts and both are -* . real, then use only one. ==== -* - IF( KBOT-KS+1.EQ.2 ) THEN - IF( WI( KBOT ).EQ.ZERO ) THEN - IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT. - $ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN - WR( KBOT-1 ) = WR( KBOT ) - ELSE - WR( KBOT ) = WR( KBOT-1 ) - END IF - END IF - END IF -* -* ==== Use up to NS of the the smallest magnatiude -* . shifts. If there aren't NS shifts available, -* . then use them all, possibly dropping one to -* . make the number of shifts even. ==== -* - NS = MIN( NS, KBOT-KS+1 ) - NS = NS - MOD( NS, 2 ) - KS = KBOT - NS + 1 -* -* ==== Small-bulge multi-shift QR sweep: -* . split workspace under the subdiagonal into -* . - a KDU-by-KDU work array U in the lower -* . left-hand-corner, -* . - a KDU-by-at-least-KDU-but-more-is-better -* . (KDU-by-NHo) horizontal work array WH along -* . the bottom edge, -* . - and an at-least-KDU-but-more-is-better-by-KDU -* . (NVE-by-KDU) vertical work WV arrow along -* . the left-hand-edge. ==== -* - KDU = 3*NS - 3 - KU = N - KDU + 1 - KWH = KDU + 1 - NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 - KWV = KDU + 4 - NVE = N - KDU - KWV + 1 -* -* ==== Small-bulge multi-shift QR sweep ==== -* - CALL DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, - $ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z, - $ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE, - $ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH ) - END IF -* -* ==== Note progress (or the lack of it). ==== -* - IF( LD.GT.0 ) THEN - NDFL = 1 - ELSE - NDFL = NDFL + 1 - END IF -* -* ==== End of main loop ==== - 80 CONTINUE -* -* ==== Iteration limit exceeded. Set INFO to show where -* . the problem occurred and exit. ==== -* - INFO = KBOT - 90 CONTINUE - END IF -* -* ==== Return the optimal value of LWORK. ==== -* - WORK( 1 ) = DBLE( LWKOPT ) -* -* ==== End of DLAQR0 ==== -* - END diff --git a/mtx/lapack_src/dlaqr1.f b/mtx/lapack_src/dlaqr1.f deleted file mode 100644 index 8263202e4..000000000 --- a/mtx/lapack_src/dlaqr1.f +++ /dev/null @@ -1,179 +0,0 @@ -*> \brief \b DLAQR1 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAQR1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION SI1, SI2, SR1, SR2 -* INTEGER LDH, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION H( LDH, * ), V( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Given a 2-by-2 or 3-by-3 matrix H, DLAQR1 sets v to a -*> scalar multiple of the first column of the product -*> -*> (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I) -*> -*> scaling to avoid overflows and most underflows. It -*> is assumed that either -*> -*> 1) sr1 = sr2 and si1 = -si2 -*> or -*> 2) si1 = si2 = 0. -*> -*> This is useful for starting double implicit shift bulges -*> in the QR algorithm. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is integer -*> Order of the matrix H. N must be either 2 or 3. -*> \endverbatim -*> -*> \param[in] H -*> \verbatim -*> H is DOUBLE PRECISION array of dimension (LDH,N) -*> The 2-by-2 or 3-by-3 matrix H in (*). -*> \endverbatim -*> -*> \param[in] LDH -*> \verbatim -*> LDH is integer -*> The leading dimension of H as declared in -*> the calling procedure. LDH.GE.N -*> \endverbatim -*> -*> \param[in] SR1 -*> \verbatim -*> SR1 is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] SI1 -*> \verbatim -*> SI1 is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] SR2 -*> \verbatim -*> SR2 is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] SI2 -*> \verbatim -*> SI2 is DOUBLE PRECISION -*> The shifts in (*). -*> \endverbatim -*> -*> \param[out] V -*> \verbatim -*> V is DOUBLE PRECISION array of dimension N -*> A scalar multiple of the first column of the -*> matrix K in (*). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Contributors: -* ================== -*> -*> Karen Braman and Ralph Byers, Department of Mathematics, -*> University of Kansas, USA -*> -* ===================================================================== - SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - DOUBLE PRECISION SI1, SI2, SR1, SR2 - INTEGER LDH, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION H( LDH, * ), V( * ) -* .. -* -* ================================================================ -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0d0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION H21S, H31S, S -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Executable Statements .. - IF( N.EQ.2 ) THEN - S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) - IF( S.EQ.ZERO ) THEN - V( 1 ) = ZERO - V( 2 ) = ZERO - ELSE - H21S = H( 2, 1 ) / S - V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-SR1 )* - $ ( ( H( 1, 1 )-SR2 ) / S ) - SI1*( SI2 / S ) - V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) - END IF - ELSE - S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) + - $ ABS( H( 3, 1 ) ) - IF( S.EQ.ZERO ) THEN - V( 1 ) = ZERO - V( 2 ) = ZERO - V( 3 ) = ZERO - ELSE - H21S = H( 2, 1 ) / S - H31S = H( 3, 1 ) / S - V( 1 ) = ( H( 1, 1 )-SR1 )*( ( H( 1, 1 )-SR2 ) / S ) - - $ SI1*( SI2 / S ) + H( 1, 2 )*H21S + H( 1, 3 )*H31S - V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) + - $ H( 2, 3 )*H31S - V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-SR1-SR2 ) + - $ H21S*H( 3, 2 ) - END IF - END IF - END diff --git a/mtx/lapack_src/dlaqr2.f b/mtx/lapack_src/dlaqr2.f deleted file mode 100644 index b5de50273..000000000 --- a/mtx/lapack_src/dlaqr2.f +++ /dev/null @@ -1,684 +0,0 @@ -*> \brief \b DLAQR2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAQR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, -* IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, -* LDT, NV, WV, LDWV, WORK, LWORK ) -* -* .. Scalar Arguments .. -* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, -* $ LDZ, LWORK, N, ND, NH, NS, NV, NW -* LOGICAL WANTT, WANTZ -* .. -* .. Array Arguments .. -* DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), -* $ V( LDV, * ), WORK( * ), WV( LDWV, * ), -* $ Z( LDZ, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAQR2 is identical to DLAQR3 except that it avoids -*> recursion by calling DLAHQR instead of DLAQR4. -*> -*> Aggressive early deflation: -*> -*> This subroutine accepts as input an upper Hessenberg matrix -*> H and performs an orthogonal similarity transformation -*> designed to detect and deflate fully converged eigenvalues from -*> a trailing principal submatrix. On output H has been over- -*> written by a new Hessenberg matrix that is a perturbation of -*> an orthogonal similarity transformation of H. It is to be -*> hoped that the final version of H has many zero subdiagonal -*> entries. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] WANTT -*> \verbatim -*> WANTT is LOGICAL -*> If .TRUE., then the Hessenberg matrix H is fully updated -*> so that the quasi-triangular Schur factor may be -*> computed (in cooperation with the calling subroutine). -*> If .FALSE., then only enough of H is updated to preserve -*> the eigenvalues. -*> \endverbatim -*> -*> \param[in] WANTZ -*> \verbatim -*> WANTZ is LOGICAL -*> If .TRUE., then the orthogonal matrix Z is updated so -*> so that the orthogonal Schur factor may be computed -*> (in cooperation with the calling subroutine). -*> If .FALSE., then Z is not referenced. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix H and (if WANTZ is .TRUE.) the -*> order of the orthogonal matrix Z. -*> \endverbatim -*> -*> \param[in] KTOP -*> \verbatim -*> KTOP is INTEGER -*> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. -*> KBOT and KTOP together determine an isolated block -*> along the diagonal of the Hessenberg matrix. -*> \endverbatim -*> -*> \param[in] KBOT -*> \verbatim -*> KBOT is INTEGER -*> It is assumed without a check that either -*> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together -*> determine an isolated block along the diagonal of the -*> Hessenberg matrix. -*> \endverbatim -*> -*> \param[in] NW -*> \verbatim -*> NW is INTEGER -*> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). -*> \endverbatim -*> -*> \param[in,out] H -*> \verbatim -*> H is DOUBLE PRECISION array, dimension (LDH,N) -*> On input the initial N-by-N section of H stores the -*> Hessenberg matrix undergoing aggressive early deflation. -*> On output H has been transformed by an orthogonal -*> similarity transformation, perturbed, and the returned -*> to Hessenberg form that (it is to be hoped) has some -*> zero subdiagonal entries. -*> \endverbatim -*> -*> \param[in] LDH -*> \verbatim -*> LDH is integer -*> Leading dimension of H just as declared in the calling -*> subroutine. N .LE. LDH -*> \endverbatim -*> -*> \param[in] ILOZ -*> \verbatim -*> ILOZ is INTEGER -*> \endverbatim -*> -*> \param[in] IHIZ -*> \verbatim -*> IHIZ is INTEGER -*> Specify the rows of Z to which transformations must be -*> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. -*> \endverbatim -*> -*> \param[in,out] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (LDZ,N) -*> IF WANTZ is .TRUE., then on output, the orthogonal -*> similarity transformation mentioned above has been -*> accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. -*> If WANTZ is .FALSE., then Z is unreferenced. -*> \endverbatim -*> -*> \param[in] LDZ -*> \verbatim -*> LDZ is integer -*> The leading dimension of Z just as declared in the -*> calling subroutine. 1 .LE. LDZ. -*> \endverbatim -*> -*> \param[out] NS -*> \verbatim -*> NS is integer -*> The number of unconverged (ie approximate) eigenvalues -*> returned in SR and SI that may be used as shifts by the -*> calling subroutine. -*> \endverbatim -*> -*> \param[out] ND -*> \verbatim -*> ND is integer -*> The number of converged eigenvalues uncovered by this -*> subroutine. -*> \endverbatim -*> -*> \param[out] SR -*> \verbatim -*> SR is DOUBLE PRECISION array, dimension (KBOT) -*> \endverbatim -*> -*> \param[out] SI -*> \verbatim -*> SI is DOUBLE PRECISION array, dimension (KBOT) -*> On output, the real and imaginary parts of approximate -*> eigenvalues that may be used for shifts are stored in -*> SR(KBOT-ND-NS+1) through SR(KBOT-ND) and -*> SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. -*> The real and imaginary parts of converged eigenvalues -*> are stored in SR(KBOT-ND+1) through SR(KBOT) and -*> SI(KBOT-ND+1) through SI(KBOT), respectively. -*> \endverbatim -*> -*> \param[out] V -*> \verbatim -*> V is DOUBLE PRECISION array, dimension (LDV,NW) -*> An NW-by-NW work array. -*> \endverbatim -*> -*> \param[in] LDV -*> \verbatim -*> LDV is integer scalar -*> The leading dimension of V just as declared in the -*> calling subroutine. NW .LE. LDV -*> \endverbatim -*> -*> \param[in] NH -*> \verbatim -*> NH is integer scalar -*> The number of columns of T. NH.GE.NW. -*> \endverbatim -*> -*> \param[out] T -*> \verbatim -*> T is DOUBLE PRECISION array, dimension (LDT,NW) -*> \endverbatim -*> -*> \param[in] LDT -*> \verbatim -*> LDT is integer -*> The leading dimension of T just as declared in the -*> calling subroutine. NW .LE. LDT -*> \endverbatim -*> -*> \param[in] NV -*> \verbatim -*> NV is integer -*> The number of rows of work array WV available for -*> workspace. NV.GE.NW. -*> \endverbatim -*> -*> \param[out] WV -*> \verbatim -*> WV is DOUBLE PRECISION array, dimension (LDWV,NW) -*> \endverbatim -*> -*> \param[in] LDWV -*> \verbatim -*> LDWV is integer -*> The leading dimension of W just as declared in the -*> calling subroutine. NW .LE. LDV -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (LWORK) -*> On exit, WORK(1) is set to an estimate of the optimal value -*> of LWORK for the given values of N, NW, KTOP and KBOT. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is integer -*> The dimension of the work array WORK. LWORK = 2*NW -*> suffices, but greater efficiency may result from larger -*> values of LWORK. -*> -*> If LWORK = -1, then a workspace query is assumed; DLAQR2 -*> only estimates the optimal workspace size for the given -*> values of N, NW, KTOP and KBOT. The estimate is returned -*> in WORK(1). No error message related to LWORK is issued -*> by XERBLA. Neither H nor Z are accessed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Contributors: -* ================== -*> -*> Karen Braman and Ralph Byers, Department of Mathematics, -*> University of Kansas, USA -*> -* ===================================================================== - SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, - $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, - $ LDT, NV, WV, LDWV, WORK, LWORK ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, - $ LDZ, LWORK, N, ND, NH, NS, NV, NW - LOGICAL WANTT, WANTZ -* .. -* .. Array Arguments .. - DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), - $ V( LDV, * ), WORK( * ), WV( LDWV, * ), - $ Z( LDZ, * ) -* .. -* -* ================================================================ -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, - $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP - INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, - $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, - $ LWKOPT - LOGICAL BULGE, SORTED -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR, - $ DLANV2, DLARF, DLARFG, DLASET, DORMHR, DTREXC -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* ==== Estimate optimal workspace. ==== -* - JW = MIN( NW, KBOT-KTOP+1 ) - IF( JW.LE.2 ) THEN - LWKOPT = 1 - ELSE -* -* ==== Workspace query call to DGEHRD ==== -* - CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) - LWK1 = INT( WORK( 1 ) ) -* -* ==== Workspace query call to DORMHR ==== -* - CALL DORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, - $ WORK, -1, INFO ) - LWK2 = INT( WORK( 1 ) ) -* -* ==== Optimal workspace ==== -* - LWKOPT = JW + MAX( LWK1, LWK2 ) - END IF -* -* ==== Quick return in case of workspace query. ==== -* - IF( LWORK.EQ.-1 ) THEN - WORK( 1 ) = DBLE( LWKOPT ) - RETURN - END IF -* -* ==== Nothing to do ... -* ... for an empty active block ... ==== - NS = 0 - ND = 0 - WORK( 1 ) = ONE - IF( KTOP.GT.KBOT ) - $ RETURN -* ... nor for an empty deflation window. ==== - IF( NW.LT.1 ) - $ RETURN -* -* ==== Machine constants ==== -* - SAFMIN = DLAMCH( 'SAFE MINIMUM' ) - SAFMAX = ONE / SAFMIN - CALL DLABAD( SAFMIN, SAFMAX ) - ULP = DLAMCH( 'PRECISION' ) - SMLNUM = SAFMIN*( DBLE( N ) / ULP ) -* -* ==== Setup deflation window ==== -* - JW = MIN( NW, KBOT-KTOP+1 ) - KWTOP = KBOT - JW + 1 - IF( KWTOP.EQ.KTOP ) THEN - S = ZERO - ELSE - S = H( KWTOP, KWTOP-1 ) - END IF -* - IF( KBOT.EQ.KWTOP ) THEN -* -* ==== 1-by-1 deflation window: not much to do ==== -* - SR( KWTOP ) = H( KWTOP, KWTOP ) - SI( KWTOP ) = ZERO - NS = 1 - ND = 0 - IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) ) - $ THEN - NS = 0 - ND = 1 - IF( KWTOP.GT.KTOP ) - $ H( KWTOP, KWTOP-1 ) = ZERO - END IF - WORK( 1 ) = ONE - RETURN - END IF -* -* ==== Convert to spike-triangular form. (In case of a -* . rare QR failure, this routine continues to do -* . aggressive early deflation using that part of -* . the deflation window that converged using INFQR -* . here and there to keep track.) ==== -* - CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) - CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) -* - CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) - CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), - $ SI( KWTOP ), 1, JW, V, LDV, INFQR ) -* -* ==== DTREXC needs a clean margin near the diagonal ==== -* - DO 10 J = 1, JW - 3 - T( J+2, J ) = ZERO - T( J+3, J ) = ZERO - 10 CONTINUE - IF( JW.GT.2 ) - $ T( JW, JW-2 ) = ZERO -* -* ==== Deflation detection loop ==== -* - NS = JW - ILST = INFQR + 1 - 20 CONTINUE - IF( ILST.LE.NS ) THEN - IF( NS.EQ.1 ) THEN - BULGE = .FALSE. - ELSE - BULGE = T( NS, NS-1 ).NE.ZERO - END IF -* -* ==== Small spike tip test for deflation ==== -* - IF( .NOT.BULGE ) THEN -* -* ==== Real eigenvalue ==== -* - FOO = ABS( T( NS, NS ) ) - IF( FOO.EQ.ZERO ) - $ FOO = ABS( S ) - IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN -* -* ==== Deflatable ==== -* - NS = NS - 1 - ELSE -* -* ==== Undeflatable. Move it up out of the way. -* . (DTREXC can not fail in this case.) ==== -* - IFST = NS - CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, - $ INFO ) - ILST = ILST + 1 - END IF - ELSE -* -* ==== Complex conjugate pair ==== -* - FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )* - $ SQRT( ABS( T( NS-1, NS ) ) ) - IF( FOO.EQ.ZERO ) - $ FOO = ABS( S ) - IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE. - $ MAX( SMLNUM, ULP*FOO ) ) THEN -* -* ==== Deflatable ==== -* - NS = NS - 2 - ELSE -* -* ==== Undeflatable. Move them up out of the way. -* . Fortunately, DTREXC does the right thing with -* . ILST in case of a rare exchange failure. ==== -* - IFST = NS - CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, - $ INFO ) - ILST = ILST + 2 - END IF - END IF -* -* ==== End deflation detection loop ==== -* - GO TO 20 - END IF -* -* ==== Return to Hessenberg form ==== -* - IF( NS.EQ.0 ) - $ S = ZERO -* - IF( NS.LT.JW ) THEN -* -* ==== sorting diagonal blocks of T improves accuracy for -* . graded matrices. Bubble sort deals well with -* . exchange failures. ==== -* - SORTED = .false. - I = NS + 1 - 30 CONTINUE - IF( SORTED ) - $ GO TO 50 - SORTED = .true. -* - KEND = I - 1 - I = INFQR + 1 - IF( I.EQ.NS ) THEN - K = I + 1 - ELSE IF( T( I+1, I ).EQ.ZERO ) THEN - K = I + 1 - ELSE - K = I + 2 - END IF - 40 CONTINUE - IF( K.LE.KEND ) THEN - IF( K.EQ.I+1 ) THEN - EVI = ABS( T( I, I ) ) - ELSE - EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )* - $ SQRT( ABS( T( I, I+1 ) ) ) - END IF -* - IF( K.EQ.KEND ) THEN - EVK = ABS( T( K, K ) ) - ELSE IF( T( K+1, K ).EQ.ZERO ) THEN - EVK = ABS( T( K, K ) ) - ELSE - EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )* - $ SQRT( ABS( T( K, K+1 ) ) ) - END IF -* - IF( EVI.GE.EVK ) THEN - I = K - ELSE - SORTED = .false. - IFST = I - ILST = K - CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, - $ INFO ) - IF( INFO.EQ.0 ) THEN - I = ILST - ELSE - I = K - END IF - END IF - IF( I.EQ.KEND ) THEN - K = I + 1 - ELSE IF( T( I+1, I ).EQ.ZERO ) THEN - K = I + 1 - ELSE - K = I + 2 - END IF - GO TO 40 - END IF - GO TO 30 - 50 CONTINUE - END IF -* -* ==== Restore shift/eigenvalue array from T ==== -* - I = JW - 60 CONTINUE - IF( I.GE.INFQR+1 ) THEN - IF( I.EQ.INFQR+1 ) THEN - SR( KWTOP+I-1 ) = T( I, I ) - SI( KWTOP+I-1 ) = ZERO - I = I - 1 - ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN - SR( KWTOP+I-1 ) = T( I, I ) - SI( KWTOP+I-1 ) = ZERO - I = I - 1 - ELSE - AA = T( I-1, I-1 ) - CC = T( I, I-1 ) - BB = T( I-1, I ) - DD = T( I, I ) - CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ), - $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ), - $ SI( KWTOP+I-1 ), CS, SN ) - I = I - 2 - END IF - GO TO 60 - END IF -* - IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN - IF( NS.GT.1 .AND. S.NE.ZERO ) THEN -* -* ==== Reflect spike back into lower triangle ==== -* - CALL DCOPY( NS, V, LDV, WORK, 1 ) - BETA = WORK( 1 ) - CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU ) - WORK( 1 ) = ONE -* - CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) -* - CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT, - $ WORK( JW+1 ) ) - CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, - $ WORK( JW+1 ) ) - CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, - $ WORK( JW+1 ) ) -* - CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), - $ LWORK-JW, INFO ) - END IF -* -* ==== Copy updated reduced window into place ==== -* - IF( KWTOP.GT.1 ) - $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 ) - CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) - CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), - $ LDH+1 ) -* -* ==== Accumulate orthogonal matrix in order update -* . H and Z, if requested. ==== -* - IF( NS.GT.1 .AND. S.NE.ZERO ) - $ CALL DORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, - $ WORK( JW+1 ), LWORK-JW, INFO ) -* -* ==== Update vertical slab in H ==== -* - IF( WANTT ) THEN - LTOP = 1 - ELSE - LTOP = KTOP - END IF - DO 70 KROW = LTOP, KWTOP - 1, NV - KLN = MIN( NV, KWTOP-KROW ) - CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), - $ LDH, V, LDV, ZERO, WV, LDWV ) - CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) - 70 CONTINUE -* -* ==== Update horizontal slab in H ==== -* - IF( WANTT ) THEN - DO 80 KCOL = KBOT + 1, N, NH - KLN = MIN( NH, N-KCOL+1 ) - CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, - $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) - CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), - $ LDH ) - 80 CONTINUE - END IF -* -* ==== Update vertical slab in Z ==== -* - IF( WANTZ ) THEN - DO 90 KROW = ILOZ, IHIZ, NV - KLN = MIN( NV, IHIZ-KROW+1 ) - CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), - $ LDZ, V, LDV, ZERO, WV, LDWV ) - CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), - $ LDZ ) - 90 CONTINUE - END IF - END IF -* -* ==== Return the number of deflations ... ==== -* - ND = JW - NS -* -* ==== ... and the number of shifts. (Subtracting -* . INFQR from the spike length takes care -* . of the case of a rare QR failure while -* . calculating eigenvalues of the deflation -* . window.) ==== -* - NS = NS - INFQR -* -* ==== Return optimal workspace. ==== -* - WORK( 1 ) = DBLE( LWKOPT ) -* -* ==== End of DLAQR2 ==== -* - END diff --git a/mtx/lapack_src/dlaqr3.f b/mtx/lapack_src/dlaqr3.f deleted file mode 100644 index 97890d16e..000000000 --- a/mtx/lapack_src/dlaqr3.f +++ /dev/null @@ -1,695 +0,0 @@ -*> \brief \b DLAQR3 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAQR3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, -* IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, -* LDT, NV, WV, LDWV, WORK, LWORK ) -* -* .. Scalar Arguments .. -* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, -* $ LDZ, LWORK, N, ND, NH, NS, NV, NW -* LOGICAL WANTT, WANTZ -* .. -* .. Array Arguments .. -* DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), -* $ V( LDV, * ), WORK( * ), WV( LDWV, * ), -* $ Z( LDZ, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Aggressive early deflation: -*> -*> DLAQR3 accepts as input an upper Hessenberg matrix -*> H and performs an orthogonal similarity transformation -*> designed to detect and deflate fully converged eigenvalues from -*> a trailing principal submatrix. On output H has been over- -*> written by a new Hessenberg matrix that is a perturbation of -*> an orthogonal similarity transformation of H. It is to be -*> hoped that the final version of H has many zero subdiagonal -*> entries. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] WANTT -*> \verbatim -*> WANTT is LOGICAL -*> If .TRUE., then the Hessenberg matrix H is fully updated -*> so that the quasi-triangular Schur factor may be -*> computed (in cooperation with the calling subroutine). -*> If .FALSE., then only enough of H is updated to preserve -*> the eigenvalues. -*> \endverbatim -*> -*> \param[in] WANTZ -*> \verbatim -*> WANTZ is LOGICAL -*> If .TRUE., then the orthogonal matrix Z is updated so -*> so that the orthogonal Schur factor may be computed -*> (in cooperation with the calling subroutine). -*> If .FALSE., then Z is not referenced. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix H and (if WANTZ is .TRUE.) the -*> order of the orthogonal matrix Z. -*> \endverbatim -*> -*> \param[in] KTOP -*> \verbatim -*> KTOP is INTEGER -*> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. -*> KBOT and KTOP together determine an isolated block -*> along the diagonal of the Hessenberg matrix. -*> \endverbatim -*> -*> \param[in] KBOT -*> \verbatim -*> KBOT is INTEGER -*> It is assumed without a check that either -*> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together -*> determine an isolated block along the diagonal of the -*> Hessenberg matrix. -*> \endverbatim -*> -*> \param[in] NW -*> \verbatim -*> NW is INTEGER -*> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). -*> \endverbatim -*> -*> \param[in,out] H -*> \verbatim -*> H is DOUBLE PRECISION array, dimension (LDH,N) -*> On input the initial N-by-N section of H stores the -*> Hessenberg matrix undergoing aggressive early deflation. -*> On output H has been transformed by an orthogonal -*> similarity transformation, perturbed, and the returned -*> to Hessenberg form that (it is to be hoped) has some -*> zero subdiagonal entries. -*> \endverbatim -*> -*> \param[in] LDH -*> \verbatim -*> LDH is integer -*> Leading dimension of H just as declared in the calling -*> subroutine. N .LE. LDH -*> \endverbatim -*> -*> \param[in] ILOZ -*> \verbatim -*> ILOZ is INTEGER -*> \endverbatim -*> -*> \param[in] IHIZ -*> \verbatim -*> IHIZ is INTEGER -*> Specify the rows of Z to which transformations must be -*> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. -*> \endverbatim -*> -*> \param[in,out] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (LDZ,N) -*> IF WANTZ is .TRUE., then on output, the orthogonal -*> similarity transformation mentioned above has been -*> accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. -*> If WANTZ is .FALSE., then Z is unreferenced. -*> \endverbatim -*> -*> \param[in] LDZ -*> \verbatim -*> LDZ is integer -*> The leading dimension of Z just as declared in the -*> calling subroutine. 1 .LE. LDZ. -*> \endverbatim -*> -*> \param[out] NS -*> \verbatim -*> NS is integer -*> The number of unconverged (ie approximate) eigenvalues -*> returned in SR and SI that may be used as shifts by the -*> calling subroutine. -*> \endverbatim -*> -*> \param[out] ND -*> \verbatim -*> ND is integer -*> The number of converged eigenvalues uncovered by this -*> subroutine. -*> \endverbatim -*> -*> \param[out] SR -*> \verbatim -*> SR is DOUBLE PRECISION array, dimension (KBOT) -*> \endverbatim -*> -*> \param[out] SI -*> \verbatim -*> SI is DOUBLE PRECISION array, dimension (KBOT) -*> On output, the real and imaginary parts of approximate -*> eigenvalues that may be used for shifts are stored in -*> SR(KBOT-ND-NS+1) through SR(KBOT-ND) and -*> SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. -*> The real and imaginary parts of converged eigenvalues -*> are stored in SR(KBOT-ND+1) through SR(KBOT) and -*> SI(KBOT-ND+1) through SI(KBOT), respectively. -*> \endverbatim -*> -*> \param[out] V -*> \verbatim -*> V is DOUBLE PRECISION array, dimension (LDV,NW) -*> An NW-by-NW work array. -*> \endverbatim -*> -*> \param[in] LDV -*> \verbatim -*> LDV is integer scalar -*> The leading dimension of V just as declared in the -*> calling subroutine. NW .LE. LDV -*> \endverbatim -*> -*> \param[in] NH -*> \verbatim -*> NH is integer scalar -*> The number of columns of T. NH.GE.NW. -*> \endverbatim -*> -*> \param[out] T -*> \verbatim -*> T is DOUBLE PRECISION array, dimension (LDT,NW) -*> \endverbatim -*> -*> \param[in] LDT -*> \verbatim -*> LDT is integer -*> The leading dimension of T just as declared in the -*> calling subroutine. NW .LE. LDT -*> \endverbatim -*> -*> \param[in] NV -*> \verbatim -*> NV is integer -*> The number of rows of work array WV available for -*> workspace. NV.GE.NW. -*> \endverbatim -*> -*> \param[out] WV -*> \verbatim -*> WV is DOUBLE PRECISION array, dimension (LDWV,NW) -*> \endverbatim -*> -*> \param[in] LDWV -*> \verbatim -*> LDWV is integer -*> The leading dimension of W just as declared in the -*> calling subroutine. NW .LE. LDV -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (LWORK) -*> On exit, WORK(1) is set to an estimate of the optimal value -*> of LWORK for the given values of N, NW, KTOP and KBOT. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is integer -*> The dimension of the work array WORK. LWORK = 2*NW -*> suffices, but greater efficiency may result from larger -*> values of LWORK. -*> -*> If LWORK = -1, then a workspace query is assumed; DLAQR3 -*> only estimates the optimal workspace size for the given -*> values of N, NW, KTOP and KBOT. The estimate is returned -*> in WORK(1). No error message related to LWORK is issued -*> by XERBLA. Neither H nor Z are accessed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Contributors: -* ================== -*> -*> Karen Braman and Ralph Byers, Department of Mathematics, -*> University of Kansas, USA -*> -* ===================================================================== - SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, - $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, - $ LDT, NV, WV, LDWV, WORK, LWORK ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, - $ LDZ, LWORK, N, ND, NH, NS, NV, NW - LOGICAL WANTT, WANTZ -* .. -* .. Array Arguments .. - DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), - $ V( LDV, * ), WORK( * ), WV( LDWV, * ), - $ Z( LDZ, * ) -* .. -* -* ================================================================ -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, - $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP - INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, - $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, - $ LWKOPT, NMIN - LOGICAL BULGE, SORTED -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - INTEGER ILAENV - EXTERNAL DLAMCH, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR, - $ DLANV2, DLAQR4, DLARF, DLARFG, DLASET, DORMHR, - $ DTREXC -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* ==== Estimate optimal workspace. ==== -* - JW = MIN( NW, KBOT-KTOP+1 ) - IF( JW.LE.2 ) THEN - LWKOPT = 1 - ELSE -* -* ==== Workspace query call to DGEHRD ==== -* - CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) - LWK1 = INT( WORK( 1 ) ) -* -* ==== Workspace query call to DORMHR ==== -* - CALL DORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, - $ WORK, -1, INFO ) - LWK2 = INT( WORK( 1 ) ) -* -* ==== Workspace query call to DLAQR4 ==== -* - CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR, SI, 1, JW, - $ V, LDV, WORK, -1, INFQR ) - LWK3 = INT( WORK( 1 ) ) -* -* ==== Optimal workspace ==== -* - LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) - END IF -* -* ==== Quick return in case of workspace query. ==== -* - IF( LWORK.EQ.-1 ) THEN - WORK( 1 ) = DBLE( LWKOPT ) - RETURN - END IF -* -* ==== Nothing to do ... -* ... for an empty active block ... ==== - NS = 0 - ND = 0 - WORK( 1 ) = ONE - IF( KTOP.GT.KBOT ) - $ RETURN -* ... nor for an empty deflation window. ==== - IF( NW.LT.1 ) - $ RETURN -* -* ==== Machine constants ==== -* - SAFMIN = DLAMCH( 'SAFE MINIMUM' ) - SAFMAX = ONE / SAFMIN - CALL DLABAD( SAFMIN, SAFMAX ) - ULP = DLAMCH( 'PRECISION' ) - SMLNUM = SAFMIN*( DBLE( N ) / ULP ) -* -* ==== Setup deflation window ==== -* - JW = MIN( NW, KBOT-KTOP+1 ) - KWTOP = KBOT - JW + 1 - IF( KWTOP.EQ.KTOP ) THEN - S = ZERO - ELSE - S = H( KWTOP, KWTOP-1 ) - END IF -* - IF( KBOT.EQ.KWTOP ) THEN -* -* ==== 1-by-1 deflation window: not much to do ==== -* - SR( KWTOP ) = H( KWTOP, KWTOP ) - SI( KWTOP ) = ZERO - NS = 1 - ND = 0 - IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) ) - $ THEN - NS = 0 - ND = 1 - IF( KWTOP.GT.KTOP ) - $ H( KWTOP, KWTOP-1 ) = ZERO - END IF - WORK( 1 ) = ONE - RETURN - END IF -* -* ==== Convert to spike-triangular form. (In case of a -* . rare QR failure, this routine continues to do -* . aggressive early deflation using that part of -* . the deflation window that converged using INFQR -* . here and there to keep track.) ==== -* - CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) - CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) -* - CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) - NMIN = ILAENV( 12, 'DLAQR3', 'SV', JW, 1, JW, LWORK ) - IF( JW.GT.NMIN ) THEN - CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), - $ SI( KWTOP ), 1, JW, V, LDV, WORK, LWORK, INFQR ) - ELSE - CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), - $ SI( KWTOP ), 1, JW, V, LDV, INFQR ) - END IF -* -* ==== DTREXC needs a clean margin near the diagonal ==== -* - DO 10 J = 1, JW - 3 - T( J+2, J ) = ZERO - T( J+3, J ) = ZERO - 10 CONTINUE - IF( JW.GT.2 ) - $ T( JW, JW-2 ) = ZERO -* -* ==== Deflation detection loop ==== -* - NS = JW - ILST = INFQR + 1 - 20 CONTINUE - IF( ILST.LE.NS ) THEN - IF( NS.EQ.1 ) THEN - BULGE = .FALSE. - ELSE - BULGE = T( NS, NS-1 ).NE.ZERO - END IF -* -* ==== Small spike tip test for deflation ==== -* - IF( .NOT. BULGE ) THEN -* -* ==== Real eigenvalue ==== -* - FOO = ABS( T( NS, NS ) ) - IF( FOO.EQ.ZERO ) - $ FOO = ABS( S ) - IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN -* -* ==== Deflatable ==== -* - NS = NS - 1 - ELSE -* -* ==== Undeflatable. Move it up out of the way. -* . (DTREXC can not fail in this case.) ==== -* - IFST = NS - CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, - $ INFO ) - ILST = ILST + 1 - END IF - ELSE -* -* ==== Complex conjugate pair ==== -* - FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )* - $ SQRT( ABS( T( NS-1, NS ) ) ) - IF( FOO.EQ.ZERO ) - $ FOO = ABS( S ) - IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE. - $ MAX( SMLNUM, ULP*FOO ) ) THEN -* -* ==== Deflatable ==== -* - NS = NS - 2 - ELSE -* -* ==== Undeflatable. Move them up out of the way. -* . Fortunately, DTREXC does the right thing with -* . ILST in case of a rare exchange failure. ==== -* - IFST = NS - CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, - $ INFO ) - ILST = ILST + 2 - END IF - END IF -* -* ==== End deflation detection loop ==== -* - GO TO 20 - END IF -* -* ==== Return to Hessenberg form ==== -* - IF( NS.EQ.0 ) - $ S = ZERO -* - IF( NS.LT.JW ) THEN -* -* ==== sorting diagonal blocks of T improves accuracy for -* . graded matrices. Bubble sort deals well with -* . exchange failures. ==== -* - SORTED = .false. - I = NS + 1 - 30 CONTINUE - IF( SORTED ) - $ GO TO 50 - SORTED = .true. -* - KEND = I - 1 - I = INFQR + 1 - IF( I.EQ.NS ) THEN - K = I + 1 - ELSE IF( T( I+1, I ).EQ.ZERO ) THEN - K = I + 1 - ELSE - K = I + 2 - END IF - 40 CONTINUE - IF( K.LE.KEND ) THEN - IF( K.EQ.I+1 ) THEN - EVI = ABS( T( I, I ) ) - ELSE - EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )* - $ SQRT( ABS( T( I, I+1 ) ) ) - END IF -* - IF( K.EQ.KEND ) THEN - EVK = ABS( T( K, K ) ) - ELSE IF( T( K+1, K ).EQ.ZERO ) THEN - EVK = ABS( T( K, K ) ) - ELSE - EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )* - $ SQRT( ABS( T( K, K+1 ) ) ) - END IF -* - IF( EVI.GE.EVK ) THEN - I = K - ELSE - SORTED = .false. - IFST = I - ILST = K - CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, - $ INFO ) - IF( INFO.EQ.0 ) THEN - I = ILST - ELSE - I = K - END IF - END IF - IF( I.EQ.KEND ) THEN - K = I + 1 - ELSE IF( T( I+1, I ).EQ.ZERO ) THEN - K = I + 1 - ELSE - K = I + 2 - END IF - GO TO 40 - END IF - GO TO 30 - 50 CONTINUE - END IF -* -* ==== Restore shift/eigenvalue array from T ==== -* - I = JW - 60 CONTINUE - IF( I.GE.INFQR+1 ) THEN - IF( I.EQ.INFQR+1 ) THEN - SR( KWTOP+I-1 ) = T( I, I ) - SI( KWTOP+I-1 ) = ZERO - I = I - 1 - ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN - SR( KWTOP+I-1 ) = T( I, I ) - SI( KWTOP+I-1 ) = ZERO - I = I - 1 - ELSE - AA = T( I-1, I-1 ) - CC = T( I, I-1 ) - BB = T( I-1, I ) - DD = T( I, I ) - CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ), - $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ), - $ SI( KWTOP+I-1 ), CS, SN ) - I = I - 2 - END IF - GO TO 60 - END IF -* - IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN - IF( NS.GT.1 .AND. S.NE.ZERO ) THEN -* -* ==== Reflect spike back into lower triangle ==== -* - CALL DCOPY( NS, V, LDV, WORK, 1 ) - BETA = WORK( 1 ) - CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU ) - WORK( 1 ) = ONE -* - CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) -* - CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT, - $ WORK( JW+1 ) ) - CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, - $ WORK( JW+1 ) ) - CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, - $ WORK( JW+1 ) ) -* - CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), - $ LWORK-JW, INFO ) - END IF -* -* ==== Copy updated reduced window into place ==== -* - IF( KWTOP.GT.1 ) - $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 ) - CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) - CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), - $ LDH+1 ) -* -* ==== Accumulate orthogonal matrix in order update -* . H and Z, if requested. ==== -* - IF( NS.GT.1 .AND. S.NE.ZERO ) - $ CALL DORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, - $ WORK( JW+1 ), LWORK-JW, INFO ) -* -* ==== Update vertical slab in H ==== -* - IF( WANTT ) THEN - LTOP = 1 - ELSE - LTOP = KTOP - END IF - DO 70 KROW = LTOP, KWTOP - 1, NV - KLN = MIN( NV, KWTOP-KROW ) - CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), - $ LDH, V, LDV, ZERO, WV, LDWV ) - CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) - 70 CONTINUE -* -* ==== Update horizontal slab in H ==== -* - IF( WANTT ) THEN - DO 80 KCOL = KBOT + 1, N, NH - KLN = MIN( NH, N-KCOL+1 ) - CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, - $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) - CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), - $ LDH ) - 80 CONTINUE - END IF -* -* ==== Update vertical slab in Z ==== -* - IF( WANTZ ) THEN - DO 90 KROW = ILOZ, IHIZ, NV - KLN = MIN( NV, IHIZ-KROW+1 ) - CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), - $ LDZ, V, LDV, ZERO, WV, LDWV ) - CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), - $ LDZ ) - 90 CONTINUE - END IF - END IF -* -* ==== Return the number of deflations ... ==== -* - ND = JW - NS -* -* ==== ... and the number of shifts. (Subtracting -* . INFQR from the spike length takes care -* . of the case of a rare QR failure while -* . calculating eigenvalues of the deflation -* . window.) ==== -* - NS = NS - INFQR -* -* ==== Return optimal workspace. ==== -* - WORK( 1 ) = DBLE( LWKOPT ) -* -* ==== End of DLAQR3 ==== -* - END diff --git a/mtx/lapack_src/dlaqr4.f b/mtx/lapack_src/dlaqr4.f deleted file mode 100644 index a25c9586c..000000000 --- a/mtx/lapack_src/dlaqr4.f +++ /dev/null @@ -1,739 +0,0 @@ -*> \brief \b DLAQR4 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAQR4 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, -* ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N -* LOGICAL WANTT, WANTZ -* .. -* .. Array Arguments .. -* DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), -* $ Z( LDZ, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAQR4 implements one level of recursion for DLAQR0. -*> It is a complete implementation of the small bulge multi-shift -*> QR algorithm. It may be called by DLAQR0 and, for large enough -*> deflation window size, it may be called by DLAQR3. This -*> subroutine is identical to DLAQR0 except that it calls DLAQR2 -*> instead of DLAQR3. -*> -*> DLAQR4 computes the eigenvalues of a Hessenberg matrix H -*> and, optionally, the matrices T and Z from the Schur decomposition -*> H = Z T Z**T, where T is an upper quasi-triangular matrix (the -*> Schur form), and Z is the orthogonal matrix of Schur vectors. -*> -*> Optionally Z may be postmultiplied into an input orthogonal -*> matrix Q so that this routine can give the Schur factorization -*> of a matrix A which has been reduced to the Hessenberg form H -*> by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] WANTT -*> \verbatim -*> WANTT is LOGICAL -*> = .TRUE. : the full Schur form T is required; -*> = .FALSE.: only eigenvalues are required. -*> \endverbatim -*> -*> \param[in] WANTZ -*> \verbatim -*> WANTZ is LOGICAL -*> = .TRUE. : the matrix of Schur vectors Z is required; -*> = .FALSE.: Schur vectors are not required. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix H. N .GE. 0. -*> \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 and, if ILO.GT.1, -*> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a -*> previous call to DGEBAL, and then passed to DGEHRD when the -*> matrix output by DGEBAL is reduced to Hessenberg form. -*> Otherwise, ILO and IHI should be set to 1 and N, -*> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. -*> If N = 0, then ILO = 1 and IHI = 0. -*> \endverbatim -*> -*> \param[in,out] H -*> \verbatim -*> H is DOUBLE PRECISION array, dimension (LDH,N) -*> On entry, the upper Hessenberg matrix H. -*> On exit, if INFO = 0 and WANTT is .TRUE., then H contains -*> the upper quasi-triangular matrix T from the Schur -*> decomposition (the Schur form); 2-by-2 diagonal blocks -*> (corresponding to complex conjugate pairs of eigenvalues) -*> are returned in standard form, with H(i,i) = H(i+1,i+1) -*> and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is -*> .FALSE., then the contents of H are unspecified on exit. -*> (The output value of H when INFO.GT.0 is given under the -*> description of INFO below.) -*> -*> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and -*> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. -*> \endverbatim -*> -*> \param[in] LDH -*> \verbatim -*> LDH is INTEGER -*> The leading dimension of the array H. LDH .GE. max(1,N). -*> \endverbatim -*> -*> \param[out] WR -*> \verbatim -*> WR is DOUBLE PRECISION array, dimension (IHI) -*> \endverbatim -*> -*> \param[out] WI -*> \verbatim -*> WI is DOUBLE PRECISION array, dimension (IHI) -*> The real and imaginary parts, respectively, of the computed -*> eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) -*> and WI(ILO:IHI). If two eigenvalues are computed as a -*> complex conjugate pair, they are stored in consecutive -*> elements of WR and WI, say the i-th and (i+1)th, with -*> WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then -*> the eigenvalues are stored in the same order as on the -*> diagonal of the Schur form returned in H, with -*> WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal -*> block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and -*> WI(i+1) = -WI(i). -*> \endverbatim -*> -*> \param[in] ILOZ -*> \verbatim -*> ILOZ is INTEGER -*> \endverbatim -*> -*> \param[in] IHIZ -*> \verbatim -*> IHIZ is INTEGER -*> Specify the rows of Z to which transformations must be -*> applied if WANTZ is .TRUE.. -*> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. -*> \endverbatim -*> -*> \param[in,out] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (LDZ,IHI) -*> If WANTZ is .FALSE., then Z is not referenced. -*> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is -*> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the -*> orthogonal Schur factor of H(ILO:IHI,ILO:IHI). -*> (The output value of Z when INFO.GT.0 is given under -*> the description of INFO below.) -*> \endverbatim -*> -*> \param[in] LDZ -*> \verbatim -*> LDZ is INTEGER -*> The leading dimension of the array Z. if WANTZ is .TRUE. -*> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension LWORK -*> On exit, if LWORK = -1, WORK(1) returns an estimate of -*> the optimal value for LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. LWORK .GE. max(1,N) -*> is sufficient, but LWORK typically as large as 6*N may -*> be required for optimal performance. A workspace query -*> to determine the optimal workspace size is recommended. -*> -*> If LWORK = -1, then DLAQR4 does a workspace query. -*> In this case, DLAQR4 checks the input parameters and -*> estimates the optimal workspace size for the given -*> values of N, ILO and IHI. The estimate is returned -*> in WORK(1). No error message related to LWORK is -*> issued by XERBLA. Neither H nor Z are accessed. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> .GT. 0: if INFO = i, DLAQR4 failed to compute all of -*> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR -*> and WI contain those eigenvalues which have been -*> successfully computed. (Failures are rare.) -*> -*> If INFO .GT. 0 and WANT is .FALSE., then on exit, -*> the remaining unconverged eigenvalues are the eigen- -*> values of the upper Hessenberg matrix rows and -*> columns ILO through INFO of the final, output -*> value of H. -*> -*> If INFO .GT. 0 and WANTT is .TRUE., then on exit -*> -*> (*) (initial value of H)*U = U*(final value of H) -*> -*> where U is a orthogonal matrix. The final -*> value of H is upper Hessenberg and triangular in -*> rows and columns INFO+1 through IHI. -*> -*> If INFO .GT. 0 and WANTZ is .TRUE., then on exit -*> -*> (final value of Z(ILO:IHI,ILOZ:IHIZ) -*> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U -*> -*> where U is the orthogonal matrix in (*) (regard- -*> less of the value of WANTT.) -*> -*> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not -*> accessed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Contributors: -* ================== -*> -*> Karen Braman and Ralph Byers, Department of Mathematics, -*> University of Kansas, USA -* -*> \par References: -* ================ -*> -*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR -*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 -*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages -*> 929--947, 2002. -*> \n -*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR -*> Algorithm Part II: Aggressive Early Deflation, SIAM Journal -*> of Matrix Analysis, volume 23, pages 948--973, 2002. -*> -* ===================================================================== - SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, - $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N - LOGICAL WANTT, WANTZ -* .. -* .. Array Arguments .. - DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), - $ Z( LDZ, * ) -* .. -* -* ================================================================ -* .. Parameters .. -* -* ==== Matrices of order NTINY or smaller must be processed by -* . DLAHQR because of insufficient subdiagonal scratch space. -* . (This is a hard limit.) ==== - INTEGER NTINY - PARAMETER ( NTINY = 11 ) -* -* ==== Exceptional deflation windows: try to cure rare -* . slow convergence by varying the size of the -* . deflation window after KEXNW iterations. ==== - INTEGER KEXNW - PARAMETER ( KEXNW = 5 ) -* -* ==== Exceptional shifts: try to cure rare slow convergence -* . with ad-hoc exceptional shifts every KEXSH iterations. -* . ==== - INTEGER KEXSH - PARAMETER ( KEXSH = 6 ) -* -* ==== The constants WILK1 and WILK2 are used to form the -* . exceptional shifts. ==== - DOUBLE PRECISION WILK1, WILK2 - PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP - INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, - $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, - $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, - $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD - LOGICAL SORTED - CHARACTER JBCMPZ*2 -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Local Arrays .. - DOUBLE PRECISION ZDUM( 1, 1 ) -* .. -* .. External Subroutines .. - EXTERNAL DLACPY, DLAHQR, DLANV2, DLAQR2, DLAQR5 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD -* .. -* .. Executable Statements .. - INFO = 0 -* -* ==== Quick return for N = 0: nothing to do. ==== -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = ONE - RETURN - END IF -* - IF( N.LE.NTINY ) THEN -* -* ==== Tiny matrices must use DLAHQR. ==== -* - LWKOPT = 1 - IF( LWORK.NE.-1 ) - $ CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, - $ ILOZ, IHIZ, Z, LDZ, INFO ) - ELSE -* -* ==== Use small bulge multi-shift QR with aggressive early -* . deflation on larger-than-tiny matrices. ==== -* -* ==== Hope for the best. ==== -* - INFO = 0 -* -* ==== Set up job flags for ILAENV. ==== -* - IF( WANTT ) THEN - JBCMPZ( 1: 1 ) = 'S' - ELSE - JBCMPZ( 1: 1 ) = 'E' - END IF - IF( WANTZ ) THEN - JBCMPZ( 2: 2 ) = 'V' - ELSE - JBCMPZ( 2: 2 ) = 'N' - END IF -* -* ==== NWR = recommended deflation window size. At this -* . point, N .GT. NTINY = 11, so there is enough -* . subdiagonal workspace for NWR.GE.2 as required. -* . (In fact, there is enough subdiagonal space for -* . NWR.GE.3.) ==== -* - NWR = ILAENV( 13, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) - NWR = MAX( 2, NWR ) - NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) -* -* ==== NSR = recommended number of simultaneous shifts. -* . At this point N .GT. NTINY = 11, so there is at -* . enough subdiagonal workspace for NSR to be even -* . and greater than or equal to two as required. ==== -* - NSR = ILAENV( 15, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) - NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) - NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) -* -* ==== Estimate optimal workspace ==== -* -* ==== Workspace query call to DLAQR2 ==== -* - CALL DLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, - $ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH, - $ N, H, LDH, WORK, -1 ) -* -* ==== Optimal workspace = MAX(DLAQR5, DLAQR2) ==== -* - LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) -* -* ==== Quick return in case of workspace query. ==== -* - IF( LWORK.EQ.-1 ) THEN - WORK( 1 ) = DBLE( LWKOPT ) - RETURN - END IF -* -* ==== DLAHQR/DLAQR0 crossover point ==== -* - NMIN = ILAENV( 12, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) - NMIN = MAX( NTINY, NMIN ) -* -* ==== Nibble crossover point ==== -* - NIBBLE = ILAENV( 14, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) - NIBBLE = MAX( 0, NIBBLE ) -* -* ==== Accumulate reflections during ttswp? Use block -* . 2-by-2 structure during matrix-matrix multiply? ==== -* - KACC22 = ILAENV( 16, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) - KACC22 = MAX( 0, KACC22 ) - KACC22 = MIN( 2, KACC22 ) -* -* ==== NWMAX = the largest possible deflation window for -* . which there is sufficient workspace. ==== -* - NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) - NW = NWMAX -* -* ==== NSMAX = the Largest number of simultaneous shifts -* . for which there is sufficient workspace. ==== -* - NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) - NSMAX = NSMAX - MOD( NSMAX, 2 ) -* -* ==== NDFL: an iteration count restarted at deflation. ==== -* - NDFL = 1 -* -* ==== ITMAX = iteration limit ==== -* - ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) -* -* ==== Last row and column in the active block ==== -* - KBOT = IHI -* -* ==== Main Loop ==== -* - DO 80 IT = 1, ITMAX -* -* ==== Done when KBOT falls below ILO ==== -* - IF( KBOT.LT.ILO ) - $ GO TO 90 -* -* ==== Locate active block ==== -* - DO 10 K = KBOT, ILO + 1, -1 - IF( H( K, K-1 ).EQ.ZERO ) - $ GO TO 20 - 10 CONTINUE - K = ILO - 20 CONTINUE - KTOP = K -* -* ==== Select deflation window size: -* . Typical Case: -* . If possible and advisable, nibble the entire -* . active block. If not, use size MIN(NWR,NWMAX) -* . or MIN(NWR+1,NWMAX) depending upon which has -* . the smaller corresponding subdiagonal entry -* . (a heuristic). -* . -* . Exceptional Case: -* . If there have been no deflations in KEXNW or -* . more iterations, then vary the deflation window -* . size. At first, because, larger windows are, -* . in general, more powerful than smaller ones, -* . rapidly increase the window to the maximum possible. -* . Then, gradually reduce the window size. ==== -* - NH = KBOT - KTOP + 1 - NWUPBD = MIN( NH, NWMAX ) - IF( NDFL.LT.KEXNW ) THEN - NW = MIN( NWUPBD, NWR ) - ELSE - NW = MIN( NWUPBD, 2*NW ) - END IF - IF( NW.LT.NWMAX ) THEN - IF( NW.GE.NH-1 ) THEN - NW = NH - ELSE - KWTOP = KBOT - NW + 1 - IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. - $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 - END IF - END IF - IF( NDFL.LT.KEXNW ) THEN - NDEC = -1 - ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN - NDEC = NDEC + 1 - IF( NW-NDEC.LT.2 ) - $ NDEC = 0 - NW = NW - NDEC - END IF -* -* ==== Aggressive early deflation: -* . split workspace under the subdiagonal into -* . - an nw-by-nw work array V in the lower -* . left-hand-corner, -* . - an NW-by-at-least-NW-but-more-is-better -* . (NW-by-NHO) horizontal work array along -* . the bottom edge, -* . - an at-least-NW-but-more-is-better (NHV-by-NW) -* . vertical work array along the left-hand-edge. -* . ==== -* - KV = N - NW + 1 - KT = NW + 1 - NHO = ( N-NW-1 ) - KT + 1 - KWV = NW + 2 - NVE = ( N-NW ) - KWV + 1 -* -* ==== Aggressive early deflation ==== -* - CALL DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, - $ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH, - $ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, - $ WORK, LWORK ) -* -* ==== Adjust KBOT accounting for new deflations. ==== -* - KBOT = KBOT - LD -* -* ==== KS points to the shifts. ==== -* - KS = KBOT - LS + 1 -* -* ==== Skip an expensive QR sweep if there is a (partly -* . heuristic) reason to expect that many eigenvalues -* . will deflate without it. Here, the QR sweep is -* . skipped if many eigenvalues have just been deflated -* . or if the remaining active block is small. -* - IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- - $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN -* -* ==== NS = nominal number of simultaneous shifts. -* . This may be lowered (slightly) if DLAQR2 -* . did not provide that many shifts. ==== -* - NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) - NS = NS - MOD( NS, 2 ) -* -* ==== If there have been no deflations -* . in a multiple of KEXSH iterations, -* . then try exceptional shifts. -* . Otherwise use shifts provided by -* . DLAQR2 above or from the eigenvalues -* . of a trailing principal submatrix. ==== -* - IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN - KS = KBOT - NS + 1 - DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2 - SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) - AA = WILK1*SS + H( I, I ) - BB = SS - CC = WILK2*SS - DD = AA - CALL DLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ), - $ WR( I ), WI( I ), CS, SN ) - 30 CONTINUE - IF( KS.EQ.KTOP ) THEN - WR( KS+1 ) = H( KS+1, KS+1 ) - WI( KS+1 ) = ZERO - WR( KS ) = WR( KS+1 ) - WI( KS ) = WI( KS+1 ) - END IF - ELSE -* -* ==== Got NS/2 or fewer shifts? Use DLAHQR -* . on a trailing principal submatrix to -* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, -* . there is enough space below the subdiagonal -* . to fit an NS-by-NS scratch array.) ==== -* - IF( KBOT-KS+1.LE.NS / 2 ) THEN - KS = KBOT - NS + 1 - KT = N - NS + 1 - CALL DLACPY( 'A', NS, NS, H( KS, KS ), LDH, - $ H( KT, 1 ), LDH ) - CALL DLAHQR( .false., .false., NS, 1, NS, - $ H( KT, 1 ), LDH, WR( KS ), WI( KS ), - $ 1, 1, ZDUM, 1, INF ) - KS = KS + INF -* -* ==== In case of a rare QR failure use -* . eigenvalues of the trailing 2-by-2 -* . principal submatrix. ==== -* - IF( KS.GE.KBOT ) THEN - AA = H( KBOT-1, KBOT-1 ) - CC = H( KBOT, KBOT-1 ) - BB = H( KBOT-1, KBOT ) - DD = H( KBOT, KBOT ) - CALL DLANV2( AA, BB, CC, DD, WR( KBOT-1 ), - $ WI( KBOT-1 ), WR( KBOT ), - $ WI( KBOT ), CS, SN ) - KS = KBOT - 1 - END IF - END IF -* - IF( KBOT-KS+1.GT.NS ) THEN -* -* ==== Sort the shifts (Helps a little) -* . Bubble sort keeps complex conjugate -* . pairs together. ==== -* - SORTED = .false. - DO 50 K = KBOT, KS + 1, -1 - IF( SORTED ) - $ GO TO 60 - SORTED = .true. - DO 40 I = KS, K - 1 - IF( ABS( WR( I ) )+ABS( WI( I ) ).LT. - $ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN - SORTED = .false. -* - SWAP = WR( I ) - WR( I ) = WR( I+1 ) - WR( I+1 ) = SWAP -* - SWAP = WI( I ) - WI( I ) = WI( I+1 ) - WI( I+1 ) = SWAP - END IF - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - END IF -* -* ==== Shuffle shifts into pairs of real shifts -* . and pairs of complex conjugate shifts -* . assuming complex conjugate shifts are -* . already adjacent to one another. (Yes, -* . they are.) ==== -* - DO 70 I = KBOT, KS + 2, -2 - IF( WI( I ).NE.-WI( I-1 ) ) THEN -* - SWAP = WR( I ) - WR( I ) = WR( I-1 ) - WR( I-1 ) = WR( I-2 ) - WR( I-2 ) = SWAP -* - SWAP = WI( I ) - WI( I ) = WI( I-1 ) - WI( I-1 ) = WI( I-2 ) - WI( I-2 ) = SWAP - END IF - 70 CONTINUE - END IF -* -* ==== If there are only two shifts and both are -* . real, then use only one. ==== -* - IF( KBOT-KS+1.EQ.2 ) THEN - IF( WI( KBOT ).EQ.ZERO ) THEN - IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT. - $ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN - WR( KBOT-1 ) = WR( KBOT ) - ELSE - WR( KBOT ) = WR( KBOT-1 ) - END IF - END IF - END IF -* -* ==== Use up to NS of the the smallest magnatiude -* . shifts. If there aren't NS shifts available, -* . then use them all, possibly dropping one to -* . make the number of shifts even. ==== -* - NS = MIN( NS, KBOT-KS+1 ) - NS = NS - MOD( NS, 2 ) - KS = KBOT - NS + 1 -* -* ==== Small-bulge multi-shift QR sweep: -* . split workspace under the subdiagonal into -* . - a KDU-by-KDU work array U in the lower -* . left-hand-corner, -* . - a KDU-by-at-least-KDU-but-more-is-better -* . (KDU-by-NHo) horizontal work array WH along -* . the bottom edge, -* . - and an at-least-KDU-but-more-is-better-by-KDU -* . (NVE-by-KDU) vertical work WV arrow along -* . the left-hand-edge. ==== -* - KDU = 3*NS - 3 - KU = N - KDU + 1 - KWH = KDU + 1 - NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 - KWV = KDU + 4 - NVE = N - KDU - KWV + 1 -* -* ==== Small-bulge multi-shift QR sweep ==== -* - CALL DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, - $ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z, - $ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE, - $ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH ) - END IF -* -* ==== Note progress (or the lack of it). ==== -* - IF( LD.GT.0 ) THEN - NDFL = 1 - ELSE - NDFL = NDFL + 1 - END IF -* -* ==== End of main loop ==== - 80 CONTINUE -* -* ==== Iteration limit exceeded. Set INFO to show where -* . the problem occurred and exit. ==== -* - INFO = KBOT - 90 CONTINUE - END IF -* -* ==== Return the optimal value of LWORK. ==== -* - WORK( 1 ) = DBLE( LWKOPT ) -* -* ==== End of DLAQR4 ==== -* - END diff --git a/mtx/lapack_src/dlaqr5.f b/mtx/lapack_src/dlaqr5.f deleted file mode 100644 index 9fa954147..000000000 --- a/mtx/lapack_src/dlaqr5.f +++ /dev/null @@ -1,921 +0,0 @@ -*> \brief \b DLAQR5 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAQR5 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, -* SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, -* LDU, NV, WV, LDWV, NH, WH, LDWH ) -* -* .. Scalar Arguments .. -* INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, -* $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV -* LOGICAL WANTT, WANTZ -* .. -* .. Array Arguments .. -* DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), U( LDU, * ), -* $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ), -* $ Z( LDZ, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAQR5, called by DLAQR0, performs a -*> single small-bulge multi-shift QR sweep. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] WANTT -*> \verbatim -*> WANTT is logical scalar -*> WANTT = .true. if the quasi-triangular Schur factor -*> is being computed. WANTT is set to .false. otherwise. -*> \endverbatim -*> -*> \param[in] WANTZ -*> \verbatim -*> WANTZ is logical scalar -*> WANTZ = .true. if the orthogonal Schur factor is being -*> computed. WANTZ is set to .false. otherwise. -*> \endverbatim -*> -*> \param[in] KACC22 -*> \verbatim -*> KACC22 is integer with value 0, 1, or 2. -*> Specifies the computation mode of far-from-diagonal -*> orthogonal updates. -*> = 0: DLAQR5 does not accumulate reflections and does not -*> use matrix-matrix multiply to update far-from-diagonal -*> matrix entries. -*> = 1: DLAQR5 accumulates reflections and uses matrix-matrix -*> multiply to update the far-from-diagonal matrix entries. -*> = 2: DLAQR5 accumulates reflections, uses matrix-matrix -*> multiply to update the far-from-diagonal matrix entries, -*> and takes advantage of 2-by-2 block structure during -*> matrix multiplies. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is integer scalar -*> N is the order of the Hessenberg matrix H upon which this -*> subroutine operates. -*> \endverbatim -*> -*> \param[in] KTOP -*> \verbatim -*> KTOP is integer scalar -*> \endverbatim -*> -*> \param[in] KBOT -*> \verbatim -*> KBOT is integer scalar -*> These are the first and last rows and columns of an -*> isolated diagonal block upon which the QR sweep is to be -*> applied. It is assumed without a check that -*> either KTOP = 1 or H(KTOP,KTOP-1) = 0 -*> and -*> either KBOT = N or H(KBOT+1,KBOT) = 0. -*> \endverbatim -*> -*> \param[in] NSHFTS -*> \verbatim -*> NSHFTS is integer scalar -*> NSHFTS gives the number of simultaneous shifts. NSHFTS -*> must be positive and even. -*> \endverbatim -*> -*> \param[in,out] SR -*> \verbatim -*> SR is DOUBLE PRECISION array of size (NSHFTS) -*> \endverbatim -*> -*> \param[in,out] SI -*> \verbatim -*> SI is DOUBLE PRECISION array of size (NSHFTS) -*> SR contains the real parts and SI contains the imaginary -*> parts of the NSHFTS shifts of origin that define the -*> multi-shift QR sweep. On output SR and SI may be -*> reordered. -*> \endverbatim -*> -*> \param[in,out] H -*> \verbatim -*> H is DOUBLE PRECISION array of size (LDH,N) -*> On input H contains a Hessenberg matrix. On output a -*> multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied -*> to the isolated diagonal block in rows and columns KTOP -*> through KBOT. -*> \endverbatim -*> -*> \param[in] LDH -*> \verbatim -*> LDH is integer scalar -*> LDH is the leading dimension of H just as declared in the -*> calling procedure. LDH.GE.MAX(1,N). -*> \endverbatim -*> -*> \param[in] ILOZ -*> \verbatim -*> ILOZ is INTEGER -*> \endverbatim -*> -*> \param[in] IHIZ -*> \verbatim -*> IHIZ is INTEGER -*> Specify the rows of Z to which transformations must be -*> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N -*> \endverbatim -*> -*> \param[in,out] Z -*> \verbatim -*> Z is DOUBLE PRECISION array of size (LDZ,IHI) -*> If WANTZ = .TRUE., then the QR Sweep orthogonal -*> similarity transformation is accumulated into -*> Z(ILOZ:IHIZ,ILO:IHI) from the right. -*> If WANTZ = .FALSE., then Z is unreferenced. -*> \endverbatim -*> -*> \param[in] LDZ -*> \verbatim -*> LDZ is integer scalar -*> LDA is the leading dimension of Z just as declared in -*> the calling procedure. LDZ.GE.N. -*> \endverbatim -*> -*> \param[out] V -*> \verbatim -*> V is DOUBLE PRECISION array of size (LDV,NSHFTS/2) -*> \endverbatim -*> -*> \param[in] LDV -*> \verbatim -*> LDV is integer scalar -*> LDV is the leading dimension of V as declared in the -*> calling procedure. LDV.GE.3. -*> \endverbatim -*> -*> \param[out] U -*> \verbatim -*> U is DOUBLE PRECISION array of size -*> (LDU,3*NSHFTS-3) -*> \endverbatim -*> -*> \param[in] LDU -*> \verbatim -*> LDU is integer scalar -*> LDU is the leading dimension of U just as declared in the -*> in the calling subroutine. LDU.GE.3*NSHFTS-3. -*> \endverbatim -*> -*> \param[in] NH -*> \verbatim -*> NH is integer scalar -*> NH is the number of columns in array WH available for -*> workspace. NH.GE.1. -*> \endverbatim -*> -*> \param[out] WH -*> \verbatim -*> WH is DOUBLE PRECISION array of size (LDWH,NH) -*> \endverbatim -*> -*> \param[in] LDWH -*> \verbatim -*> LDWH is integer scalar -*> Leading dimension of WH just as declared in the -*> calling procedure. LDWH.GE.3*NSHFTS-3. -*> \endverbatim -*> -*> \param[in] NV -*> \verbatim -*> NV is integer scalar -*> NV is the number of rows in WV agailable for workspace. -*> NV.GE.1. -*> \endverbatim -*> -*> \param[out] WV -*> \verbatim -*> WV is DOUBLE PRECISION array of size -*> (LDWV,3*NSHFTS-3) -*> \endverbatim -*> -*> \param[in] LDWV -*> \verbatim -*> LDWV is integer scalar -*> LDWV is the leading dimension of WV as declared in the -*> in the calling subroutine. LDWV.GE.NV. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Contributors: -* ================== -*> -*> Karen Braman and Ralph Byers, Department of Mathematics, -*> University of Kansas, USA -* -*> \par References: -* ================ -*> -*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR -*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 -*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages -*> 929--947, 2002. -*> -* ===================================================================== - SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, - $ SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, - $ LDU, NV, WV, LDWV, NH, WH, LDWH ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, - $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV - LOGICAL WANTT, WANTZ -* .. -* .. Array Arguments .. - DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), U( LDU, * ), - $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ), - $ Z( LDZ, * ) -* .. -* -* ================================================================ -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, BETA, H11, H12, H21, H22, REFSUM, - $ SAFMAX, SAFMIN, SCL, SMLNUM, SWAP, TST1, TST2, - $ ULP - INTEGER I, I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN, - $ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS, - $ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL, - $ NS, NU - LOGICAL ACCUM, BLK22, BMP22 -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Intrinsic Functions .. -* - INTRINSIC ABS, DBLE, MAX, MIN, MOD -* .. -* .. Local Arrays .. - DOUBLE PRECISION VT( 3 ) -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DLABAD, DLACPY, DLAQR1, DLARFG, DLASET, - $ DTRMM -* .. -* .. Executable Statements .. -* -* ==== If there are no shifts, then there is nothing to do. ==== -* - IF( NSHFTS.LT.2 ) - $ RETURN -* -* ==== If the active block is empty or 1-by-1, then there -* . is nothing to do. ==== -* - IF( KTOP.GE.KBOT ) - $ RETURN -* -* ==== Shuffle shifts into pairs of real shifts and pairs -* . of complex conjugate shifts assuming complex -* . conjugate shifts are already adjacent to one -* . another. ==== -* - DO 10 I = 1, NSHFTS - 2, 2 - IF( SI( I ).NE.-SI( I+1 ) ) THEN -* - SWAP = SR( I ) - SR( I ) = SR( I+1 ) - SR( I+1 ) = SR( I+2 ) - SR( I+2 ) = SWAP -* - SWAP = SI( I ) - SI( I ) = SI( I+1 ) - SI( I+1 ) = SI( I+2 ) - SI( I+2 ) = SWAP - END IF - 10 CONTINUE -* -* ==== NSHFTS is supposed to be even, but if it is odd, -* . then simply reduce it by one. The shuffle above -* . ensures that the dropped shift is real and that -* . the remaining shifts are paired. ==== -* - NS = NSHFTS - MOD( NSHFTS, 2 ) -* -* ==== Machine constants for deflation ==== -* - SAFMIN = DLAMCH( 'SAFE MINIMUM' ) - SAFMAX = ONE / SAFMIN - CALL DLABAD( SAFMIN, SAFMAX ) - ULP = DLAMCH( 'PRECISION' ) - SMLNUM = SAFMIN*( DBLE( N ) / ULP ) -* -* ==== Use accumulated reflections to update far-from-diagonal -* . entries ? ==== -* - ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 ) -* -* ==== If so, exploit the 2-by-2 block structure? ==== -* - BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 ) -* -* ==== clear trash ==== -* - IF( KTOP+2.LE.KBOT ) - $ H( KTOP+2, KTOP ) = ZERO -* -* ==== NBMPS = number of 2-shift bulges in the chain ==== -* - NBMPS = NS / 2 -* -* ==== KDU = width of slab ==== -* - KDU = 6*NBMPS - 3 -* -* ==== Create and chase chains of NBMPS bulges ==== -* - DO 220 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2 - NDCOL = INCOL + KDU - IF( ACCUM ) - $ CALL DLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU ) -* -* ==== Near-the-diagonal bulge chase. The following loop -* . performs the near-the-diagonal part of a small bulge -* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal -* . chunk extends from column INCOL to column NDCOL -* . (including both column INCOL and column NDCOL). The -* . following loop chases a 3*NBMPS column long chain of -* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL -* . may be less than KTOP and and NDCOL may be greater than -* . KBOT indicating phantom columns from which to chase -* . bulges before they are actually introduced or to which -* . to chase bulges beyond column KBOT.) ==== -* - DO 150 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 ) -* -* ==== Bulges number MTOP to MBOT are active double implicit -* . shift bulges. There may or may not also be small -* . 2-by-2 bulge, if there is room. The inactive bulges -* . (if any) must wait until the active bulges have moved -* . down the diagonal to make room. The phantom matrix -* . paradigm described above helps keep track. ==== -* - MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 ) - MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 ) - M22 = MBOT + 1 - BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ. - $ ( KBOT-2 ) -* -* ==== Generate reflections to chase the chain right -* . one column. (The minimum value of K is KTOP-1.) ==== -* - DO 20 M = MTOP, MBOT - K = KRCOL + 3*( M-1 ) - IF( K.EQ.KTOP-1 ) THEN - CALL DLAQR1( 3, H( KTOP, KTOP ), LDH, SR( 2*M-1 ), - $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), - $ V( 1, M ) ) - ALPHA = V( 1, M ) - CALL DLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) ) - ELSE - BETA = H( K+1, K ) - V( 2, M ) = H( K+2, K ) - V( 3, M ) = H( K+3, K ) - CALL DLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) ) -* -* ==== A Bulge may collapse because of vigilant -* . deflation or destructive underflow. In the -* . underflow case, try the two-small-subdiagonals -* . trick to try to reinflate the bulge. ==== -* - IF( H( K+3, K ).NE.ZERO .OR. H( K+3, K+1 ).NE. - $ ZERO .OR. H( K+3, K+2 ).EQ.ZERO ) THEN -* -* ==== Typical case: not collapsed (yet). ==== -* - H( K+1, K ) = BETA - H( K+2, K ) = ZERO - H( K+3, K ) = ZERO - ELSE -* -* ==== Atypical case: collapsed. Attempt to -* . reintroduce ignoring H(K+1,K) and H(K+2,K). -* . If the fill resulting from the new -* . reflector is too large, then abandon it. -* . Otherwise, use the new one. ==== -* - CALL DLAQR1( 3, H( K+1, K+1 ), LDH, SR( 2*M-1 ), - $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), - $ VT ) - ALPHA = VT( 1 ) - CALL DLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) - REFSUM = VT( 1 )*( H( K+1, K )+VT( 2 )* - $ H( K+2, K ) ) -* - IF( ABS( H( K+2, K )-REFSUM*VT( 2 ) )+ - $ ABS( REFSUM*VT( 3 ) ).GT.ULP* - $ ( ABS( H( K, K ) )+ABS( H( K+1, - $ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN -* -* ==== Starting a new bulge here would -* . create non-negligible fill. Use -* . the old one with trepidation. ==== -* - H( K+1, K ) = BETA - H( K+2, K ) = ZERO - H( K+3, K ) = ZERO - ELSE -* -* ==== Stating a new bulge here would -* . create only negligible fill. -* . Replace the old reflector with -* . the new one. ==== -* - H( K+1, K ) = H( K+1, K ) - REFSUM - H( K+2, K ) = ZERO - H( K+3, K ) = ZERO - V( 1, M ) = VT( 1 ) - V( 2, M ) = VT( 2 ) - V( 3, M ) = VT( 3 ) - END IF - END IF - END IF - 20 CONTINUE -* -* ==== Generate a 2-by-2 reflection, if needed. ==== -* - K = KRCOL + 3*( M22-1 ) - IF( BMP22 ) THEN - IF( K.EQ.KTOP-1 ) THEN - CALL DLAQR1( 2, H( K+1, K+1 ), LDH, SR( 2*M22-1 ), - $ SI( 2*M22-1 ), SR( 2*M22 ), SI( 2*M22 ), - $ V( 1, M22 ) ) - BETA = V( 1, M22 ) - CALL DLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) - ELSE - BETA = H( K+1, K ) - V( 2, M22 ) = H( K+2, K ) - CALL DLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) - H( K+1, K ) = BETA - H( K+2, K ) = ZERO - END IF - END IF -* -* ==== Multiply H by reflections from the left ==== -* - IF( ACCUM ) THEN - JBOT = MIN( NDCOL, KBOT ) - ELSE IF( WANTT ) THEN - JBOT = N - ELSE - JBOT = KBOT - END IF - DO 40 J = MAX( KTOP, KRCOL ), JBOT - MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 ) - DO 30 M = MTOP, MEND - K = KRCOL + 3*( M-1 ) - REFSUM = V( 1, M )*( H( K+1, J )+V( 2, M )* - $ H( K+2, J )+V( 3, M )*H( K+3, J ) ) - H( K+1, J ) = H( K+1, J ) - REFSUM - H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M ) - H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M ) - 30 CONTINUE - 40 CONTINUE - IF( BMP22 ) THEN - K = KRCOL + 3*( M22-1 ) - DO 50 J = MAX( K+1, KTOP ), JBOT - REFSUM = V( 1, M22 )*( H( K+1, J )+V( 2, M22 )* - $ H( K+2, J ) ) - H( K+1, J ) = H( K+1, J ) - REFSUM - H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 ) - 50 CONTINUE - END IF -* -* ==== Multiply H by reflections from the right. -* . Delay filling in the last row until the -* . vigilant deflation check is complete. ==== -* - IF( ACCUM ) THEN - JTOP = MAX( KTOP, INCOL ) - ELSE IF( WANTT ) THEN - JTOP = 1 - ELSE - JTOP = KTOP - END IF - DO 90 M = MTOP, MBOT - IF( V( 1, M ).NE.ZERO ) THEN - K = KRCOL + 3*( M-1 ) - DO 60 J = JTOP, MIN( KBOT, K+3 ) - REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )* - $ H( J, K+2 )+V( 3, M )*H( J, K+3 ) ) - H( J, K+1 ) = H( J, K+1 ) - REFSUM - H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M ) - H( J, K+3 ) = H( J, K+3 ) - REFSUM*V( 3, M ) - 60 CONTINUE -* - IF( ACCUM ) THEN -* -* ==== Accumulate U. (If necessary, update Z later -* . with with an efficient matrix-matrix -* . multiply.) ==== -* - KMS = K - INCOL - DO 70 J = MAX( 1, KTOP-INCOL ), KDU - REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )* - $ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) ) - U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM - U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*V( 2, M ) - U( J, KMS+3 ) = U( J, KMS+3 ) - REFSUM*V( 3, M ) - 70 CONTINUE - ELSE IF( WANTZ ) THEN -* -* ==== U is not accumulated, so update Z -* . now by multiplying by reflections -* . from the right. ==== -* - DO 80 J = ILOZ, IHIZ - REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )* - $ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) ) - Z( J, K+1 ) = Z( J, K+1 ) - REFSUM - Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M ) - Z( J, K+3 ) = Z( J, K+3 ) - REFSUM*V( 3, M ) - 80 CONTINUE - END IF - END IF - 90 CONTINUE -* -* ==== Special case: 2-by-2 reflection (if needed) ==== -* - K = KRCOL + 3*( M22-1 ) - IF( BMP22 ) THEN - IF ( V( 1, M22 ).NE.ZERO ) THEN - DO 100 J = JTOP, MIN( KBOT, K+3 ) - REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )* - $ H( J, K+2 ) ) - H( J, K+1 ) = H( J, K+1 ) - REFSUM - H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M22 ) - 100 CONTINUE -* - IF( ACCUM ) THEN - KMS = K - INCOL - DO 110 J = MAX( 1, KTOP-INCOL ), KDU - REFSUM = V( 1, M22 )*( U( J, KMS+1 )+ - $ V( 2, M22 )*U( J, KMS+2 ) ) - U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM - U( J, KMS+2 ) = U( J, KMS+2 ) - - $ REFSUM*V( 2, M22 ) - 110 CONTINUE - ELSE IF( WANTZ ) THEN - DO 120 J = ILOZ, IHIZ - REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )* - $ Z( J, K+2 ) ) - Z( J, K+1 ) = Z( J, K+1 ) - REFSUM - Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M22 ) - 120 CONTINUE - END IF - END IF - END IF -* -* ==== Vigilant deflation check ==== -* - MSTART = MTOP - IF( KRCOL+3*( MSTART-1 ).LT.KTOP ) - $ MSTART = MSTART + 1 - MEND = MBOT - IF( BMP22 ) - $ MEND = MEND + 1 - IF( KRCOL.EQ.KBOT-2 ) - $ MEND = MEND + 1 - DO 130 M = MSTART, MEND - K = MIN( KBOT-1, KRCOL+3*( M-1 ) ) -* -* ==== The following convergence test requires that -* . the tradition small-compared-to-nearby-diagonals -* . criterion and the Ahues & Tisseur (LAWN 122, 1997) -* . criteria both be satisfied. The latter improves -* . accuracy in some examples. Falling back on an -* . alternate convergence criterion when TST1 or TST2 -* . is zero (as done here) is traditional but probably -* . unnecessary. ==== -* - IF( H( K+1, K ).NE.ZERO ) THEN - TST1 = ABS( H( K, K ) ) + ABS( H( K+1, K+1 ) ) - IF( TST1.EQ.ZERO ) THEN - IF( K.GE.KTOP+1 ) - $ TST1 = TST1 + ABS( H( K, K-1 ) ) - IF( K.GE.KTOP+2 ) - $ TST1 = TST1 + ABS( H( K, K-2 ) ) - IF( K.GE.KTOP+3 ) - $ TST1 = TST1 + ABS( H( K, K-3 ) ) - IF( K.LE.KBOT-2 ) - $ TST1 = TST1 + ABS( H( K+2, K+1 ) ) - IF( K.LE.KBOT-3 ) - $ TST1 = TST1 + ABS( H( K+3, K+1 ) ) - IF( K.LE.KBOT-4 ) - $ TST1 = TST1 + ABS( H( K+4, K+1 ) ) - END IF - IF( ABS( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) ) - $ THEN - H12 = MAX( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) ) - H21 = MIN( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) ) - H11 = MAX( ABS( H( K+1, K+1 ) ), - $ ABS( H( K, K )-H( K+1, K+1 ) ) ) - H22 = MIN( ABS( H( K+1, K+1 ) ), - $ ABS( H( K, K )-H( K+1, K+1 ) ) ) - SCL = H11 + H12 - TST2 = H22*( H11 / SCL ) -* - IF( TST2.EQ.ZERO .OR. H21*( H12 / SCL ).LE. - $ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO - END IF - END IF - 130 CONTINUE -* -* ==== Fill in the last row of each bulge. ==== -* - MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 ) - DO 140 M = MTOP, MEND - K = KRCOL + 3*( M-1 ) - REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 ) - H( K+4, K+1 ) = -REFSUM - H( K+4, K+2 ) = -REFSUM*V( 2, M ) - H( K+4, K+3 ) = H( K+4, K+3 ) - REFSUM*V( 3, M ) - 140 CONTINUE -* -* ==== End of near-the-diagonal bulge chase. ==== -* - 150 CONTINUE -* -* ==== Use U (if accumulated) to update far-from-diagonal -* . entries in H. If required, use U to update Z as -* . well. ==== -* - IF( ACCUM ) THEN - IF( WANTT ) THEN - JTOP = 1 - JBOT = N - ELSE - JTOP = KTOP - JBOT = KBOT - END IF - IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR. - $ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN -* -* ==== Updates not exploiting the 2-by-2 block -* . structure of U. K1 and NU keep track of -* . the location and size of U in the special -* . cases of introducing bulges and chasing -* . bulges off the bottom. In these special -* . cases and in case the number of shifts -* . is NS = 2, there is no 2-by-2 block -* . structure to exploit. ==== -* - K1 = MAX( 1, KTOP-INCOL ) - NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1 -* -* ==== Horizontal Multiply ==== -* - DO 160 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH - JLEN = MIN( NH, JBOT-JCOL+1 ) - CALL DGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ), - $ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, - $ LDWH ) - CALL DLACPY( 'ALL', NU, JLEN, WH, LDWH, - $ H( INCOL+K1, JCOL ), LDH ) - 160 CONTINUE -* -* ==== Vertical multiply ==== -* - DO 170 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV - JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW ) - CALL DGEMM( 'N', 'N', JLEN, NU, NU, ONE, - $ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ), - $ LDU, ZERO, WV, LDWV ) - CALL DLACPY( 'ALL', JLEN, NU, WV, LDWV, - $ H( JROW, INCOL+K1 ), LDH ) - 170 CONTINUE -* -* ==== Z multiply (also vertical) ==== -* - IF( WANTZ ) THEN - DO 180 JROW = ILOZ, IHIZ, NV - JLEN = MIN( NV, IHIZ-JROW+1 ) - CALL DGEMM( 'N', 'N', JLEN, NU, NU, ONE, - $ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ), - $ LDU, ZERO, WV, LDWV ) - CALL DLACPY( 'ALL', JLEN, NU, WV, LDWV, - $ Z( JROW, INCOL+K1 ), LDZ ) - 180 CONTINUE - END IF - ELSE -* -* ==== Updates exploiting U's 2-by-2 block structure. -* . (I2, I4, J2, J4 are the last rows and columns -* . of the blocks.) ==== -* - I2 = ( KDU+1 ) / 2 - I4 = KDU - J2 = I4 - I2 - J4 = KDU -* -* ==== KZS and KNZ deal with the band of zeros -* . along the diagonal of one of the triangular -* . blocks. ==== -* - KZS = ( J4-J2 ) - ( NS+1 ) - KNZ = NS + 1 -* -* ==== Horizontal multiply ==== -* - DO 190 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH - JLEN = MIN( NH, JBOT-JCOL+1 ) -* -* ==== Copy bottom of H to top+KZS of scratch ==== -* (The first KZS rows get multiplied by zero.) ==== -* - CALL DLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ), - $ LDH, WH( KZS+1, 1 ), LDWH ) -* -* ==== Multiply by U21**T ==== -* - CALL DLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH ) - CALL DTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE, - $ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ), - $ LDWH ) -* -* ==== Multiply top of H by U11**T ==== -* - CALL DGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, - $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) -* -* ==== Copy top of H to bottom of WH ==== -* - CALL DLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, - $ WH( I2+1, 1 ), LDWH ) -* -* ==== Multiply by U21**T ==== -* - CALL DTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE, - $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH ) -* -* ==== Multiply by U22 ==== -* - CALL DGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE, - $ U( J2+1, I2+1 ), LDU, - $ H( INCOL+1+J2, JCOL ), LDH, ONE, - $ WH( I2+1, 1 ), LDWH ) -* -* ==== Copy it back ==== -* - CALL DLACPY( 'ALL', KDU, JLEN, WH, LDWH, - $ H( INCOL+1, JCOL ), LDH ) - 190 CONTINUE -* -* ==== Vertical multiply ==== -* - DO 200 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV - JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW ) -* -* ==== Copy right of H to scratch (the first KZS -* . columns get multiplied by zero) ==== -* - CALL DLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ), - $ LDH, WV( 1, 1+KZS ), LDWV ) -* -* ==== Multiply by U21 ==== -* - CALL DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV ) - CALL DTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, - $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), - $ LDWV ) -* -* ==== Multiply by U11 ==== -* - CALL DGEMM( 'N', 'N', JLEN, I2, J2, ONE, - $ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV, - $ LDWV ) -* -* ==== Copy left of H to right of scratch ==== -* - CALL DLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH, - $ WV( 1, 1+I2 ), LDWV ) -* -* ==== Multiply by U21 ==== -* - CALL DTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, - $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV ) -* -* ==== Multiply by U22 ==== -* - CALL DGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, - $ H( JROW, INCOL+1+J2 ), LDH, - $ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ), - $ LDWV ) -* -* ==== Copy it back ==== -* - CALL DLACPY( 'ALL', JLEN, KDU, WV, LDWV, - $ H( JROW, INCOL+1 ), LDH ) - 200 CONTINUE -* -* ==== Multiply Z (also vertical) ==== -* - IF( WANTZ ) THEN - DO 210 JROW = ILOZ, IHIZ, NV - JLEN = MIN( NV, IHIZ-JROW+1 ) -* -* ==== Copy right of Z to left of scratch (first -* . KZS columns get multiplied by zero) ==== -* - CALL DLACPY( 'ALL', JLEN, KNZ, - $ Z( JROW, INCOL+1+J2 ), LDZ, - $ WV( 1, 1+KZS ), LDWV ) -* -* ==== Multiply by U12 ==== -* - CALL DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, - $ LDWV ) - CALL DTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, - $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), - $ LDWV ) -* -* ==== Multiply by U11 ==== -* - CALL DGEMM( 'N', 'N', JLEN, I2, J2, ONE, - $ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE, - $ WV, LDWV ) -* -* ==== Copy left of Z to right of scratch ==== -* - CALL DLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ), - $ LDZ, WV( 1, 1+I2 ), LDWV ) -* -* ==== Multiply by U21 ==== -* - CALL DTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, - $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), - $ LDWV ) -* -* ==== Multiply by U22 ==== -* - CALL DGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, - $ Z( JROW, INCOL+1+J2 ), LDZ, - $ U( J2+1, I2+1 ), LDU, ONE, - $ WV( 1, 1+I2 ), LDWV ) -* -* ==== Copy the result back to Z ==== -* - CALL DLACPY( 'ALL', JLEN, KDU, WV, LDWV, - $ Z( JROW, INCOL+1 ), LDZ ) - 210 CONTINUE - END IF - END IF - END IF - 220 CONTINUE -* -* ==== End of DLAQR5 ==== -* - END diff --git a/mtx/lapack_src/dlarf.f b/mtx/lapack_src/dlarf.f deleted file mode 100644 index 2a82ff439..000000000 --- a/mtx/lapack_src/dlarf.f +++ /dev/null @@ -1,227 +0,0 @@ -*> \brief \b DLARF -* -* =========== 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. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER SIDE - INTEGER INCV, LDC, M, N - DOUBLE PRECISION TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL APPLYLEFT - INTEGER I, LASTV, LASTC -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DGER -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILADLR, ILADLC - EXTERNAL LSAME, ILADLR, ILADLC -* .. -* .. Executable Statements .. -* - APPLYLEFT = LSAME( SIDE, 'L' ) - LASTV = 0 - LASTC = 0 - IF( TAU.NE.ZERO ) THEN -! Set up variables for scanning V. LASTV begins pointing to the end -! of V. - IF( APPLYLEFT ) THEN - LASTV = M - ELSE - LASTV = N - END IF - IF( INCV.GT.0 ) THEN - I = 1 + (LASTV-1) * INCV - ELSE - I = 1 - END IF -! Look for the last non-zero row in V. - DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) - LASTV = LASTV - 1 - I = I - INCV - END DO - IF( APPLYLEFT ) THEN -! Scan for the last non-zero column in C(1:lastv,:). - LASTC = ILADLC(LASTV, N, C, LDC) - ELSE -! Scan for the last non-zero row in C(:,1:lastv). - LASTC = ILADLR(M, LASTV, C, LDC) - END IF - END IF -! Note that lastc.eq.0 renders the BLAS operations null; no special -! case is needed at this level. - IF( APPLYLEFT ) THEN -* -* Form H * C -* - IF( LASTV.GT.0 ) THEN -* -* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) -* - CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV, - $ ZERO, WORK, 1 ) -* -* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T -* - CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) - END IF - ELSE -* -* Form C * H -* - IF( LASTV.GT.0 ) THEN -* -* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) -* - CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, - $ V, INCV, ZERO, WORK, 1 ) -* -* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T -* - CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) - END IF - END IF - RETURN -* -* End of DLARF -* - END diff --git a/mtx/lapack_src/dlarfb.f b/mtx/lapack_src/dlarfb.f deleted file mode 100644 index 206d3b268..000000000 --- a/mtx/lapack_src/dlarfb.f +++ /dev/null @@ -1,762 +0,0 @@ -*> \brief \b DLARFB -* -* =========== 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). -*> \endverbatim -*> -*> \param[in] V -*> \verbatim -*> V is DOUBLE PRECISION array, dimension -*> (LDV,K) if STOREV = 'C' -*> (LDV,M) if STOREV = 'R' and SIDE = 'L' -*> (LDV,N) if STOREV = 'R' and SIDE = 'R' -*> The matrix V. See Further Details. -*> \endverbatim -*> -*> \param[in] LDV -*> \verbatim -*> LDV is INTEGER -*> The leading dimension of the array V. -*> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); -*> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); -*> if STOREV = 'R', LDV >= K. -*> \endverbatim -*> -*> \param[in] T -*> \verbatim -*> T is DOUBLE PRECISION array, dimension (LDT,K) -*> The triangular k by k matrix T in the representation of the -*> block reflector. -*> \endverbatim -*> -*> \param[in] LDT -*> \verbatim -*> LDT is INTEGER -*> The leading dimension of the array T. LDT >= K. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) -*> On entry, the m by n matrix C. -*> On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (LDWORK,K) -*> \endverbatim -*> -*> \param[in] LDWORK -*> \verbatim -*> LDWORK is INTEGER -*> The leading dimension of the array WORK. -*> If SIDE = 'L', LDWORK >= max(1,N); -*> if SIDE = 'R', LDWORK >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The shape of the matrix V and the storage of the vectors which define -*> the H(i) is best illustrated by the following example with n = 5 and -*> k = 3. The elements equal to 1 are not stored; the corresponding -*> array elements are modified but restored on exit. The rest of the -*> array is not used. -*> -*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -*> -*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -*> ( v1 1 ) ( 1 v2 v2 v2 ) -*> ( v1 v2 1 ) ( 1 v3 v3 ) -*> ( v1 v2 v3 ) -*> ( v1 v2 v3 ) -*> -*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -*> -*> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -*> ( v1 v2 v3 ) ( v2 v2 v2 1 ) -*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -*> ( 1 v3 ) -*> ( 1 ) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, - $ T, LDT, C, LDC, WORK, LDWORK ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER DIRECT, SIDE, STOREV, TRANS - INTEGER K, LDC, LDT, LDV, LDWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), - $ WORK( LDWORK, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - CHARACTER TRANST - INTEGER I, J, LASTV, LASTC -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILADLR, ILADLC - EXTERNAL LSAME, ILADLR, ILADLC -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DTRMM -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - IF( LSAME( TRANS, 'N' ) ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF -* - IF( LSAME( STOREV, 'C' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 ) (first K rows) -* ( V2 ) -* where V1 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* - LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) -* -* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) -* -* W := C1**T -* - DO 10 J = 1, K - CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 10 CONTINUE -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C2**T *V2 -* - CALL DGEMM( 'Transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W**T -* - IF( LASTV.GT.K ) THEN -* -* C2 := C2 - V2 * W**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTV-K, LASTC, K, - $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, - $ C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W**T -* - DO 30 J = 1, K - DO 20 I = 1, LASTC - C( J, I ) = C( J, I ) - WORK( I, J ) - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C1 -* - DO 40 J = 1, K - CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) - 40 CONTINUE -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C2 * V2 -* - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V**T -* - IF( LASTV.GT.K ) THEN -* -* C2 := C2 - W * V2**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, - $ C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 60 J = 1, K - DO 50 I = 1, LASTC - C( I, J ) = C( I, J ) - WORK( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF -* - ELSE -* -* Let V = ( V1 ) -* ( V2 ) (last K rows) -* where V2 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* - LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) -* -* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) -* -* W := C2**T -* - DO 70 J = 1, K - CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) - 70 CONTINUE -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, - $ WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C1**T*V1 -* - CALL DGEMM( 'Transpose', 'No transpose', - $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W**T -* - IF( LASTV.GT.K ) THEN -* -* C1 := C1 - V1 * W**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) - END IF -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, - $ WORK, LDWORK ) -* -* C2 := C2 - W**T -* - DO 90 J = 1, K - DO 80 I = 1, LASTC - C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C2 -* - DO 100 J = 1, K - CALL DCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) - 100 CONTINUE -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, - $ WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C1 * V1 -* - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V**T -* - IF( LASTV.GT.K ) THEN -* -* C1 := C1 - W * V1**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) - END IF -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, - $ WORK, LDWORK ) -* -* C2 := C2 - W -* - DO 120 J = 1, K - DO 110 I = 1, LASTC - C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J) - 110 CONTINUE - 120 CONTINUE - END IF - END IF -* - ELSE IF( LSAME( STOREV, 'R' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 V2 ) (V1: first K columns) -* where V1 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* - LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) -* -* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) -* -* W := C1**T -* - DO 130 J = 1, K - CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 130 CONTINUE -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C2**T*V2**T -* - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V**T * W**T -* - IF( LASTV.GT.K ) THEN -* -* C2 := C2 - V2**T * W**T -* - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTV-K, LASTC, K, - $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, - $ ONE, C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W**T -* - DO 150 J = 1, K - DO 140 I = 1, LASTC - C( J, I ) = C( J, I ) - WORK( I, J ) - 140 CONTINUE - 150 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) -* -* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) -* -* W := C1 -* - DO 160 J = 1, K - CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) - 160 CONTINUE -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C2 * V2**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( LASTV.GT.K ) THEN -* -* C2 := C2 - W * V2 -* - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, - $ ONE, C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 180 J = 1, K - DO 170 I = 1, LASTC - C( I, J ) = C( I, J ) - WORK( I, J ) - 170 CONTINUE - 180 CONTINUE -* - END IF -* - ELSE -* -* Let V = ( V1 V2 ) (V2: last K columns) -* where V2 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* - LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) -* -* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) -* -* W := C2**T -* - DO 190 J = 1, K - CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) - 190 CONTINUE -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, - $ WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C1**T * V1**T -* - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V**T * W**T -* - IF( LASTV.GT.K ) THEN -* -* C1 := C1 - V1**T * W**T -* - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, - $ WORK, LDWORK ) -* -* C2 := C2 - W**T -* - DO 210 J = 1, K - DO 200 I = 1, LASTC - C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) - 200 CONTINUE - 210 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) -* -* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) -* -* W := C2 -* - DO 220 J = 1, K - CALL DCOPY( LASTC, C( 1, LASTV-K+J ), 1, - $ WORK( 1, J ), 1 ) - 220 CONTINUE -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, - $ WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C1 * V1**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( LASTV.GT.K ) THEN -* -* C1 := C1 - W * V1 -* - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, - $ WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 240 J = 1, K - DO 230 I = 1, LASTC - C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J) - 230 CONTINUE - 240 CONTINUE -* - END IF -* - END IF - END IF -* - RETURN -* -* End of DLARFB -* - END diff --git a/mtx/lapack_src/dlarfg.f b/mtx/lapack_src/dlarfg.f deleted file mode 100644 index 458ad2e05..000000000 --- a/mtx/lapack_src/dlarfg.f +++ /dev/null @@ -1,196 +0,0 @@ -*> \brief \b DLARFG -* -* =========== 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. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INCX, N - DOUBLE PRECISION ALPHA, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION X( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER J, KNT - DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 - EXTERNAL DLAMCH, DLAPY2, DNRM2 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SIGN -* .. -* .. External Subroutines .. - EXTERNAL DSCAL -* .. -* .. Executable Statements .. -* - IF( N.LE.1 ) THEN - TAU = ZERO - RETURN - END IF -* - XNORM = DNRM2( N-1, X, INCX ) -* - IF( XNORM.EQ.ZERO ) THEN -* -* H = I -* - TAU = ZERO - ELSE -* -* general case -* - BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) - SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) - KNT = 0 - IF( ABS( BETA ).LT.SAFMIN ) THEN -* -* XNORM, BETA may be inaccurate; scale X and recompute them -* - RSAFMN = ONE / SAFMIN - 10 CONTINUE - KNT = KNT + 1 - CALL DSCAL( N-1, RSAFMN, X, INCX ) - BETA = BETA*RSAFMN - ALPHA = ALPHA*RSAFMN - IF( ABS( BETA ).LT.SAFMIN ) - $ GO TO 10 -* -* New BETA is at most 1, at least SAFMIN -* - XNORM = DNRM2( N-1, X, INCX ) - BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) - END IF - TAU = ( BETA-ALPHA ) / BETA - CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) -* -* If ALPHA is subnormal, it may lose relative accuracy -* - DO 20 J = 1, KNT - BETA = BETA*SAFMIN - 20 CONTINUE - ALPHA = BETA - END IF -* - RETURN -* -* End of DLARFG -* - END diff --git a/mtx/lapack_src/dlarft.f b/mtx/lapack_src/dlarft.f deleted file mode 100644 index 4b7550403..000000000 --- a/mtx/lapack_src/dlarft.f +++ /dev/null @@ -1,326 +0,0 @@ -*> \brief \b DLARFT -* -* =========== 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. -* -*> \date April 2012 -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The shape of the matrix V and the storage of the vectors which define -*> the H(i) is best illustrated by the following example with n = 5 and -*> k = 3. The elements equal to 1 are not stored. -*> -*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -*> -*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -*> ( v1 1 ) ( 1 v2 v2 v2 ) -*> ( v1 v2 1 ) ( 1 v3 v3 ) -*> ( v1 v2 v3 ) -*> ( v1 v2 v3 ) -*> -*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -*> -*> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -*> ( v1 v2 v3 ) ( v2 v2 v2 1 ) -*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -*> ( 1 v3 ) -*> ( 1 ) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* -* -- LAPACK auxiliary routine (version 3.4.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 -* -* .. Scalar Arguments .. - CHARACTER DIRECT, STOREV - INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, PREVLASTV, LASTV -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DTRMV -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( LSAME( DIRECT, 'F' ) ) THEN - PREVLASTV = N - DO I = 1, K - PREVLASTV = MAX( I, PREVLASTV ) - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = 1, I - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * V( I , J ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) -* - CALL DGEMV( 'Transpose', J-I, I-1, -TAU( I ), - $ V( I+1, 1 ), LDV, V( I+1, I ), 1, ONE, - $ T( 1, I ), 1 ) - ELSE -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * V( J , I ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T -* - CALL DGEMV( 'No transpose', I-1, J-I, -TAU( I ), - $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, ONE, - $ T( 1, I ), 1 ) - END IF -* -* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) -* - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, - $ LDT, T( 1, I ), 1 ) - T( I, I ) = TAU( I ) - IF( I.GT.1 ) THEN - PREVLASTV = MAX( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - END DO - ELSE - PREVLASTV = 1 - DO I = K, 1, -1 - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = I, K - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( I.LT.K ) THEN - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - DO J = I+1, K - T( J, I ) = -TAU( I ) * V( N-K+I , J ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) -* - CALL DGEMV( 'Transpose', N-K+I-J, K-I, -TAU( I ), - $ V( J, I+1 ), LDV, V( J, I ), 1, ONE, - $ T( I+1, I ), 1 ) - ELSE -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - DO J = I+1, K - T( J, I ) = -TAU( I ) * V( J, N-K+I ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T -* - CALL DGEMV( 'No transpose', K-I, N-K+I-J, - $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, - $ ONE, T( I+1, I ), 1 ) - END IF -* -* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) -* - CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, - $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) - IF( I.GT.1 ) THEN - PREVLASTV = MIN( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - T( I, I ) = TAU( I ) - END IF - END DO - END IF - RETURN -* -* End of DLARFT -* - END diff --git a/mtx/lapack_src/dlarfx.f b/mtx/lapack_src/dlarfx.f deleted file mode 100644 index 76338199a..000000000 --- a/mtx/lapack_src/dlarfx.f +++ /dev/null @@ -1,697 +0,0 @@ -*> \brief \b DLARFX -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLARFX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE -* INTEGER LDC, M, N -* DOUBLE PRECISION TAU -* .. -* .. Array Arguments .. -* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLARFX 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 -*> -*> This version uses inline code if H has order < 11. -*> \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 (M) if SIDE = 'L' -*> or (N) if SIDE = 'R' -*> The vector v in the representation of H. -*> \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. LDA >= (1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension -*> (N) if SIDE = 'L' -*> or (M) if SIDE = 'R' -*> WORK is not referenced if H has order < 11. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER SIDE - INTEGER LDC, M, N - DOUBLE PRECISION TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER J - DOUBLE PRECISION SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9, - $ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9 -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLARF -* .. -* .. Executable Statements .. -* - IF( TAU.EQ.ZERO ) - $ RETURN - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C, where H has order m. -* - GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, - $ 170, 190 )M -* -* Code for general M -* - CALL DLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK ) - GO TO 410 - 10 CONTINUE -* -* Special code for 1 x 1 Householder -* - T1 = ONE - TAU*V( 1 )*V( 1 ) - DO 20 J = 1, N - C( 1, J ) = T1*C( 1, J ) - 20 CONTINUE - GO TO 410 - 30 CONTINUE -* -* Special code for 2 x 2 Householder -* - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - DO 40 J = 1, N - SUM = V1*C( 1, J ) + V2*C( 2, J ) - C( 1, J ) = C( 1, J ) - SUM*T1 - C( 2, J ) = C( 2, J ) - SUM*T2 - 40 CONTINUE - GO TO 410 - 50 CONTINUE -* -* Special code for 3 x 3 Householder -* - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - DO 60 J = 1, N - SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) - C( 1, J ) = C( 1, J ) - SUM*T1 - C( 2, J ) = C( 2, J ) - SUM*T2 - C( 3, J ) = C( 3, J ) - SUM*T3 - 60 CONTINUE - GO TO 410 - 70 CONTINUE -* -* Special code for 4 x 4 Householder -* - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - DO 80 J = 1, N - SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + - $ V4*C( 4, J ) - C( 1, J ) = C( 1, J ) - SUM*T1 - C( 2, J ) = C( 2, J ) - SUM*T2 - C( 3, J ) = C( 3, J ) - SUM*T3 - C( 4, J ) = C( 4, J ) - SUM*T4 - 80 CONTINUE - GO TO 410 - 90 CONTINUE -* -* Special code for 5 x 5 Householder -* - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - DO 100 J = 1, N - SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + - $ V4*C( 4, J ) + V5*C( 5, J ) - C( 1, J ) = C( 1, J ) - SUM*T1 - C( 2, J ) = C( 2, J ) - SUM*T2 - C( 3, J ) = C( 3, J ) - SUM*T3 - C( 4, J ) = C( 4, J ) - SUM*T4 - C( 5, J ) = C( 5, J ) - SUM*T5 - 100 CONTINUE - GO TO 410 - 110 CONTINUE -* -* Special code for 6 x 6 Householder -* - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - DO 120 J = 1, N - SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + - $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) - C( 1, J ) = C( 1, J ) - SUM*T1 - C( 2, J ) = C( 2, J ) - SUM*T2 - C( 3, J ) = C( 3, J ) - SUM*T3 - C( 4, J ) = C( 4, J ) - SUM*T4 - C( 5, J ) = C( 5, J ) - SUM*T5 - C( 6, J ) = C( 6, J ) - SUM*T6 - 120 CONTINUE - GO TO 410 - 130 CONTINUE -* -* Special code for 7 x 7 Householder -* - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - V7 = V( 7 ) - T7 = TAU*V7 - DO 140 J = 1, N - SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + - $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + - $ V7*C( 7, J ) - C( 1, J ) = C( 1, J ) - SUM*T1 - C( 2, J ) = C( 2, J ) - SUM*T2 - C( 3, J ) = C( 3, J ) - SUM*T3 - C( 4, J ) = C( 4, J ) - SUM*T4 - C( 5, J ) = C( 5, J ) - SUM*T5 - C( 6, J ) = C( 6, J ) - SUM*T6 - C( 7, J ) = C( 7, J ) - SUM*T7 - 140 CONTINUE - GO TO 410 - 150 CONTINUE -* -* Special code for 8 x 8 Householder -* - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - V7 = V( 7 ) - T7 = TAU*V7 - V8 = V( 8 ) - T8 = TAU*V8 - DO 160 J = 1, N - SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + - $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + - $ V7*C( 7, J ) + V8*C( 8, J ) - C( 1, J ) = C( 1, J ) - SUM*T1 - C( 2, J ) = C( 2, J ) - SUM*T2 - C( 3, J ) = C( 3, J ) - SUM*T3 - C( 4, J ) = C( 4, J ) - SUM*T4 - C( 5, J ) = C( 5, J ) - SUM*T5 - C( 6, J ) = C( 6, J ) - SUM*T6 - C( 7, J ) = C( 7, J ) - SUM*T7 - C( 8, J ) = C( 8, J ) - SUM*T8 - 160 CONTINUE - GO TO 410 - 170 CONTINUE -* -* Special code for 9 x 9 Householder -* - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - V7 = V( 7 ) - T7 = TAU*V7 - V8 = V( 8 ) - T8 = TAU*V8 - V9 = V( 9 ) - T9 = TAU*V9 - DO 180 J = 1, N - SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + - $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + - $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) - C( 1, J ) = C( 1, J ) - SUM*T1 - C( 2, J ) = C( 2, J ) - SUM*T2 - C( 3, J ) = C( 3, J ) - SUM*T3 - C( 4, J ) = C( 4, J ) - SUM*T4 - C( 5, J ) = C( 5, J ) - SUM*T5 - C( 6, J ) = C( 6, J ) - SUM*T6 - C( 7, J ) = C( 7, J ) - SUM*T7 - C( 8, J ) = C( 8, J ) - SUM*T8 - C( 9, J ) = C( 9, J ) - SUM*T9 - 180 CONTINUE - GO TO 410 - 190 CONTINUE -* -* Special code for 10 x 10 Householder -* - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - V7 = V( 7 ) - T7 = TAU*V7 - V8 = V( 8 ) - T8 = TAU*V8 - V9 = V( 9 ) - T9 = TAU*V9 - V10 = V( 10 ) - T10 = TAU*V10 - DO 200 J = 1, N - SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + - $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + - $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) + - $ V10*C( 10, J ) - C( 1, J ) = C( 1, J ) - SUM*T1 - C( 2, J ) = C( 2, J ) - SUM*T2 - C( 3, J ) = C( 3, J ) - SUM*T3 - C( 4, J ) = C( 4, J ) - SUM*T4 - C( 5, J ) = C( 5, J ) - SUM*T5 - C( 6, J ) = C( 6, J ) - SUM*T6 - C( 7, J ) = C( 7, J ) - SUM*T7 - C( 8, J ) = C( 8, J ) - SUM*T8 - C( 9, J ) = C( 9, J ) - SUM*T9 - C( 10, J ) = C( 10, J ) - SUM*T10 - 200 CONTINUE - GO TO 410 - ELSE -* -* Form C * H, where H has order n. -* - GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, - $ 370, 390 )N -* -* Code for general N -* - CALL DLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK ) - GO TO 410 - 210 CONTINUE -* -* Special code for 1 x 1 Householder -* - T1 = ONE - TAU*V( 1 )*V( 1 ) - DO 220 J = 1, M - C( J, 1 ) = T1*C( J, 1 ) - 220 CONTINUE - GO TO 410 - 230 CONTINUE -* -* Special code for 2 x 2 Householder -* - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - DO 240 J = 1, M - SUM = V1*C( J, 1 ) + V2*C( J, 2 ) - C( J, 1 ) = C( J, 1 ) - SUM*T1 - C( J, 2 ) = C( J, 2 ) - SUM*T2 - 240 CONTINUE - GO TO 410 - 250 CONTINUE -* -* Special code for 3 x 3 Householder -* - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - DO 260 J = 1, M - SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) - C( J, 1 ) = C( J, 1 ) - SUM*T1 - C( J, 2 ) = C( J, 2 ) - SUM*T2 - C( J, 3 ) = C( J, 3 ) - SUM*T3 - 260 CONTINUE - GO TO 410 - 270 CONTINUE -* -* Special code for 4 x 4 Householder -* - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - DO 280 J = 1, M - SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + - $ V4*C( J, 4 ) - C( J, 1 ) = C( J, 1 ) - SUM*T1 - C( J, 2 ) = C( J, 2 ) - SUM*T2 - C( J, 3 ) = C( J, 3 ) - SUM*T3 - C( J, 4 ) = C( J, 4 ) - SUM*T4 - 280 CONTINUE - GO TO 410 - 290 CONTINUE -* -* Special code for 5 x 5 Householder -* - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - DO 300 J = 1, M - SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + - $ V4*C( J, 4 ) + V5*C( J, 5 ) - C( J, 1 ) = C( J, 1 ) - SUM*T1 - C( J, 2 ) = C( J, 2 ) - SUM*T2 - C( J, 3 ) = C( J, 3 ) - SUM*T3 - C( J, 4 ) = C( J, 4 ) - SUM*T4 - C( J, 5 ) = C( J, 5 ) - SUM*T5 - 300 CONTINUE - GO TO 410 - 310 CONTINUE -* -* Special code for 6 x 6 Householder -* - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - DO 320 J = 1, M - SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + - $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) - C( J, 1 ) = C( J, 1 ) - SUM*T1 - C( J, 2 ) = C( J, 2 ) - SUM*T2 - C( J, 3 ) = C( J, 3 ) - SUM*T3 - C( J, 4 ) = C( J, 4 ) - SUM*T4 - C( J, 5 ) = C( J, 5 ) - SUM*T5 - C( J, 6 ) = C( J, 6 ) - SUM*T6 - 320 CONTINUE - GO TO 410 - 330 CONTINUE -* -* Special code for 7 x 7 Householder -* - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - V7 = V( 7 ) - T7 = TAU*V7 - DO 340 J = 1, M - SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + - $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + - $ V7*C( J, 7 ) - C( J, 1 ) = C( J, 1 ) - SUM*T1 - C( J, 2 ) = C( J, 2 ) - SUM*T2 - C( J, 3 ) = C( J, 3 ) - SUM*T3 - C( J, 4 ) = C( J, 4 ) - SUM*T4 - C( J, 5 ) = C( J, 5 ) - SUM*T5 - C( J, 6 ) = C( J, 6 ) - SUM*T6 - C( J, 7 ) = C( J, 7 ) - SUM*T7 - 340 CONTINUE - GO TO 410 - 350 CONTINUE -* -* Special code for 8 x 8 Householder -* - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - V7 = V( 7 ) - T7 = TAU*V7 - V8 = V( 8 ) - T8 = TAU*V8 - DO 360 J = 1, M - SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + - $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + - $ V7*C( J, 7 ) + V8*C( J, 8 ) - C( J, 1 ) = C( J, 1 ) - SUM*T1 - C( J, 2 ) = C( J, 2 ) - SUM*T2 - C( J, 3 ) = C( J, 3 ) - SUM*T3 - C( J, 4 ) = C( J, 4 ) - SUM*T4 - C( J, 5 ) = C( J, 5 ) - SUM*T5 - C( J, 6 ) = C( J, 6 ) - SUM*T6 - C( J, 7 ) = C( J, 7 ) - SUM*T7 - C( J, 8 ) = C( J, 8 ) - SUM*T8 - 360 CONTINUE - GO TO 410 - 370 CONTINUE -* -* Special code for 9 x 9 Householder -* - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - V7 = V( 7 ) - T7 = TAU*V7 - V8 = V( 8 ) - T8 = TAU*V8 - V9 = V( 9 ) - T9 = TAU*V9 - DO 380 J = 1, M - SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + - $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + - $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) - C( J, 1 ) = C( J, 1 ) - SUM*T1 - C( J, 2 ) = C( J, 2 ) - SUM*T2 - C( J, 3 ) = C( J, 3 ) - SUM*T3 - C( J, 4 ) = C( J, 4 ) - SUM*T4 - C( J, 5 ) = C( J, 5 ) - SUM*T5 - C( J, 6 ) = C( J, 6 ) - SUM*T6 - C( J, 7 ) = C( J, 7 ) - SUM*T7 - C( J, 8 ) = C( J, 8 ) - SUM*T8 - C( J, 9 ) = C( J, 9 ) - SUM*T9 - 380 CONTINUE - GO TO 410 - 390 CONTINUE -* -* Special code for 10 x 10 Householder -* - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - V7 = V( 7 ) - T7 = TAU*V7 - V8 = V( 8 ) - T8 = TAU*V8 - V9 = V( 9 ) - T9 = TAU*V9 - V10 = V( 10 ) - T10 = TAU*V10 - DO 400 J = 1, M - SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + - $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + - $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) + - $ V10*C( J, 10 ) - C( J, 1 ) = C( J, 1 ) - SUM*T1 - C( J, 2 ) = C( J, 2 ) - SUM*T2 - C( J, 3 ) = C( J, 3 ) - SUM*T3 - C( J, 4 ) = C( J, 4 ) - SUM*T4 - C( J, 5 ) = C( J, 5 ) - SUM*T5 - C( J, 6 ) = C( J, 6 ) - SUM*T6 - C( J, 7 ) = C( J, 7 ) - SUM*T7 - C( J, 8 ) = C( J, 8 ) - SUM*T8 - C( J, 9 ) = C( J, 9 ) - SUM*T9 - C( J, 10 ) = C( J, 10 ) - SUM*T10 - 400 CONTINUE - GO TO 410 - END IF - 410 CONTINUE - RETURN -* -* End of DLARFX -* - END diff --git a/mtx/lapack_src/dlartg.f b/mtx/lapack_src/dlartg.f deleted file mode 100644 index aa68c3776..000000000 --- a/mtx/lapack_src/dlartg.f +++ /dev/null @@ -1,204 +0,0 @@ -*> \brief \b DLARTG -* -* =========== 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 November 2011 -* -*> \ingroup auxOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLARTG( F, G, CS, SN, R ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - DOUBLE PRECISION 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/mtx/lapack_src/dlas2.f b/mtx/lapack_src/dlas2.f deleted file mode 100644 index a6a711dda..000000000 --- a/mtx/lapack_src/dlas2.f +++ /dev/null @@ -1,183 +0,0 @@ -*> \brief \b DLAS2 -* -* =========== 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. -* -*> \date November 2011 -* -*> \ingroup auxOTHERauxiliary -* -*> \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 (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - DOUBLE PRECISION 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/mtx/lapack_src/dlascl.f b/mtx/lapack_src/dlascl.f deleted file mode 100644 index 5b4d3b24e..000000000 --- a/mtx/lapack_src/dlascl.f +++ /dev/null @@ -1,364 +0,0 @@ -*> \brief \b DLASCL -* -* =========== 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. LDA >= max(1,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. -* -*> \date November 2011 -* -*> \ingroup auxOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER 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. - 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/mtx/lapack_src/dlaset.f b/mtx/lapack_src/dlaset.f deleted file mode 100644 index 166a8da97..000000000 --- a/mtx/lapack_src/dlaset.f +++ /dev/null @@ -1,184 +0,0 @@ -*> \brief \b DLASET -* -* =========== 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[in,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. -* -*> \date November 2011 -* -*> \ingroup auxOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - 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/mtx/lapack_src/dlasq1.f b/mtx/lapack_src/dlasq1.f deleted file mode 100644 index af70675ab..000000000 --- a/mtx/lapack_src/dlasq1.f +++ /dev/null @@ -1,224 +0,0 @@ -*> \brief \b DLASQ1 -* -* =========== 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. -* -*> \date November 2011 -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER 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 = -2 - 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/mtx/lapack_src/dlasq2.f b/mtx/lapack_src/dlasq2.f deleted file mode 100644 index 94feaba7b..000000000 --- a/mtx/lapack_src/dlasq2.f +++ /dev/null @@ -1,582 +0,0 @@ -*> \brief \b DLASQ2 -* -* =========== 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. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER 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( 2 ).LT.ZERO .OR. Z( 3 ).LT.ZERO ) THEN - INFO = -2 - 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 .AND. - $ ILAENV( 11, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 -* -* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). -* - DO 30 K = 2*N, 2, -2 - Z( 2*K ) = ZERO - Z( 2*K-1 ) = Z( K ) - Z( 2*K-2 ) = ZERO - Z( 2*K-3 ) = Z( K-1 ) - 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/mtx/lapack_src/dlasq3.f b/mtx/lapack_src/dlasq3.f deleted file mode 100644 index d044b10ae..000000000 --- a/mtx/lapack_src/dlasq3.f +++ /dev/null @@ -1,421 +0,0 @@ -*> \brief \b DLASQ3 -* -* =========== 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] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( 4*N ) -*> 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[out] NFAIL -*> \verbatim -*> NFAIL is INTEGER -*> Number of times shift was too big. -*> \endverbatim -*> -*> \param[out] ITER -*> \verbatim -*> ITER is INTEGER -*> Number of iterations. -*> \endverbatim -*> -*> \param[out] NDIV -*> \verbatim -*> NDIV is INTEGER -*> Number of divisions. -*> \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. -* -*> \date April 2012 -* -*> \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 (version 3.4.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 -* -* .. Scalar Arguments .. - 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 - IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN - T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) ) - 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/mtx/lapack_src/dlasq4.f b/mtx/lapack_src/dlasq4.f deleted file mode 100644 index dc6fb719c..000000000 --- a/mtx/lapack_src/dlasq4.f +++ /dev/null @@ -1,425 +0,0 @@ -*> \brief \b DLASQ4 -* -* =========== 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*N ) -*> 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 REAL -*> 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. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER 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 - B2 = Z( NP-2 ) - 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/mtx/lapack_src/dlasq5.f b/mtx/lapack_src/dlasq5.f deleted file mode 100644 index 3724419b1..000000000 --- a/mtx/lapack_src/dlasq5.f +++ /dev/null @@ -1,410 +0,0 @@ -*> \brief \b DLASQ5 -* -* =========== 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. -* -*> \date April 2012 -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, - $ DN, DNM1, DNM2, IEEE, EPS ) -* -* -- LAPACK computational routine (version 3.4.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 -* -* .. Scalar Arguments .. - 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/mtx/lapack_src/dlasq6.f b/mtx/lapack_src/dlasq6.f deleted file mode 100644 index e069fa6f7..000000000 --- a/mtx/lapack_src/dlasq6.f +++ /dev/null @@ -1,254 +0,0 @@ -*> \brief \b DLASQ6 -* -* =========== 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. -* -*> \date November 2011 -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, - $ DNM1, DNM2 ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER 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/mtx/lapack_src/dlasr.f b/mtx/lapack_src/dlasr.f deleted file mode 100644 index bbe6217dd..000000000 --- a/mtx/lapack_src/dlasr.f +++ /dev/null @@ -1,436 +0,0 @@ -*> \brief \b DLASR -* -* =========== 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 = '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. -* -*> \date November 2011 -* -*> \ingroup auxOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - 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/mtx/lapack_src/dlasrt.f b/mtx/lapack_src/dlasrt.f deleted file mode 100644 index fe8f526a2..000000000 --- a/mtx/lapack_src/dlasrt.f +++ /dev/null @@ -1,303 +0,0 @@ -*> \brief \b DLASRT -* -* =========== 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. -* -*> \date November 2011 -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DLASRT( ID, N, D, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER 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 paramters. -* - 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/mtx/lapack_src/dlassq.f b/mtx/lapack_src/dlassq.f deleted file mode 100644 index 51d5a22d2..000000000 --- a/mtx/lapack_src/dlassq.f +++ /dev/null @@ -1,151 +0,0 @@ -*> \brief \b DLASSQ -* -* =========== 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 November 2011 -* -*> \ingroup auxOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INCX, N - DOUBLE PRECISION SCALE, SUMSQ -* .. -* .. Array Arguments .. - DOUBLE PRECISION X( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER IX - DOUBLE PRECISION ABSXI -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Executable Statements .. -* - IF( N.GT.0 ) THEN - DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX - IF( X( IX ).NE.ZERO ) THEN - ABSXI = ABS( X( IX ) ) - 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/mtx/lapack_src/dlasv2.f b/mtx/lapack_src/dlasv2.f deleted file mode 100644 index bf76ac27d..000000000 --- a/mtx/lapack_src/dlasv2.f +++ /dev/null @@ -1,325 +0,0 @@ -*> \brief \b DLASV2 -* -* =========== 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. -* -*> \date November 2011 -* -*> \ingroup auxOTHERauxiliary -* -*> \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 (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - DOUBLE PRECISION 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/mtx/lapack_src/dlaswp.f b/mtx/lapack_src/dlaswp.f deleted file mode 100644 index ff0d1b04e..000000000 --- a/mtx/lapack_src/dlaswp.f +++ /dev/null @@ -1,191 +0,0 @@ -*> \brief \b DLASWP -* -* =========== 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 -*> The last element of IPIV for which a row interchange will -*> be done. -*> \endverbatim -*> -*> \param[in] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (K2*abs(INCX)) -*> The vector of pivot indices. Only the elements in positions -*> K1 through K2 of IPIV are accessed. -*> IPIV(K) = L implies rows K and L are to be interchanged. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> The increment between successive values of IPIV. If IPIV -*> 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. -* -*> \date November 2011 -* -*> \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 (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INCX, 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(I) 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 = 1 + ( 1-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/mtx/lapack_src/dlasy2.f b/mtx/lapack_src/dlasy2.f deleted file mode 100644 index 33b533307..000000000 --- a/mtx/lapack_src/dlasy2.f +++ /dev/null @@ -1,480 +0,0 @@ -*> \brief \b DLASY2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASY2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, -* LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) -* -* .. Scalar Arguments .. -* LOGICAL LTRANL, LTRANR -* INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 -* DOUBLE PRECISION SCALE, XNORM -* .. -* .. Array Arguments .. -* DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), -* $ X( LDX, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in -*> -*> op(TL)*X + ISGN*X*op(TR) = SCALE*B, -*> -*> where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or -*> -1. op(T) = T or T**T, where T**T denotes the transpose of T. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] LTRANL -*> \verbatim -*> LTRANL is LOGICAL -*> On entry, LTRANL specifies the op(TL): -*> = .FALSE., op(TL) = TL, -*> = .TRUE., op(TL) = TL**T. -*> \endverbatim -*> -*> \param[in] LTRANR -*> \verbatim -*> LTRANR is LOGICAL -*> On entry, LTRANR specifies the op(TR): -*> = .FALSE., op(TR) = TR, -*> = .TRUE., op(TR) = TR**T. -*> \endverbatim -*> -*> \param[in] ISGN -*> \verbatim -*> ISGN is INTEGER -*> On entry, ISGN specifies the sign of the equation -*> as described before. ISGN may only be 1 or -1. -*> \endverbatim -*> -*> \param[in] N1 -*> \verbatim -*> N1 is INTEGER -*> On entry, N1 specifies the order of matrix TL. -*> N1 may only be 0, 1 or 2. -*> \endverbatim -*> -*> \param[in] N2 -*> \verbatim -*> N2 is INTEGER -*> On entry, N2 specifies the order of matrix TR. -*> N2 may only be 0, 1 or 2. -*> \endverbatim -*> -*> \param[in] TL -*> \verbatim -*> TL is DOUBLE PRECISION array, dimension (LDTL,2) -*> On entry, TL contains an N1 by N1 matrix. -*> \endverbatim -*> -*> \param[in] LDTL -*> \verbatim -*> LDTL is INTEGER -*> The leading dimension of the matrix TL. LDTL >= max(1,N1). -*> \endverbatim -*> -*> \param[in] TR -*> \verbatim -*> TR is DOUBLE PRECISION array, dimension (LDTR,2) -*> On entry, TR contains an N2 by N2 matrix. -*> \endverbatim -*> -*> \param[in] LDTR -*> \verbatim -*> LDTR is INTEGER -*> The leading dimension of the matrix TR. LDTR >= max(1,N2). -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,2) -*> On entry, the N1 by N2 matrix B contains the right-hand -*> side of the equation. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the matrix B. LDB >= max(1,N1). -*> \endverbatim -*> -*> \param[out] SCALE -*> \verbatim -*> SCALE is DOUBLE PRECISION -*> On exit, SCALE contains the scale factor. SCALE is chosen -*> less than or equal to 1 to prevent the solution overflowing. -*> \endverbatim -*> -*> \param[out] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension (LDX,2) -*> On exit, X contains the N1 by N2 solution. -*> \endverbatim -*> -*> \param[in] LDX -*> \verbatim -*> LDX is INTEGER -*> The leading dimension of the matrix X. LDX >= max(1,N1). -*> \endverbatim -*> -*> \param[out] XNORM -*> \verbatim -*> XNORM is DOUBLE PRECISION -*> On exit, XNORM is the infinity-norm of the solution. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> On exit, INFO is set to -*> 0: successful exit. -*> 1: TL and TR have too close eigenvalues, so TL or -*> TR is perturbed to get a nonsingular equation. -*> NOTE: In the interests of speed, this routine does not -*> check the inputs for errors. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleSYauxiliary -* -* ===================================================================== - SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, - $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - LOGICAL LTRANL, LTRANR - INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 - DOUBLE PRECISION SCALE, XNORM -* .. -* .. Array Arguments .. - DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), - $ X( LDX, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - DOUBLE PRECISION TWO, HALF, EIGHT - PARAMETER ( TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL BSWAP, XSWAP - INTEGER I, IP, IPIV, IPSV, J, JP, JPSV, K - DOUBLE PRECISION BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1, - $ TEMP, U11, U12, U22, XMAX -* .. -* .. Local Arrays .. - LOGICAL BSWPIV( 4 ), XSWPIV( 4 ) - INTEGER JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ), - $ LOCU22( 4 ) - DOUBLE PRECISION BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 ) -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL IDAMAX, DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. -* .. Data statements .. - DATA LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / , - $ LOCU22 / 4, 3, 2, 1 / - DATA XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. / - DATA BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. / -* .. -* .. Executable Statements .. -* -* Do not check the input parameters for errors -* - INFO = 0 -* -* Quick return if possible -* - IF( N1.EQ.0 .OR. N2.EQ.0 ) - $ RETURN -* -* Set constants to control overflow -* - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) / EPS - SGN = ISGN -* - K = N1 + N1 + N2 - 2 - GO TO ( 10, 20, 30, 50 )K -* -* 1 by 1: TL11*X + SGN*X*TR11 = B11 -* - 10 CONTINUE - TAU1 = TL( 1, 1 ) + SGN*TR( 1, 1 ) - BET = ABS( TAU1 ) - IF( BET.LE.SMLNUM ) THEN - TAU1 = SMLNUM - BET = SMLNUM - INFO = 1 - END IF -* - SCALE = ONE - GAM = ABS( B( 1, 1 ) ) - IF( SMLNUM*GAM.GT.BET ) - $ SCALE = ONE / GAM -* - X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1 - XNORM = ABS( X( 1, 1 ) ) - RETURN -* -* 1 by 2: -* TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12] = [B11 B12] -* [TR21 TR22] -* - 20 CONTINUE -* - SMIN = MAX( EPS*MAX( ABS( TL( 1, 1 ) ), ABS( TR( 1, 1 ) ), - $ ABS( TR( 1, 2 ) ), ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ), - $ SMLNUM ) - TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) - TMP( 4 ) = TL( 1, 1 ) + SGN*TR( 2, 2 ) - IF( LTRANR ) THEN - TMP( 2 ) = SGN*TR( 2, 1 ) - TMP( 3 ) = SGN*TR( 1, 2 ) - ELSE - TMP( 2 ) = SGN*TR( 1, 2 ) - TMP( 3 ) = SGN*TR( 2, 1 ) - END IF - BTMP( 1 ) = B( 1, 1 ) - BTMP( 2 ) = B( 1, 2 ) - GO TO 40 -* -* 2 by 1: -* op[TL11 TL12]*[X11] + ISGN* [X11]*TR11 = [B11] -* [TL21 TL22] [X21] [X21] [B21] -* - 30 CONTINUE - SMIN = MAX( EPS*MAX( ABS( TR( 1, 1 ) ), ABS( TL( 1, 1 ) ), - $ ABS( TL( 1, 2 ) ), ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ), - $ SMLNUM ) - TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) - TMP( 4 ) = TL( 2, 2 ) + SGN*TR( 1, 1 ) - IF( LTRANL ) THEN - TMP( 2 ) = TL( 1, 2 ) - TMP( 3 ) = TL( 2, 1 ) - ELSE - TMP( 2 ) = TL( 2, 1 ) - TMP( 3 ) = TL( 1, 2 ) - END IF - BTMP( 1 ) = B( 1, 1 ) - BTMP( 2 ) = B( 2, 1 ) - 40 CONTINUE -* -* Solve 2 by 2 system using complete pivoting. -* Set pivots less than SMIN to SMIN. -* - IPIV = IDAMAX( 4, TMP, 1 ) - U11 = TMP( IPIV ) - IF( ABS( U11 ).LE.SMIN ) THEN - INFO = 1 - U11 = SMIN - END IF - U12 = TMP( LOCU12( IPIV ) ) - L21 = TMP( LOCL21( IPIV ) ) / U11 - U22 = TMP( LOCU22( IPIV ) ) - U12*L21 - XSWAP = XSWPIV( IPIV ) - BSWAP = BSWPIV( IPIV ) - IF( ABS( U22 ).LE.SMIN ) THEN - INFO = 1 - U22 = SMIN - END IF - IF( BSWAP ) THEN - TEMP = BTMP( 2 ) - BTMP( 2 ) = BTMP( 1 ) - L21*TEMP - BTMP( 1 ) = TEMP - ELSE - BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 ) - END IF - SCALE = ONE - IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR. - $ ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN - SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) ) - BTMP( 1 ) = BTMP( 1 )*SCALE - BTMP( 2 ) = BTMP( 2 )*SCALE - END IF - X2( 2 ) = BTMP( 2 ) / U22 - X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 ) - IF( XSWAP ) THEN - TEMP = X2( 2 ) - X2( 2 ) = X2( 1 ) - X2( 1 ) = TEMP - END IF - X( 1, 1 ) = X2( 1 ) - IF( N1.EQ.1 ) THEN - X( 1, 2 ) = X2( 2 ) - XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) ) - ELSE - X( 2, 1 ) = X2( 2 ) - XNORM = MAX( ABS( X( 1, 1 ) ), ABS( X( 2, 1 ) ) ) - END IF - RETURN -* -* 2 by 2: -* op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12] -* [TL21 TL22] [X21 X22] [X21 X22] [TR21 TR22] [B21 B22] -* -* Solve equivalent 4 by 4 system using complete pivoting. -* Set pivots less than SMIN to SMIN. -* - 50 CONTINUE - SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), - $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) - SMIN = MAX( SMIN, ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), - $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ) - SMIN = MAX( EPS*SMIN, SMLNUM ) - BTMP( 1 ) = ZERO - CALL DCOPY( 16, BTMP, 0, T16, 1 ) - T16( 1, 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) - T16( 2, 2 ) = TL( 2, 2 ) + SGN*TR( 1, 1 ) - T16( 3, 3 ) = TL( 1, 1 ) + SGN*TR( 2, 2 ) - T16( 4, 4 ) = TL( 2, 2 ) + SGN*TR( 2, 2 ) - IF( LTRANL ) THEN - T16( 1, 2 ) = TL( 2, 1 ) - T16( 2, 1 ) = TL( 1, 2 ) - T16( 3, 4 ) = TL( 2, 1 ) - T16( 4, 3 ) = TL( 1, 2 ) - ELSE - T16( 1, 2 ) = TL( 1, 2 ) - T16( 2, 1 ) = TL( 2, 1 ) - T16( 3, 4 ) = TL( 1, 2 ) - T16( 4, 3 ) = TL( 2, 1 ) - END IF - IF( LTRANR ) THEN - T16( 1, 3 ) = SGN*TR( 1, 2 ) - T16( 2, 4 ) = SGN*TR( 1, 2 ) - T16( 3, 1 ) = SGN*TR( 2, 1 ) - T16( 4, 2 ) = SGN*TR( 2, 1 ) - ELSE - T16( 1, 3 ) = SGN*TR( 2, 1 ) - T16( 2, 4 ) = SGN*TR( 2, 1 ) - T16( 3, 1 ) = SGN*TR( 1, 2 ) - T16( 4, 2 ) = SGN*TR( 1, 2 ) - END IF - BTMP( 1 ) = B( 1, 1 ) - BTMP( 2 ) = B( 2, 1 ) - BTMP( 3 ) = B( 1, 2 ) - BTMP( 4 ) = B( 2, 2 ) -* -* Perform elimination -* - DO 100 I = 1, 3 - XMAX = ZERO - DO 70 IP = I, 4 - DO 60 JP = I, 4 - IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN - XMAX = ABS( T16( IP, JP ) ) - IPSV = IP - JPSV = JP - END IF - 60 CONTINUE - 70 CONTINUE - IF( IPSV.NE.I ) THEN - CALL DSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 ) - TEMP = BTMP( I ) - BTMP( I ) = BTMP( IPSV ) - BTMP( IPSV ) = TEMP - END IF - IF( JPSV.NE.I ) - $ CALL DSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 ) - JPIV( I ) = JPSV - IF( ABS( T16( I, I ) ).LT.SMIN ) THEN - INFO = 1 - T16( I, I ) = SMIN - END IF - DO 90 J = I + 1, 4 - T16( J, I ) = T16( J, I ) / T16( I, I ) - BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I ) - DO 80 K = I + 1, 4 - T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K ) - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - IF( ABS( T16( 4, 4 ) ).LT.SMIN ) - $ T16( 4, 4 ) = SMIN - SCALE = ONE - IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR. - $ ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR. - $ ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR. - $ ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN - SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ), - $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), ABS( BTMP( 4 ) ) ) - BTMP( 1 ) = BTMP( 1 )*SCALE - BTMP( 2 ) = BTMP( 2 )*SCALE - BTMP( 3 ) = BTMP( 3 )*SCALE - BTMP( 4 ) = BTMP( 4 )*SCALE - END IF - DO 120 I = 1, 4 - K = 5 - I - TEMP = ONE / T16( K, K ) - TMP( K ) = BTMP( K )*TEMP - DO 110 J = K + 1, 4 - TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J ) - 110 CONTINUE - 120 CONTINUE - DO 130 I = 1, 3 - IF( JPIV( 4-I ).NE.4-I ) THEN - TEMP = TMP( 4-I ) - TMP( 4-I ) = TMP( JPIV( 4-I ) ) - TMP( JPIV( 4-I ) ) = TEMP - END IF - 130 CONTINUE - X( 1, 1 ) = TMP( 1 ) - X( 2, 1 ) = TMP( 2 ) - X( 1, 2 ) = TMP( 3 ) - X( 2, 2 ) = TMP( 4 ) - XNORM = MAX( ABS( TMP( 1 ) )+ABS( TMP( 3 ) ), - $ ABS( TMP( 2 ) )+ABS( TMP( 4 ) ) ) - RETURN -* -* End of DLASY2 -* - END diff --git a/mtx/lapack_src/dlatbs.f b/mtx/lapack_src/dlatbs.f deleted file mode 100644 index d3fd23d32..000000000 --- a/mtx/lapack_src/dlatbs.f +++ /dev/null @@ -1,812 +0,0 @@ -*> \brief \b DLATBS -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLATBS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, -* SCALE, CNORM, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER DIAG, NORMIN, TRANS, UPLO -* INTEGER INFO, KD, LDAB, N -* DOUBLE PRECISION SCALE -* .. -* .. Array Arguments .. -* DOUBLE PRECISION AB( LDAB, * ), CNORM( * ), X( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLATBS solves one of the triangular systems -*> -*> A *x = s*b or A**T*x = s*b -*> -*> with scaling to prevent overflow, where A is an upper or lower -*> triangular band matrix. Here 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 DTBSV 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] KD -*> \verbatim -*> KD is INTEGER -*> The number of subdiagonals or superdiagonals in the -*> triangular matrix A. KD >= 0. -*> \endverbatim -*> -*> \param[in] AB -*> \verbatim -*> AB is DOUBLE PRECISION array, dimension (LDAB,N) -*> The upper or lower triangular band matrix A, stored in the -*> first KD+1 rows of the array. The j-th column of A is stored -*> in the j-th column of the array AB as follows: -*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; -*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). -*> \endverbatim -*> -*> \param[in] LDAB -*> \verbatim -*> LDAB is INTEGER -*> The leading dimension of the array AB. LDAB >= KD+1. -*> \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. -* -*> \date April 2012 -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> A rough bound on x is computed; if that is less than overflow, DTBSV -*> 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 DTBSV 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 DTBSV if 1/M(n) and 1/G(n) are both greater -*> than max(underflow, 1/overflow). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, - $ SCALE, CNORM, INFO ) -* -* -- LAPACK auxiliary routine (version 3.4.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 -* -* .. Scalar Arguments .. - CHARACTER DIAG, NORMIN, TRANS, UPLO - INTEGER INFO, KD, LDAB, N - DOUBLE PRECISION SCALE -* .. -* .. Array Arguments .. - DOUBLE PRECISION AB( LDAB, * ), 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, JLEN, MAIND - 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 - EXTERNAL LSAME, IDAMAX, DASUM, DDOT, DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DSCAL, DTBSV, 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( KD.LT.0 ) THEN - INFO = -6 - ELSE IF( LDAB.LT.KD+1 ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLATBS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine machine dependent parameters to control overflow. -* - SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM - SCALE = ONE -* - 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 - JLEN = MIN( KD, J-1 ) - CNORM( J ) = DASUM( JLEN, AB( KD+1-JLEN, J ), 1 ) - 10 CONTINUE - ELSE -* -* A is lower triangular. -* - DO 20 J = 1, N - JLEN = MIN( KD, N-J ) - IF( JLEN.GT.0 ) THEN - CNORM( J ) = DASUM( JLEN, AB( 2, J ), 1 ) - ELSE - CNORM( J ) = ZERO - END IF - 20 CONTINUE - 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 - TSCAL = ONE / ( SMLNUM*TMAX ) - CALL DSCAL( N, TSCAL, CNORM, 1 ) - END IF -* -* Compute a bound on the computed solution vector to see if the -* Level 2 BLAS routine DTBSV 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 - MAIND = KD + 1 - ELSE - JFIRST = 1 - JLAST = N - JINC = 1 - MAIND = 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( AB( MAIND, 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 - MAIND = KD + 1 - ELSE - JFIRST = N - JLAST = 1 - JINC = -1 - MAIND = 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( AB( MAIND, 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 DTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, 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 = AB( MAIND, 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(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) - -* x(j)* A(max(1,j-kd):j-1,j) -* - JLEN = MIN( KD, J-1 ) - CALL DAXPY( JLEN, -X( J )*TSCAL, - $ AB( KD+1-JLEN, J ), 1, X( J-JLEN ), 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:min(j+kd,n)) := x(j+1:min(j+kd,n)) - -* x(j) * A(j+1:min(j+kd,n),j) -* - JLEN = MIN( KD, N-J ) - IF( JLEN.GT.0 ) - $ CALL DAXPY( JLEN, -X( J )*TSCAL, AB( 2, J ), 1, - $ X( J+1 ), 1 ) - I = J + IDAMAX( N-J, X( J+1 ), 1 ) - XMAX = ABS( X( I ) ) - 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 = AB( MAIND, 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 - JLEN = MIN( KD, J-1 ) - SUMJ = DDOT( JLEN, AB( KD+1-JLEN, J ), 1, - $ X( J-JLEN ), 1 ) - ELSE - JLEN = MIN( KD, N-J ) - IF( JLEN.GT.0 ) - $ SUMJ = DDOT( JLEN, AB( 2, J ), 1, X( J+1 ), 1 ) - END IF - ELSE -* -* Otherwise, use in-line code for the dot product. -* - IF( UPPER ) THEN - JLEN = MIN( KD, J-1 ) - DO 120 I = 1, JLEN - SUMJ = SUMJ + ( AB( KD+I-JLEN, J )*USCAL )* - $ X( J-JLEN-1+I ) - 120 CONTINUE - ELSE - JLEN = MIN( KD, N-J ) - DO 130 I = 1, JLEN - SUMJ = SUMJ + ( AB( I+1, J )*USCAL )*X( J+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 -* -* Compute x(j) = x(j) / A(j,j), scaling if necessary. -* - TJJS = AB( MAIND, J )*TSCAL - ELSE - TJJS = TSCAL - IF( TSCAL.EQ.ONE ) - $ GO TO 150 - 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/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 DLATBS -* - END diff --git a/mtx/lapack_src/dlatrs.f b/mtx/lapack_src/dlatrs.f deleted file mode 100644 index 8ed76e31a..000000000 --- a/mtx/lapack_src/dlatrs.f +++ /dev/null @@ -1,787 +0,0 @@ -*> \brief \b DLATRS -* -* =========== 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. -* -*> \date April 2012 -* -*> \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 (version 3.4.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 -* -* .. Scalar Arguments .. - CHARACTER 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 - EXTERNAL LSAME, IDAMAX, DASUM, DDOT, DLAMCH -* .. -* .. 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 -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine machine dependent parameters to control overflow. -* - SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM - SCALE = ONE -* - 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 - TSCAL = ONE / ( SMLNUM*TMAX ) - CALL DSCAL( N, TSCAL, CNORM, 1 ) - 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/mtx/lapack_src/dlazq3.f b/mtx/lapack_src/dlazq3.f deleted file mode 100644 index 784248f73..000000000 --- a/mtx/lapack_src/dlazq3.f +++ /dev/null @@ -1,302 +0,0 @@ - SUBROUTINE DLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, - $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, - $ DN2, TAU ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - LOGICAL IEEE - INTEGER I0, ITER, N0, NDIV, NFAIL, PP, TTYPE - DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, QMAX, - $ SIGMA, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION Z( * ) -* .. -* -* Purpose -* ======= -* -* DLAZQ3 checks for deflation, computes a shift (TAU) and calls dqds. -* In case of failure it changes shifts, and tries again until output -* is positive. -* -* Arguments -* ========= -* -* I0 (input) INTEGER -* First index. -* -* N0 (input) INTEGER -* Last index. -* -* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) -* Z holds the qd array. -* -* PP (input) INTEGER -* PP=0 for ping, PP=1 for pong. -* -* DMIN (output) DOUBLE PRECISION -* Minimum value of d. -* -* SIGMA (output) DOUBLE PRECISION -* Sum of shifts used in current segment. -* -* DESIG (input/output) DOUBLE PRECISION -* Lower order part of SIGMA -* -* QMAX (input) DOUBLE PRECISION -* Maximum value of q. -* -* NFAIL (output) INTEGER -* Number of times shift was too big. -* -* ITER (output) INTEGER -* Number of iterations. -* -* NDIV (output) INTEGER -* Number of divisions. -* -* IEEE (input) LOGICAL -* Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). -* -* TTYPE (input/output) INTEGER -* Shift type. TTYPE is passed as an argument in order to save -* its value between calls to DLAZQ3 -* -* DMIN1 (input/output) REAL -* DMIN2 (input/output) REAL -* DN (input/output) REAL -* DN1 (input/output) REAL -* DN2 (input/output) REAL -* TAU (input/output) REAL -* These are passed as arguments in order to save their values -* between calls to DLAZQ3 -* -* This is a thread safe version of DLASQ3, which passes TTYPE, DMIN1, -* DMIN2, DN, DN1. DN2 and TAU through the argument list in place of -* declaring them in a SAVE statment. -* -* ===================================================================== -* -* .. 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 - DOUBLE PRECISION EPS, G, S, SAFMIN, T, TEMP, TOL, TOL2 -* .. -* .. External Subroutines .. - EXTERNAL DLASQ5, DLASQ6, DLAZQ4 -* .. -* .. External Function .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MIN, SQRT -* .. -* .. Executable Statements .. -* - N0IN = N0 - EPS = DLAMCH( 'Precision' ) - SAFMIN = DLAMCH( 'Safe minimum' ) - TOL = EPS*HUNDRD - TOL2 = TOL**2 - G = ZERO -* -* 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 - IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN - T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) ) - 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 -* -* 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 -* - IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ), - $ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN -* -* Choose a shift. -* - CALL DLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, - $ DN2, TAU, TTYPE, G ) -* -* Call dqds until DMIN > 0. -* - 80 CONTINUE -* - CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, - $ DN1, DN2, IEEE ) -* - NDIV = NDIV + ( N0-I0+2 ) - ITER = ITER + 1 -* -* Check status. -* - IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN -* -* Success. -* - GO TO 100 -* - 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 100 - 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 80 - ELSE IF( DMIN.NE.DMIN ) THEN -* -* NaN. -* - TAU = ZERO - GO TO 80 - ELSE -* -* Possible underflow. Play it safe. -* - GO TO 90 - END IF - END IF -* -* Risk of underflow. -* - 90 CONTINUE - CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 ) - NDIV = NDIV + ( N0-I0+2 ) - ITER = ITER + 1 - TAU = ZERO -* - 100 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 DLAZQ3 -* - END diff --git a/mtx/lapack_src/dlazq4.f b/mtx/lapack_src/dlazq4.f deleted file mode 100644 index 7c257f8d0..000000000 --- a/mtx/lapack_src/dlazq4.f +++ /dev/null @@ -1,330 +0,0 @@ - SUBROUTINE DLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, - $ DN1, DN2, TAU, TTYPE, G ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER I0, N0, N0IN, PP, TTYPE - DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION Z( * ) -* .. -* -* Purpose -* ======= -* -* DLAZQ4 computes an approximation TAU to the smallest eigenvalue -* using values of d from the previous transform. -* -* I0 (input) INTEGER -* First index. -* -* N0 (input) INTEGER -* Last index. -* -* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) -* Z holds the qd array. -* -* PP (input) INTEGER -* PP=0 for ping, PP=1 for pong. -* -* N0IN (input) INTEGER -* The value of N0 at start of EIGTEST. -* -* DMIN (input) DOUBLE PRECISION -* Minimum value of d. -* -* DMIN1 (input) DOUBLE PRECISION -* Minimum value of d, excluding D( N0 ). -* -* DMIN2 (input) DOUBLE PRECISION -* Minimum value of d, excluding D( N0 ) and D( N0-1 ). -* -* DN (input) DOUBLE PRECISION -* d(N) -* -* DN1 (input) DOUBLE PRECISION -* d(N-1) -* -* DN2 (input) DOUBLE PRECISION -* d(N-2) -* -* TAU (output) DOUBLE PRECISION -* This is the shift. -* -* TTYPE (output) INTEGER -* Shift type. -* -* G (input/output) DOUBLE PRECISION -* G is passed as an argument in order to save its value between -* calls to DLAZQ4 -* -* Further Details -* =============== -* CNST1 = 9/16 -* -* This is a thread safe version of DLASQ4, which passes G through the -* argument list in place of declaring G in a SAVE statment. -* -* ===================================================================== -* -* .. 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 - B2 = Z( NP-2 ) - 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 DLAZQ4 -* - END diff --git a/mtx/lapack_src/dnrm2.f b/mtx/lapack_src/dnrm2.f deleted file mode 100644 index 480c912a1..000000000 --- a/mtx/lapack_src/dnrm2.f +++ /dev/null @@ -1,67 +0,0 @@ - DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION X(*) -* .. -* -* Purpose -* ======= -* -* DNRM2 returns the euclidean norm of a vector via the function -* name, so that -* -* DNRM2 := sqrt( x'*x ) -* -* Further Details -* =============== -* -* -- This version written on 25-October-1982. -* Modified on 14-October-1993 to inline the call to DLASSQ. -* Sven Hammarling, Nag Ltd. -* -* ===================================================================== -* -* .. 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/mtx/lapack_src/dorg2r.f b/mtx/lapack_src/dorg2r.f deleted file mode 100644 index 4f3844282..000000000 --- a/mtx/lapack_src/dorg2r.f +++ /dev/null @@ -1,200 +0,0 @@ -*> \brief \b DORG2R -* -* =========== 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. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER 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/mtx/lapack_src/dorgbr.f b/mtx/lapack_src/dorgbr.f deleted file mode 100644 index ddfa7262a..000000000 --- a/mtx/lapack_src/dorgbr.f +++ /dev/null @@ -1,338 +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. -* -*> \date April 2012 -* -*> \ingroup doubleGBcomputational -* -* ===================================================================== - SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 -* -* .. Scalar Arguments .. - CHARACTER 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 - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. 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( 2, 2 ), 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( 2, 2 ), LDA, TAU, WORK, - $ -1, IINFO ) - END IF - END IF - END IF - LWKOPT = 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/mtx/lapack_src/dorghr.f b/mtx/lapack_src/dorghr.f deleted file mode 100644 index 48f504ea7..000000000 --- a/mtx/lapack_src/dorghr.f +++ /dev/null @@ -1,240 +0,0 @@ -*> \brief \b DORGHR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORGHR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER IHI, ILO, INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORGHR generates a real orthogonal matrix Q which is defined as the -*> product of IHI-ILO elementary reflectors of order N, as returned by -*> DGEHRD: -*> -*> Q = H(ilo) H(ilo+1) . . . H(ihi-1). -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix Q. N >= 0. -*> \endverbatim -*> -*> \param[in] ILO -*> \verbatim -*> ILO is INTEGER -*> \endverbatim -*> -*> \param[in] IHI -*> \verbatim -*> IHI is INTEGER -*> -*> ILO and IHI must have the same values as in the previous call -*> of DGEHRD. Q is equal to the unit matrix except in the -*> submatrix Q(ilo+1:ihi,ilo+1:ihi). -*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if 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 DGEHRD. -*> 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 DGEHRD. -*> \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 >= IHI-ILO. -*> For optimum performance LWORK >= (IHI-ILO)*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. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER IHI, ILO, 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 - INTEGER I, IINFO, J, LWKOPT, NB, NH -* .. -* .. External Subroutines .. - EXTERNAL DORGQR, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NH = IHI - ILO - LQUERY = ( LWORK.EQ.-1 ) - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -2 - ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF -* - IF( INFO.EQ.0 ) THEN - NB = ILAENV( 1, 'DORGQR', ' ', NH, NH, NH, -1 ) - LWKOPT = MAX( 1, NH )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGHR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* -* Shift the vectors which define the elementary reflectors one -* column to the right, and set the first ilo and the last n-ihi -* rows and columns to those of the unit matrix -* - DO 40 J = IHI, ILO + 1, -1 - DO 10 I = 1, J - 1 - A( I, J ) = ZERO - 10 CONTINUE - DO 20 I = J + 1, IHI - A( I, J ) = A( I, J-1 ) - 20 CONTINUE - DO 30 I = IHI + 1, N - A( I, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - DO 60 J = 1, ILO - DO 50 I = 1, N - A( I, J ) = ZERO - 50 CONTINUE - A( J, J ) = ONE - 60 CONTINUE - DO 80 J = IHI + 1, N - DO 70 I = 1, N - A( I, J ) = ZERO - 70 CONTINUE - A( J, J ) = ONE - 80 CONTINUE -* - IF( NH.GT.0 ) THEN -* -* Generate Q(ilo+1:ihi,ilo+1:ihi) -* - CALL DORGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ), - $ WORK, LWORK, IINFO ) - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORGHR -* - END diff --git a/mtx/lapack_src/dorgl2.f b/mtx/lapack_src/dorgl2.f deleted file mode 100644 index 3e8398b73..000000000 --- a/mtx/lapack_src/dorgl2.f +++ /dev/null @@ -1,204 +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. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER 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/mtx/lapack_src/dorglq.f b/mtx/lapack_src/dorglq.f deleted file mode 100644 index 88aec1500..000000000 --- a/mtx/lapack_src/dorglq.f +++ /dev/null @@ -1,289 +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. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER 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/mtx/lapack_src/dorgqr.f b/mtx/lapack_src/dorgqr.f deleted file mode 100644 index 404ab184e..000000000 --- a/mtx/lapack_src/dorgqr.f +++ /dev/null @@ -1,290 +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. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER 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/mtx/lapack_src/dorm2r.f b/mtx/lapack_src/dorm2r.f deleted file mode 100644 index 5a0593541..000000000 --- a/mtx/lapack_src/dorm2r.f +++ /dev/null @@ -1,282 +0,0 @@ -*> \brief \b DORM2R -* -* =========== 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. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER SIDE, 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/mtx/lapack_src/dormbr.f b/mtx/lapack_src/dormbr.f deleted file mode 100644 index 7a0d9b903..000000000 --- a/mtx/lapack_src/dormbr.f +++ /dev/null @@ -1,372 +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. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, - $ LDC, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER SIDE, 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 = N - ELSE - NQ = N - NW = 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.MAX( 1, 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 = MAX( 1, 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/mtx/lapack_src/dormhr.f b/mtx/lapack_src/dormhr.f deleted file mode 100644 index 85bfc41b6..000000000 --- a/mtx/lapack_src/dormhr.f +++ /dev/null @@ -1,294 +0,0 @@ -*> \brief \b DORMHR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORMHR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, -* LDC, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE, TRANS -* INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORMHR 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 -*> IHI-ILO elementary reflectors, as returned by DGEHRD: -*> -*> Q = H(ilo) H(ilo+1) . . . H(ihi-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] 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] ILO -*> \verbatim -*> ILO is INTEGER -*> \endverbatim -*> -*> \param[in] IHI -*> \verbatim -*> IHI is INTEGER -*> -*> ILO and IHI must have the same values as in the previous call -*> of DGEHRD. Q is equal to the unit matrix except in the -*> submatrix Q(ilo+1:ihi,ilo+1:ihi). -*> If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and -*> ILO = 1 and IHI = 0, if M = 0; -*> if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and -*> ILO = 1 and IHI = 0, if 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 DGEHRD. -*> \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 DGEHRD. -*> \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. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, - $ LDC, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL LEFT, LQUERY - INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DORMQR, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NH = IHI - ILO - LEFT = LSAME( SIDE, 'L' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = N - ELSE - NQ = N - NW = M - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ) .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( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN - INFO = -5 - ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -11 - ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( LEFT ) THEN - NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, NH, N, NH, -1 ) - ELSE - NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, NH, NH, -1 ) - END IF - LWKOPT = MAX( 1, NW )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMHR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( LEFT ) THEN - MI = NH - NI = N - I1 = ILO + 1 - I2 = 1 - ELSE - MI = M - NI = NH - I1 = 1 - I2 = ILO + 1 - END IF -* - CALL DORMQR( SIDE, TRANS, MI, NI, NH, A( ILO+1, ILO ), LDA, - $ TAU( ILO ), C( I1, I2 ), LDC, WORK, LWORK, IINFO ) -* - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMHR -* - END diff --git a/mtx/lapack_src/dorml2.f b/mtx/lapack_src/dorml2.f deleted file mode 100644 index fe85dc3aa..000000000 --- a/mtx/lapack_src/dorml2.f +++ /dev/null @@ -1,282 +0,0 @@ -*> \brief \b DORML2 -* -* =========== 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. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER SIDE, 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/mtx/lapack_src/dormlq.f b/mtx/lapack_src/dormlq.f deleted file mode 100644 index ebbd4d26e..000000000 --- a/mtx/lapack_src/dormlq.f +++ /dev/null @@ -1,354 +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 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. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT - PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, NOTRAN - CHARACTER TRANST - INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, - $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW -* .. -* .. Local Arrays .. - DOUBLE PRECISION T( LDT, NBMAX ) -* .. -* .. 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 = N - ELSE - NQ = N - NW = 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.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Determine the block size. NB may be at most NBMAX, where NBMAX -* is used to define the local array T. -* - NB = MIN( NBMAX, ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N, K, - $ -1 ) ) - LWKOPT = MAX( 1, NW )*NB - 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 - IWS = NW*NB - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORMLQ', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - ELSE - IWS = NW - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - 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 ), T, 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, T, LDT, C( IC, JC ), LDC, WORK, - $ LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMLQ -* - END diff --git a/mtx/lapack_src/dormqr.f b/mtx/lapack_src/dormqr.f deleted file mode 100644 index c0767ecf6..000000000 --- a/mtx/lapack_src/dormqr.f +++ /dev/null @@ -1,347 +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 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. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT - PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, NOTRAN - INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, - $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW -* .. -* .. Local Arrays .. - DOUBLE PRECISION T( LDT, NBMAX ) -* .. -* .. 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 = N - ELSE - NQ = N - NW = 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.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Determine the block size. NB may be at most NBMAX, where NBMAX -* is used to define the local array T. -* - NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - LWKOPT = MAX( 1, NW )*NB - 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 - IWS = NW*NB - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - ELSE - IWS = NW - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - 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 ), T, 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, T, LDT, C( IC, JC ), LDC, - $ WORK, LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMQR -* - END diff --git a/mtx/lapack_src/drot.f b/mtx/lapack_src/drot.f deleted file mode 100644 index a02bda37f..000000000 --- a/mtx/lapack_src/drot.f +++ /dev/null @@ -1,55 +0,0 @@ - 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(*) -* .. -* -* Purpose -* ======= -* -* DROT applies a plane rotation. -* -* Further Details -* =============== -* -* jack dongarra, linpack, 3/11/78. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. 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 diff --git a/mtx/lapack_src/drscl.f b/mtx/lapack_src/drscl.f deleted file mode 100644 index d850da05c..000000000 --- a/mtx/lapack_src/drscl.f +++ /dev/null @@ -1,174 +0,0 @@ -*> \brief \b DRSCL -* -* =========== 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. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DRSCL( N, SA, SX, INCX ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INCX, N - 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 -* .. -* .. 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/mtx/lapack_src/dtrevc.f b/mtx/lapack_src/dtrevc.f deleted file mode 100644 index 62e502912..000000000 --- a/mtx/lapack_src/dtrevc.f +++ /dev/null @@ -1,1076 +0,0 @@ -*> \brief \b DTREVC -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DTREVC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, -* LDVR, MM, M, WORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER HOWMNY, SIDE -* INTEGER INFO, LDT, LDVL, LDVR, M, MM, N -* .. -* .. Array Arguments .. -* LOGICAL SELECT( * ) -* DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), -* $ WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DTREVC computes some or all of the right and/or left eigenvectors of -*> a real upper quasi-triangular matrix T. -*> Matrices of this type are produced by the Schur factorization of -*> a real general matrix: A = Q*T*Q**T, as computed by DHSEQR. -*> -*> The right eigenvector x and the left eigenvector y of T corresponding -*> to an eigenvalue w are defined by: -*> -*> T*x = w*x, (y**T)*T = w*(y**T) -*> -*> where y**T denotes the transpose of y. -*> The eigenvalues are not input to this routine, but are read directly -*> from the diagonal blocks of T. -*> -*> This routine returns the matrices X and/or Y of right and left -*> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an -*> input matrix. If Q is the orthogonal factor that reduces a matrix -*> A to Schur form T, then Q*X and Q*Y are the matrices of right and -*> left eigenvectors of A. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'R': compute right eigenvectors only; -*> = 'L': compute left eigenvectors only; -*> = 'B': compute both right and left eigenvectors. -*> \endverbatim -*> -*> \param[in] HOWMNY -*> \verbatim -*> HOWMNY is CHARACTER*1 -*> = 'A': compute all right and/or left eigenvectors; -*> = 'B': compute all right and/or left eigenvectors, -*> backtransformed by the matrices in VR and/or VL; -*> = 'S': compute selected right and/or left eigenvectors, -*> as indicated by the logical array SELECT. -*> \endverbatim -*> -*> \param[in,out] SELECT -*> \verbatim -*> SELECT is LOGICAL array, dimension (N) -*> If HOWMNY = 'S', SELECT specifies the eigenvectors to be -*> computed. -*> If w(j) is a real eigenvalue, the corresponding real -*> eigenvector is computed if SELECT(j) is .TRUE.. -*> If w(j) and w(j+1) are the real and imaginary parts of a -*> complex eigenvalue, the corresponding complex eigenvector is -*> computed if either SELECT(j) or SELECT(j+1) is .TRUE., and -*> on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to -*> .FALSE.. -*> Not referenced if HOWMNY = 'A' or 'B'. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix T. N >= 0. -*> \endverbatim -*> -*> \param[in] T -*> \verbatim -*> T is DOUBLE PRECISION array, dimension (LDT,N) -*> The upper quasi-triangular matrix T in Schur canonical form. -*> \endverbatim -*> -*> \param[in] LDT -*> \verbatim -*> LDT is INTEGER -*> The leading dimension of the array T. LDT >= max(1,N). -*> \endverbatim -*> -*> \param[in,out] VL -*> \verbatim -*> VL is DOUBLE PRECISION array, dimension (LDVL,MM) -*> On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must -*> contain an N-by-N matrix Q (usually the orthogonal matrix Q -*> of Schur vectors returned by DHSEQR). -*> On exit, if SIDE = 'L' or 'B', VL contains: -*> if HOWMNY = 'A', the matrix Y of left eigenvectors of T; -*> if HOWMNY = 'B', the matrix Q*Y; -*> if HOWMNY = 'S', the left eigenvectors of T specified by -*> SELECT, stored consecutively in the columns -*> of VL, in the same order as their -*> eigenvalues. -*> A complex eigenvector corresponding to a complex eigenvalue -*> is stored in two consecutive columns, the first holding the -*> real part, and the second the imaginary part. -*> Not referenced if SIDE = 'R'. -*> \endverbatim -*> -*> \param[in] LDVL -*> \verbatim -*> LDVL is INTEGER -*> The leading dimension of the array VL. LDVL >= 1, and if -*> SIDE = 'L' or 'B', LDVL >= N. -*> \endverbatim -*> -*> \param[in,out] VR -*> \verbatim -*> VR is DOUBLE PRECISION array, dimension (LDVR,MM) -*> On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must -*> contain an N-by-N matrix Q (usually the orthogonal matrix Q -*> of Schur vectors returned by DHSEQR). -*> On exit, if SIDE = 'R' or 'B', VR contains: -*> if HOWMNY = 'A', the matrix X of right eigenvectors of T; -*> if HOWMNY = 'B', the matrix Q*X; -*> if HOWMNY = 'S', the right eigenvectors of T specified by -*> SELECT, stored consecutively in the columns -*> of VR, in the same order as their -*> eigenvalues. -*> A complex eigenvector corresponding to a complex eigenvalue -*> is stored in two consecutive columns, the first holding the -*> real part and the second the imaginary part. -*> Not referenced if SIDE = 'L'. -*> \endverbatim -*> -*> \param[in] LDVR -*> \verbatim -*> LDVR is INTEGER -*> The leading dimension of the array VR. LDVR >= 1, and if -*> SIDE = 'R' or 'B', LDVR >= N. -*> \endverbatim -*> -*> \param[in] MM -*> \verbatim -*> MM is INTEGER -*> The number of columns in the arrays VL and/or VR. MM >= M. -*> \endverbatim -*> -*> \param[out] M -*> \verbatim -*> M is INTEGER -*> The number of columns in the arrays VL and/or VR actually -*> used to store the eigenvectors. -*> If HOWMNY = 'A' or 'B', M is set to N. -*> Each selected real eigenvector occupies one column and each -*> selected complex eigenvector occupies two columns. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (3*N) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The algorithm used in this program is basically backward (forward) -*> substitution, with scaling to make the the code robust against -*> possible overflow. -*> -*> Each eigenvector is normalized so that the element of largest -*> magnitude has magnitude 1; here the magnitude of a complex number -*> (x,y) is taken to be |x| + |y|. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, - $ LDVR, MM, M, WORK, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER HOWMNY, SIDE - INTEGER INFO, LDT, LDVL, LDVR, M, MM, N -* .. -* .. Array Arguments .. - LOGICAL SELECT( * ) - DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), - $ WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV - INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2 - DOUBLE PRECISION BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE, - $ SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR, - $ XNORM -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DDOT, DLAMCH - EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DLALN2, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. -* .. Local Arrays .. - DOUBLE PRECISION X( 2, 2 ) -* .. -* .. Executable Statements .. -* -* Decode and test the input parameters -* - BOTHV = LSAME( SIDE, 'B' ) - RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV - LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV -* - ALLV = LSAME( HOWMNY, 'A' ) - OVER = LSAME( HOWMNY, 'B' ) - SOMEV = LSAME( HOWMNY, 'S' ) -* - INFO = 0 - IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN - INFO = -1 - ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN - INFO = -8 - ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN - INFO = -10 - ELSE -* -* Set M to the number of columns required to store the selected -* eigenvectors, standardize the array SELECT if necessary, and -* test MM. -* - IF( SOMEV ) THEN - M = 0 - PAIR = .FALSE. - DO 10 J = 1, N - IF( PAIR ) THEN - PAIR = .FALSE. - SELECT( J ) = .FALSE. - ELSE - IF( J.LT.N ) THEN - IF( T( J+1, J ).EQ.ZERO ) THEN - IF( SELECT( J ) ) - $ M = M + 1 - ELSE - PAIR = .TRUE. - IF( SELECT( J ) .OR. SELECT( J+1 ) ) THEN - SELECT( J ) = .TRUE. - M = M + 2 - END IF - END IF - ELSE - IF( SELECT( N ) ) - $ M = M + 1 - END IF - END IF - 10 CONTINUE - ELSE - M = N - END IF -* - IF( MM.LT.M ) THEN - INFO = -11 - END IF - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTREVC', -INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* Set the constants to control overflow. -* - UNFL = DLAMCH( 'Safe minimum' ) - OVFL = ONE / UNFL - CALL DLABAD( UNFL, OVFL ) - ULP = DLAMCH( 'Precision' ) - SMLNUM = UNFL*( N / ULP ) - BIGNUM = ( ONE-ULP ) / SMLNUM -* -* Compute 1-norm of each column of strictly upper triangular -* part of T to control overflow in triangular solver. -* - WORK( 1 ) = ZERO - DO 30 J = 2, N - WORK( J ) = ZERO - DO 20 I = 1, J - 1 - WORK( J ) = WORK( J ) + ABS( T( I, J ) ) - 20 CONTINUE - 30 CONTINUE -* -* Index IP is used to specify the real or complex eigenvalue: -* IP = 0, real eigenvalue, -* 1, first of conjugate complex pair: (wr,wi) -* -1, second of conjugate complex pair: (wr,wi) -* - N2 = 2*N -* - IF( RIGHTV ) THEN -* -* Compute right eigenvectors. -* - IP = 0 - IS = M - DO 140 KI = N, 1, -1 -* - IF( IP.EQ.1 ) - $ GO TO 130 - IF( KI.EQ.1 ) - $ GO TO 40 - IF( T( KI, KI-1 ).EQ.ZERO ) - $ GO TO 40 - IP = -1 -* - 40 CONTINUE - IF( SOMEV ) THEN - IF( IP.EQ.0 ) THEN - IF( .NOT.SELECT( KI ) ) - $ GO TO 130 - ELSE - IF( .NOT.SELECT( KI-1 ) ) - $ GO TO 130 - END IF - END IF -* -* Compute the KI-th eigenvalue (WR,WI). -* - WR = T( KI, KI ) - WI = ZERO - IF( IP.NE.0 ) - $ WI = SQRT( ABS( T( KI, KI-1 ) ) )* - $ SQRT( ABS( T( KI-1, KI ) ) ) - SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) -* - IF( IP.EQ.0 ) THEN -* -* Real right eigenvector -* - WORK( KI+N ) = ONE -* -* Form right-hand side -* - DO 50 K = 1, KI - 1 - WORK( K+N ) = -T( K, KI ) - 50 CONTINUE -* -* Solve the upper quasi-triangular system: -* (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK. -* - JNXT = KI - 1 - DO 60 J = KI - 1, 1, -1 - IF( J.GT.JNXT ) - $ GO TO 60 - J1 = J - J2 = J - JNXT = J - 1 - IF( J.GT.1 ) THEN - IF( T( J, J-1 ).NE.ZERO ) THEN - J1 = J - 1 - JNXT = J - 2 - END IF - END IF -* - IF( J1.EQ.J2 ) THEN -* -* 1-by-1 diagonal block -* - CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), - $ LDT, ONE, ONE, WORK( J+N ), N, WR, - $ ZERO, X, 2, SCALE, XNORM, IERR ) -* -* Scale X(1,1) to avoid overflow when updating -* the right-hand side. -* - IF( XNORM.GT.ONE ) THEN - IF( WORK( J ).GT.BIGNUM / XNORM ) THEN - X( 1, 1 ) = X( 1, 1 ) / XNORM - SCALE = SCALE / XNORM - END IF - END IF -* -* Scale if necessary -* - IF( SCALE.NE.ONE ) - $ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) - WORK( J+N ) = X( 1, 1 ) -* -* Update right-hand side -* - CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, - $ WORK( 1+N ), 1 ) -* - ELSE -* -* 2-by-2 diagonal block -* - CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, - $ T( J-1, J-1 ), LDT, ONE, ONE, - $ WORK( J-1+N ), N, WR, ZERO, X, 2, - $ SCALE, XNORM, IERR ) -* -* Scale X(1,1) and X(2,1) to avoid overflow when -* updating the right-hand side. -* - IF( XNORM.GT.ONE ) THEN - BETA = MAX( WORK( J-1 ), WORK( J ) ) - IF( BETA.GT.BIGNUM / XNORM ) THEN - X( 1, 1 ) = X( 1, 1 ) / XNORM - X( 2, 1 ) = X( 2, 1 ) / XNORM - SCALE = SCALE / XNORM - END IF - END IF -* -* Scale if necessary -* - IF( SCALE.NE.ONE ) - $ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) - WORK( J-1+N ) = X( 1, 1 ) - WORK( J+N ) = X( 2, 1 ) -* -* Update right-hand side -* - CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, - $ WORK( 1+N ), 1 ) - CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, - $ WORK( 1+N ), 1 ) - END IF - 60 CONTINUE -* -* Copy the vector x or Q*x to VR and normalize. -* - IF( .NOT.OVER ) THEN - CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS ), 1 ) -* - II = IDAMAX( KI, VR( 1, IS ), 1 ) - REMAX = ONE / ABS( VR( II, IS ) ) - CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 ) -* - DO 70 K = KI + 1, N - VR( K, IS ) = ZERO - 70 CONTINUE - ELSE - IF( KI.GT.1 ) - $ CALL DGEMV( 'N', N, KI-1, ONE, VR, LDVR, - $ WORK( 1+N ), 1, WORK( KI+N ), - $ VR( 1, KI ), 1 ) -* - II = IDAMAX( N, VR( 1, KI ), 1 ) - REMAX = ONE / ABS( VR( II, KI ) ) - CALL DSCAL( N, REMAX, VR( 1, KI ), 1 ) - END IF -* - ELSE -* -* Complex right eigenvector. -* -* Initial solve -* [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0. -* [ (T(KI,KI-1) T(KI,KI) ) ] -* - IF( ABS( T( KI-1, KI ) ).GE.ABS( T( KI, KI-1 ) ) ) THEN - WORK( KI-1+N ) = ONE - WORK( KI+N2 ) = WI / T( KI-1, KI ) - ELSE - WORK( KI-1+N ) = -WI / T( KI, KI-1 ) - WORK( KI+N2 ) = ONE - END IF - WORK( KI+N ) = ZERO - WORK( KI-1+N2 ) = ZERO -* -* Form right-hand side -* - DO 80 K = 1, KI - 2 - WORK( K+N ) = -WORK( KI-1+N )*T( K, KI-1 ) - WORK( K+N2 ) = -WORK( KI+N2 )*T( K, KI ) - 80 CONTINUE -* -* Solve upper quasi-triangular system: -* (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2) -* - JNXT = KI - 2 - DO 90 J = KI - 2, 1, -1 - IF( J.GT.JNXT ) - $ GO TO 90 - J1 = J - J2 = J - JNXT = J - 1 - IF( J.GT.1 ) THEN - IF( T( J, J-1 ).NE.ZERO ) THEN - J1 = J - 1 - JNXT = J - 2 - END IF - END IF -* - IF( J1.EQ.J2 ) THEN -* -* 1-by-1 diagonal block -* - CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), - $ LDT, ONE, ONE, WORK( J+N ), N, WR, WI, - $ X, 2, SCALE, XNORM, IERR ) -* -* Scale X(1,1) and X(1,2) to avoid overflow when -* updating the right-hand side. -* - IF( XNORM.GT.ONE ) THEN - IF( WORK( J ).GT.BIGNUM / XNORM ) THEN - X( 1, 1 ) = X( 1, 1 ) / XNORM - X( 1, 2 ) = X( 1, 2 ) / XNORM - SCALE = SCALE / XNORM - END IF - END IF -* -* Scale if necessary -* - IF( SCALE.NE.ONE ) THEN - CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) - CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) - END IF - WORK( J+N ) = X( 1, 1 ) - WORK( J+N2 ) = X( 1, 2 ) -* -* Update the right-hand side -* - CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, - $ WORK( 1+N ), 1 ) - CALL DAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1, - $ WORK( 1+N2 ), 1 ) -* - ELSE -* -* 2-by-2 diagonal block -* - CALL DLALN2( .FALSE., 2, 2, SMIN, ONE, - $ T( J-1, J-1 ), LDT, ONE, ONE, - $ WORK( J-1+N ), N, WR, WI, X, 2, SCALE, - $ XNORM, IERR ) -* -* Scale X to avoid overflow when updating -* the right-hand side. -* - IF( XNORM.GT.ONE ) THEN - BETA = MAX( WORK( J-1 ), WORK( J ) ) - IF( BETA.GT.BIGNUM / XNORM ) THEN - REC = ONE / XNORM - X( 1, 1 ) = X( 1, 1 )*REC - X( 1, 2 ) = X( 1, 2 )*REC - X( 2, 1 ) = X( 2, 1 )*REC - X( 2, 2 ) = X( 2, 2 )*REC - SCALE = SCALE*REC - END IF - END IF -* -* Scale if necessary -* - IF( SCALE.NE.ONE ) THEN - CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) - CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) - END IF - WORK( J-1+N ) = X( 1, 1 ) - WORK( J+N ) = X( 2, 1 ) - WORK( J-1+N2 ) = X( 1, 2 ) - WORK( J+N2 ) = X( 2, 2 ) -* -* Update the right-hand side -* - CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, - $ WORK( 1+N ), 1 ) - CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, - $ WORK( 1+N ), 1 ) - CALL DAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1, - $ WORK( 1+N2 ), 1 ) - CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1, - $ WORK( 1+N2 ), 1 ) - END IF - 90 CONTINUE -* -* Copy the vector x or Q*x to VR and normalize. -* - IF( .NOT.OVER ) THEN - CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS-1 ), 1 ) - CALL DCOPY( KI, WORK( 1+N2 ), 1, VR( 1, IS ), 1 ) -* - EMAX = ZERO - DO 100 K = 1, KI - EMAX = MAX( EMAX, ABS( VR( K, IS-1 ) )+ - $ ABS( VR( K, IS ) ) ) - 100 CONTINUE -* - REMAX = ONE / EMAX - CALL DSCAL( KI, REMAX, VR( 1, IS-1 ), 1 ) - CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 ) -* - DO 110 K = KI + 1, N - VR( K, IS-1 ) = ZERO - VR( K, IS ) = ZERO - 110 CONTINUE -* - ELSE -* - IF( KI.GT.2 ) THEN - CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, - $ WORK( 1+N ), 1, WORK( KI-1+N ), - $ VR( 1, KI-1 ), 1 ) - CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, - $ WORK( 1+N2 ), 1, WORK( KI+N2 ), - $ VR( 1, KI ), 1 ) - ELSE - CALL DSCAL( N, WORK( KI-1+N ), VR( 1, KI-1 ), 1 ) - CALL DSCAL( N, WORK( KI+N2 ), VR( 1, KI ), 1 ) - END IF -* - EMAX = ZERO - DO 120 K = 1, N - EMAX = MAX( EMAX, ABS( VR( K, KI-1 ) )+ - $ ABS( VR( K, KI ) ) ) - 120 CONTINUE - REMAX = ONE / EMAX - CALL DSCAL( N, REMAX, VR( 1, KI-1 ), 1 ) - CALL DSCAL( N, REMAX, VR( 1, KI ), 1 ) - END IF - END IF -* - IS = IS - 1 - IF( IP.NE.0 ) - $ IS = IS - 1 - 130 CONTINUE - IF( IP.EQ.1 ) - $ IP = 0 - IF( IP.EQ.-1 ) - $ IP = 1 - 140 CONTINUE - END IF -* - IF( LEFTV ) THEN -* -* Compute left eigenvectors. -* - IP = 0 - IS = 1 - DO 260 KI = 1, N -* - IF( IP.EQ.-1 ) - $ GO TO 250 - IF( KI.EQ.N ) - $ GO TO 150 - IF( T( KI+1, KI ).EQ.ZERO ) - $ GO TO 150 - IP = 1 -* - 150 CONTINUE - IF( SOMEV ) THEN - IF( .NOT.SELECT( KI ) ) - $ GO TO 250 - END IF -* -* Compute the KI-th eigenvalue (WR,WI). -* - WR = T( KI, KI ) - WI = ZERO - IF( IP.NE.0 ) - $ WI = SQRT( ABS( T( KI, KI+1 ) ) )* - $ SQRT( ABS( T( KI+1, KI ) ) ) - SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) -* - IF( IP.EQ.0 ) THEN -* -* Real left eigenvector. -* - WORK( KI+N ) = ONE -* -* Form right-hand side -* - DO 160 K = KI + 1, N - WORK( K+N ) = -T( KI, K ) - 160 CONTINUE -* -* Solve the quasi-triangular system: -* (T(KI+1:N,KI+1:N) - WR)**T*X = SCALE*WORK -* - VMAX = ONE - VCRIT = BIGNUM -* - JNXT = KI + 1 - DO 170 J = KI + 1, N - IF( J.LT.JNXT ) - $ GO TO 170 - J1 = J - J2 = J - JNXT = J + 1 - IF( J.LT.N ) THEN - IF( T( J+1, J ).NE.ZERO ) THEN - J2 = J + 1 - JNXT = J + 2 - END IF - END IF -* - IF( J1.EQ.J2 ) THEN -* -* 1-by-1 diagonal block -* -* Scale if necessary to avoid overflow when forming -* the right-hand side. -* - IF( WORK( J ).GT.VCRIT ) THEN - REC = ONE / VMAX - CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) - VMAX = ONE - VCRIT = BIGNUM - END IF -* - WORK( J+N ) = WORK( J+N ) - - $ DDOT( J-KI-1, T( KI+1, J ), 1, - $ WORK( KI+1+N ), 1 ) -* -* Solve (T(J,J)-WR)**T*X = WORK -* - CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), - $ LDT, ONE, ONE, WORK( J+N ), N, WR, - $ ZERO, X, 2, SCALE, XNORM, IERR ) -* -* Scale if necessary -* - IF( SCALE.NE.ONE ) - $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) - WORK( J+N ) = X( 1, 1 ) - VMAX = MAX( ABS( WORK( J+N ) ), VMAX ) - VCRIT = BIGNUM / VMAX -* - ELSE -* -* 2-by-2 diagonal block -* -* Scale if necessary to avoid overflow when forming -* the right-hand side. -* - BETA = MAX( WORK( J ), WORK( J+1 ) ) - IF( BETA.GT.VCRIT ) THEN - REC = ONE / VMAX - CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) - VMAX = ONE - VCRIT = BIGNUM - END IF -* - WORK( J+N ) = WORK( J+N ) - - $ DDOT( J-KI-1, T( KI+1, J ), 1, - $ WORK( KI+1+N ), 1 ) -* - WORK( J+1+N ) = WORK( J+1+N ) - - $ DDOT( J-KI-1, T( KI+1, J+1 ), 1, - $ WORK( KI+1+N ), 1 ) -* -* Solve -* [T(J,J)-WR T(J,J+1) ]**T * X = SCALE*( WORK1 ) -* [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 ) -* - CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J, J ), - $ LDT, ONE, ONE, WORK( J+N ), N, WR, - $ ZERO, X, 2, SCALE, XNORM, IERR ) -* -* Scale if necessary -* - IF( SCALE.NE.ONE ) - $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) - WORK( J+N ) = X( 1, 1 ) - WORK( J+1+N ) = X( 2, 1 ) -* - VMAX = MAX( ABS( WORK( J+N ) ), - $ ABS( WORK( J+1+N ) ), VMAX ) - VCRIT = BIGNUM / VMAX -* - END IF - 170 CONTINUE -* -* Copy the vector x or Q*x to VL and normalize. -* - IF( .NOT.OVER ) THEN - CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) -* - II = IDAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 - REMAX = ONE / ABS( VL( II, IS ) ) - CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) -* - DO 180 K = 1, KI - 1 - VL( K, IS ) = ZERO - 180 CONTINUE -* - ELSE -* - IF( KI.LT.N ) - $ CALL DGEMV( 'N', N, N-KI, ONE, VL( 1, KI+1 ), LDVL, - $ WORK( KI+1+N ), 1, WORK( KI+N ), - $ VL( 1, KI ), 1 ) -* - II = IDAMAX( N, VL( 1, KI ), 1 ) - REMAX = ONE / ABS( VL( II, KI ) ) - CALL DSCAL( N, REMAX, VL( 1, KI ), 1 ) -* - END IF -* - ELSE -* -* Complex left eigenvector. -* -* Initial solve: -* ((T(KI,KI) T(KI,KI+1) )**T - (WR - I* WI))*X = 0. -* ((T(KI+1,KI) T(KI+1,KI+1)) ) -* - IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN - WORK( KI+N ) = WI / T( KI, KI+1 ) - WORK( KI+1+N2 ) = ONE - ELSE - WORK( KI+N ) = ONE - WORK( KI+1+N2 ) = -WI / T( KI+1, KI ) - END IF - WORK( KI+1+N ) = ZERO - WORK( KI+N2 ) = ZERO -* -* Form right-hand side -* - DO 190 K = KI + 2, N - WORK( K+N ) = -WORK( KI+N )*T( KI, K ) - WORK( K+N2 ) = -WORK( KI+1+N2 )*T( KI+1, K ) - 190 CONTINUE -* -* Solve complex quasi-triangular system: -* ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2 -* - VMAX = ONE - VCRIT = BIGNUM -* - JNXT = KI + 2 - DO 200 J = KI + 2, N - IF( J.LT.JNXT ) - $ GO TO 200 - J1 = J - J2 = J - JNXT = J + 1 - IF( J.LT.N ) THEN - IF( T( J+1, J ).NE.ZERO ) THEN - J2 = J + 1 - JNXT = J + 2 - END IF - END IF -* - IF( J1.EQ.J2 ) THEN -* -* 1-by-1 diagonal block -* -* Scale if necessary to avoid overflow when -* forming the right-hand side elements. -* - IF( WORK( J ).GT.VCRIT ) THEN - REC = ONE / VMAX - CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) - CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) - VMAX = ONE - VCRIT = BIGNUM - END IF -* - WORK( J+N ) = WORK( J+N ) - - $ DDOT( J-KI-2, T( KI+2, J ), 1, - $ WORK( KI+2+N ), 1 ) - WORK( J+N2 ) = WORK( J+N2 ) - - $ DDOT( J-KI-2, T( KI+2, J ), 1, - $ WORK( KI+2+N2 ), 1 ) -* -* Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2 -* - CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), - $ LDT, ONE, ONE, WORK( J+N ), N, WR, - $ -WI, X, 2, SCALE, XNORM, IERR ) -* -* Scale if necessary -* - IF( SCALE.NE.ONE ) THEN - CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) - CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) - END IF - WORK( J+N ) = X( 1, 1 ) - WORK( J+N2 ) = X( 1, 2 ) - VMAX = MAX( ABS( WORK( J+N ) ), - $ ABS( WORK( J+N2 ) ), VMAX ) - VCRIT = BIGNUM / VMAX -* - ELSE -* -* 2-by-2 diagonal block -* -* Scale if necessary to avoid overflow when forming -* the right-hand side elements. -* - BETA = MAX( WORK( J ), WORK( J+1 ) ) - IF( BETA.GT.VCRIT ) THEN - REC = ONE / VMAX - CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) - CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) - VMAX = ONE - VCRIT = BIGNUM - END IF -* - WORK( J+N ) = WORK( J+N ) - - $ DDOT( J-KI-2, T( KI+2, J ), 1, - $ WORK( KI+2+N ), 1 ) -* - WORK( J+N2 ) = WORK( J+N2 ) - - $ DDOT( J-KI-2, T( KI+2, J ), 1, - $ WORK( KI+2+N2 ), 1 ) -* - WORK( J+1+N ) = WORK( J+1+N ) - - $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, - $ WORK( KI+2+N ), 1 ) -* - WORK( J+1+N2 ) = WORK( J+1+N2 ) - - $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, - $ WORK( KI+2+N2 ), 1 ) -* -* Solve 2-by-2 complex linear equation -* ([T(j,j) T(j,j+1) ]**T-(wr-i*wi)*I)*X = SCALE*B -* ([T(j+1,j) T(j+1,j+1)] ) -* - CALL DLALN2( .TRUE., 2, 2, SMIN, ONE, T( J, J ), - $ LDT, ONE, ONE, WORK( J+N ), N, WR, - $ -WI, X, 2, SCALE, XNORM, IERR ) -* -* Scale if necessary -* - IF( SCALE.NE.ONE ) THEN - CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) - CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) - END IF - WORK( J+N ) = X( 1, 1 ) - WORK( J+N2 ) = X( 1, 2 ) - WORK( J+1+N ) = X( 2, 1 ) - WORK( J+1+N2 ) = X( 2, 2 ) - VMAX = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ), - $ ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ), VMAX ) - VCRIT = BIGNUM / VMAX -* - END IF - 200 CONTINUE -* -* Copy the vector x or Q*x to VL and normalize. -* - IF( .NOT.OVER ) THEN - CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) - CALL DCOPY( N-KI+1, WORK( KI+N2 ), 1, VL( KI, IS+1 ), - $ 1 ) -* - EMAX = ZERO - DO 220 K = KI, N - EMAX = MAX( EMAX, ABS( VL( K, IS ) )+ - $ ABS( VL( K, IS+1 ) ) ) - 220 CONTINUE - REMAX = ONE / EMAX - CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) - CALL DSCAL( N-KI+1, REMAX, VL( KI, IS+1 ), 1 ) -* - DO 230 K = 1, KI - 1 - VL( K, IS ) = ZERO - VL( K, IS+1 ) = ZERO - 230 CONTINUE - ELSE - IF( KI.LT.N-1 ) THEN - CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), - $ LDVL, WORK( KI+2+N ), 1, WORK( KI+N ), - $ VL( 1, KI ), 1 ) - CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), - $ LDVL, WORK( KI+2+N2 ), 1, - $ WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 ) - ELSE - CALL DSCAL( N, WORK( KI+N ), VL( 1, KI ), 1 ) - CALL DSCAL( N, WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 ) - END IF -* - EMAX = ZERO - DO 240 K = 1, N - EMAX = MAX( EMAX, ABS( VL( K, KI ) )+ - $ ABS( VL( K, KI+1 ) ) ) - 240 CONTINUE - REMAX = ONE / EMAX - CALL DSCAL( N, REMAX, VL( 1, KI ), 1 ) - CALL DSCAL( N, REMAX, VL( 1, KI+1 ), 1 ) -* - END IF -* - END IF -* - IS = IS + 1 - IF( IP.NE.0 ) - $ IS = IS + 1 - 250 CONTINUE - IF( IP.EQ.-1 ) - $ IP = 0 - IF( IP.EQ.1 ) - $ IP = -1 -* - 260 CONTINUE -* - END IF -* - RETURN -* -* End of DTREVC -* - END diff --git a/mtx/lapack_src/dtrexc.f b/mtx/lapack_src/dtrexc.f deleted file mode 100644 index 4ac8d9d59..000000000 --- a/mtx/lapack_src/dtrexc.f +++ /dev/null @@ -1,426 +0,0 @@ -*> \brief \b DTREXC -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DTREXC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, -* INFO ) -* -* .. Scalar Arguments .. -* CHARACTER COMPQ -* INTEGER IFST, ILST, INFO, LDQ, LDT, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DTREXC reorders the real Schur factorization of a real matrix -*> A = Q*T*Q**T, so that the diagonal block of T with row index IFST is -*> moved to row ILST. -*> -*> The real Schur form T is reordered by an orthogonal similarity -*> transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors -*> is updated by postmultiplying it with Z. -*> -*> T must be in Schur canonical form (as returned by DHSEQR), that is, -*> block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each -*> 2-by-2 diagonal block has its diagonal elements equal and its -*> off-diagonal elements of opposite sign. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] COMPQ -*> \verbatim -*> COMPQ is CHARACTER*1 -*> = 'V': update the matrix Q of Schur vectors; -*> = 'N': do not update Q. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix T. N >= 0. -*> \endverbatim -*> -*> \param[in,out] T -*> \verbatim -*> T is DOUBLE PRECISION array, dimension (LDT,N) -*> On entry, the upper quasi-triangular matrix T, in Schur -*> Schur canonical form. -*> On exit, the reordered upper quasi-triangular matrix, again -*> in Schur canonical form. -*> \endverbatim -*> -*> \param[in] LDT -*> \verbatim -*> LDT is INTEGER -*> The leading dimension of the array T. LDT >= max(1,N). -*> \endverbatim -*> -*> \param[in,out] Q -*> \verbatim -*> Q is DOUBLE PRECISION array, dimension (LDQ,N) -*> On entry, if COMPQ = 'V', the matrix Q of Schur vectors. -*> On exit, if COMPQ = 'V', Q has been postmultiplied by the -*> orthogonal transformation matrix Z which reorders T. -*> If COMPQ = 'N', Q is not referenced. -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max(1,N). -*> \endverbatim -*> -*> \param[in,out] IFST -*> \verbatim -*> IFST is INTEGER -*> \endverbatim -*> -*> \param[in,out] ILST -*> \verbatim -*> ILST is INTEGER -*> -*> Specify the reordering of the diagonal blocks of T. -*> The block with row index IFST is moved to row ILST, by a -*> sequence of transpositions between adjacent blocks. -*> On exit, if IFST pointed on entry to the second row of a -*> 2-by-2 block, it is changed to point to the first row; ILST -*> always points to the first row of the block in its final -*> position (which may differ from its input value by +1 or -1). -*> 1 <= IFST <= N; 1 <= ILST <= N. -*> \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 -*> = 1: two adjacent blocks were too close to swap (the problem -*> is very ill-conditioned); T may have been partially -*> reordered, and ILST points to the first row of the -*> current position of the block being moved. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, - $ INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER COMPQ - INTEGER IFST, ILST, INFO, LDQ, LDT, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL WANTQ - INTEGER HERE, NBF, NBL, NBNEXT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLAEXC, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Decode and test the input arguments. -* - INFO = 0 - WANTQ = LSAME( COMPQ, 'V' ) - IF( .NOT.WANTQ .AND. .NOT.LSAME( COMPQ, 'N' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN - INFO = -6 - ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN - INFO = -7 - ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTREXC', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.1 ) - $ RETURN -* -* Determine the first row of specified block -* and find out it is 1 by 1 or 2 by 2. -* - IF( IFST.GT.1 ) THEN - IF( T( IFST, IFST-1 ).NE.ZERO ) - $ IFST = IFST - 1 - END IF - NBF = 1 - IF( IFST.LT.N ) THEN - IF( T( IFST+1, IFST ).NE.ZERO ) - $ NBF = 2 - END IF -* -* Determine the first row of the final block -* and find out it is 1 by 1 or 2 by 2. -* - IF( ILST.GT.1 ) THEN - IF( T( ILST, ILST-1 ).NE.ZERO ) - $ ILST = ILST - 1 - END IF - NBL = 1 - IF( ILST.LT.N ) THEN - IF( T( ILST+1, ILST ).NE.ZERO ) - $ NBL = 2 - END IF -* - IF( IFST.EQ.ILST ) - $ RETURN -* - IF( IFST.LT.ILST ) THEN -* -* Update ILST -* - IF( NBF.EQ.2 .AND. NBL.EQ.1 ) - $ ILST = ILST - 1 - IF( NBF.EQ.1 .AND. NBL.EQ.2 ) - $ ILST = ILST + 1 -* - HERE = IFST -* - 10 CONTINUE -* -* Swap block with next one below -* - IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN -* -* Current block either 1 by 1 or 2 by 2 -* - NBNEXT = 1 - IF( HERE+NBF+1.LE.N ) THEN - IF( T( HERE+NBF+1, HERE+NBF ).NE.ZERO ) - $ NBNEXT = 2 - END IF - CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBF, NBNEXT, - $ WORK, INFO ) - IF( INFO.NE.0 ) THEN - ILST = HERE - RETURN - END IF - HERE = HERE + NBNEXT -* -* Test if 2 by 2 block breaks into two 1 by 1 blocks -* - IF( NBF.EQ.2 ) THEN - IF( T( HERE+1, HERE ).EQ.ZERO ) - $ NBF = 3 - END IF -* - ELSE -* -* Current block consists of two 1 by 1 blocks each of which -* must be swapped individually -* - NBNEXT = 1 - IF( HERE+3.LE.N ) THEN - IF( T( HERE+3, HERE+2 ).NE.ZERO ) - $ NBNEXT = 2 - END IF - CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, NBNEXT, - $ WORK, INFO ) - IF( INFO.NE.0 ) THEN - ILST = HERE - RETURN - END IF - IF( NBNEXT.EQ.1 ) THEN -* -* Swap two 1 by 1 blocks, no problems possible -* - CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, NBNEXT, - $ WORK, INFO ) - HERE = HERE + 1 - ELSE -* -* Recompute NBNEXT in case 2 by 2 split -* - IF( T( HERE+2, HERE+1 ).EQ.ZERO ) - $ NBNEXT = 1 - IF( NBNEXT.EQ.2 ) THEN -* -* 2 by 2 Block did not split -* - CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, - $ NBNEXT, WORK, INFO ) - IF( INFO.NE.0 ) THEN - ILST = HERE - RETURN - END IF - HERE = HERE + 2 - ELSE -* -* 2 by 2 Block did split -* - CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1, - $ WORK, INFO ) - CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, 1, - $ WORK, INFO ) - HERE = HERE + 2 - END IF - END IF - END IF - IF( HERE.LT.ILST ) - $ GO TO 10 -* - ELSE -* - HERE = IFST - 20 CONTINUE -* -* Swap block with next one above -* - IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN -* -* Current block either 1 by 1 or 2 by 2 -* - NBNEXT = 1 - IF( HERE.GE.3 ) THEN - IF( T( HERE-1, HERE-2 ).NE.ZERO ) - $ NBNEXT = 2 - END IF - CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT, - $ NBF, WORK, INFO ) - IF( INFO.NE.0 ) THEN - ILST = HERE - RETURN - END IF - HERE = HERE - NBNEXT -* -* Test if 2 by 2 block breaks into two 1 by 1 blocks -* - IF( NBF.EQ.2 ) THEN - IF( T( HERE+1, HERE ).EQ.ZERO ) - $ NBF = 3 - END IF -* - ELSE -* -* Current block consists of two 1 by 1 blocks each of which -* must be swapped individually -* - NBNEXT = 1 - IF( HERE.GE.3 ) THEN - IF( T( HERE-1, HERE-2 ).NE.ZERO ) - $ NBNEXT = 2 - END IF - CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT, - $ 1, WORK, INFO ) - IF( INFO.NE.0 ) THEN - ILST = HERE - RETURN - END IF - IF( NBNEXT.EQ.1 ) THEN -* -* Swap two 1 by 1 blocks, no problems possible -* - CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBNEXT, 1, - $ WORK, INFO ) - HERE = HERE - 1 - ELSE -* -* Recompute NBNEXT in case 2 by 2 split -* - IF( T( HERE, HERE-1 ).EQ.ZERO ) - $ NBNEXT = 1 - IF( NBNEXT.EQ.2 ) THEN -* -* 2 by 2 Block did not split -* - CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 2, 1, - $ WORK, INFO ) - IF( INFO.NE.0 ) THEN - ILST = HERE - RETURN - END IF - HERE = HERE - 2 - ELSE -* -* 2 by 2 Block did split -* - CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1, - $ WORK, INFO ) - CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 1, 1, - $ WORK, INFO ) - HERE = HERE - 2 - END IF - END IF - END IF - IF( HERE.GT.ILST ) - $ GO TO 20 - END IF - ILST = HERE -* - RETURN -* -* End of DTREXC -* - END diff --git a/mtx/lapack_src/dtrmm.f b/mtx/lapack_src/dtrmm.f deleted file mode 100644 index fc03769f2..000000000 --- a/mtx/lapack_src/dtrmm.f +++ /dev/null @@ -1,349 +0,0 @@ - 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,*) -* .. -* -* Purpose -* ======= -* -* 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. -* -* Arguments -* ========== -* -* SIDE - 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 ). -* -* Unchanged on exit. -* -* UPLO - 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. -* -* Unchanged on exit. -* -* TRANSA - 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. -* -* Unchanged on exit. -* -* DIAG - 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. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - 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. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of 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. -* Unchanged on exit. -* -* LDA - 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 ). -* Unchanged on exit. -* -* B - DOUBLE PRECISION array of 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. -* -* LDB - 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 ). -* Unchanged on exit. -* -* Further Details -* =============== -* -* 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. -* -* ===================================================================== -* -* .. 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/mtx/lapack_src/dtrmv.f b/mtx/lapack_src/dtrmv.f deleted file mode 100644 index 5356cbbc2..000000000 --- a/mtx/lapack_src/dtrmv.f +++ /dev/null @@ -1,282 +0,0 @@ - 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(*) -* .. -* -* Purpose -* ======= -* -* 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. -* -* Arguments -* ========== -* -* UPLO - 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. -* -* Unchanged on exit. -* -* TRANS - 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. -* -* Unchanged on exit. -* -* DIAG - 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. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of 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. -* Unchanged on exit. -* -* LDA - 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 ). -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Further Details -* =============== -* -* 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. -* -* ===================================================================== -* -* .. 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/mtx/lapack_src/dtrti2.f b/mtx/lapack_src/dtrti2.f deleted file mode 100644 index bc5a388d7..000000000 --- a/mtx/lapack_src/dtrti2.f +++ /dev/null @@ -1,212 +0,0 @@ -*> \brief \b DTRTI2 -* -* =========== 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. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER 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/mtx/lapack_src/dtrtri.f b/mtx/lapack_src/dtrtri.f deleted file mode 100644 index 5d27ca56a..000000000 --- a/mtx/lapack_src/dtrtri.f +++ /dev/null @@ -1,242 +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. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER 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/mtx/lapack_src/dtrtrs.f b/mtx/lapack_src/dtrtrs.f deleted file mode 100644 index 416a66e7c..000000000 --- a/mtx/lapack_src/dtrtrs.f +++ /dev/null @@ -1,226 +0,0 @@ -*> \brief \b DTRTRS -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DTRTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, -* INFO ) -* -* .. Scalar Arguments .. -* CHARACTER DIAG, TRANS, UPLO -* INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DTRTRS solves a triangular system of the form -*> -*> A * X = B or A**T * X = B, -*> -*> where A is a triangular matrix of order N, and B is an N-by-NRHS -*> matrix. A check is made to verify that A is nonsingular. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': A is upper triangular; -*> = 'L': A is lower triangular. -*> \endverbatim -*> -*> \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**H * X = B (Conjugate transpose = Transpose) -*> \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] 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 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] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) -*> On entry, the right hand side matrix B. -*> On exit, if INFO = 0, 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 -*> > 0: if INFO = i, the i-th diagonal element of A is zero, -*> indicating that the matrix is singular and the solutions -*> X have not been computed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, - $ INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER DIAG, TRANS, UPLO - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NOUNIT = LSAME( DIAG, 'N' ) - 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.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTRTRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Check for singularity. -* - IF( NOUNIT ) THEN - DO 10 INFO = 1, N - IF( A( INFO, INFO ).EQ.ZERO ) - $ RETURN - 10 CONTINUE - END IF - INFO = 0 -* -* Solve A * x = b or A**T * x = b. -* - CALL DTRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B, - $ LDB ) -* - RETURN -* -* End of DTRTRS -* - END diff --git a/mtx/lapack_src/icmax1.f b/mtx/lapack_src/icmax1.f deleted file mode 100644 index ffc80c822..000000000 --- a/mtx/lapack_src/icmax1.f +++ /dev/null @@ -1,154 +0,0 @@ -*> \brief \b ICMAX1 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ICMAX1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION ICMAX1( N, CX, INCX ) -* -* .. Scalar Arguments .. -* INTEGER INCX, N -* .. -* .. Array Arguments .. -* COMPLEX CX( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ICMAX1 finds the index of the element whose real part has maximum -*> absolute value. -*> -*> Based on ICAMAX from Level 1 BLAS. -*> The change is to use the 'genuine' absolute value. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of elements in the vector CX. -*> \endverbatim -*> -*> \param[in] CX -*> \verbatim -*> CX is COMPLEX array, dimension (N) -*> The vector whose elements will be summed. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> The spacing between successive values of CX. INCX >= 1. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup complexOTHERauxiliary -* -*> \par Contributors: -* ================== -*> -*> Nick Higham for use with CLACON. -* -* ===================================================================== - INTEGER FUNCTION ICMAX1( N, CX, INCX ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INCX, N -* .. -* .. Array Arguments .. - COMPLEX CX( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IX - REAL SMAX - COMPLEX ZDUM -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Statement Functions .. - REAL CABS1 -* .. -* .. Statement Function definitions .. -* -* NEXT LINE IS THE ONLY MODIFICATION. - CABS1( ZDUM ) = ABS( ZDUM ) -* .. -* .. Executable Statements .. -* - ICMAX1 = 0 - IF( N.LT.1 ) - $ RETURN - ICMAX1 = 1 - IF( N.EQ.1 ) - $ RETURN - IF( INCX.EQ.1 ) - $ GO TO 30 -* -* CODE FOR INCREMENT NOT EQUAL TO 1 -* - IX = 1 - SMAX = CABS1( CX( 1 ) ) - IX = IX + INCX - DO 20 I = 2, N - IF( CABS1( CX( IX ) ).LE.SMAX ) - $ GO TO 10 - ICMAX1 = I - SMAX = CABS1( CX( IX ) ) - 10 CONTINUE - IX = IX + INCX - 20 CONTINUE - RETURN -* -* CODE FOR INCREMENT EQUAL TO 1 -* - 30 CONTINUE - SMAX = CABS1( CX( 1 ) ) - DO 40 I = 2, N - IF( CABS1( CX( I ) ).LE.SMAX ) - $ GO TO 40 - ICMAX1 = I - SMAX = CABS1( CX( I ) ) - 40 CONTINUE - RETURN -* -* End of ICMAX1 -* - END diff --git a/mtx/lapack_src/ieeeck.f b/mtx/lapack_src/ieeeck.f deleted file mode 100644 index 132e43677..000000000 --- a/mtx/lapack_src/ieeeck.f +++ /dev/null @@ -1,203 +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 inifinity 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. -* -*> \date November 2011 -* -*> \ingroup auxOTHERauxiliary -* -* ===================================================================== - INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER 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/mtx/lapack_src/ilaclc.f b/mtx/lapack_src/ilaclc.f deleted file mode 100644 index 4ceb61c52..000000000 --- a/mtx/lapack_src/ilaclc.f +++ /dev/null @@ -1,118 +0,0 @@ -*> \brief \b ILACLC -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ILACLC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION ILACLC( M, N, A, LDA ) -* -* .. Scalar Arguments .. -* INTEGER M, N, LDA -* .. -* .. Array Arguments .. -* COMPLEX A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ILACLC scans A for its last non-zero column. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX array, dimension (LDA,N) -*> The m by n matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup complexOTHERauxiliary -* -* ===================================================================== - INTEGER FUNCTION ILACLC( M, N, A, LDA ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - COMPLEX A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = (0.0E+0, 0.0E+0) ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( N.EQ.0 ) THEN - ILACLC = N - ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILACLC = N - ELSE -* Now scan each column from the end, returning with the first non-zero. - DO ILACLC = N, 1, -1 - DO I = 1, M - IF( A(I, ILACLC).NE.ZERO ) RETURN - END DO - END DO - END IF - RETURN - END diff --git a/mtx/lapack_src/ilaclr.f b/mtx/lapack_src/ilaclr.f deleted file mode 100644 index d8ab09c55..000000000 --- a/mtx/lapack_src/ilaclr.f +++ /dev/null @@ -1,121 +0,0 @@ -*> \brief \b ILACLR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ILACLR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION ILACLR( M, N, A, LDA ) -* -* .. Scalar Arguments .. -* INTEGER M, N, LDA -* .. -* .. Array Arguments .. -* COMPLEX A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ILACLR scans A for its last non-zero row. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is array, dimension (LDA,N) -*> The m by n matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date April 2012 -* -*> \ingroup complexOTHERauxiliary -* -* ===================================================================== - INTEGER FUNCTION ILACLR( M, N, A, LDA ) -* -* -- LAPACK auxiliary routine (version 3.4.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - COMPLEX A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = (0.0E+0, 0.0E+0) ) -* .. -* .. Local Scalars .. - INTEGER I, J -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( M.EQ.0 ) THEN - ILACLR = M - ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILACLR = M - ELSE -* Scan up each column tracking the last zero row seen. - ILACLR = 0 - DO J = 1, N - I=M - DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) - I=I-1 - ENDDO - ILACLR = MAX( ILACLR, I ) - END DO - END IF - RETURN - END diff --git a/mtx/lapack_src/iladiag.f b/mtx/lapack_src/iladiag.f deleted file mode 100644 index 1d5c5bff1..000000000 --- a/mtx/lapack_src/iladiag.f +++ /dev/null @@ -1,92 +0,0 @@ -*> \brief \b ILADIAG -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ILADIAG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION ILADIAG( DIAG ) -* -* .. Scalar Arguments .. -* CHARACTER DIAG -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> This subroutine translated from a character string specifying if a -*> matrix has unit diagonal or not to the relevant BLAST-specified -*> integer constant. -*> -*> ILADIAG returns an INTEGER. If ILADIAG < 0, then the input is not a -*> character indicating a unit or non-unit diagonal. Otherwise ILADIAG -*> returns the constant value corresponding to DIAG. -*> \endverbatim -* -* Arguments: -* ========== -* -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - INTEGER FUNCTION ILADIAG( DIAG ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER DIAG -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER BLAS_NON_UNIT_DIAG, BLAS_UNIT_DIAG - PARAMETER ( BLAS_NON_UNIT_DIAG = 131, BLAS_UNIT_DIAG = 132 ) -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. - IF( LSAME( DIAG, 'N' ) ) THEN - ILADIAG = BLAS_NON_UNIT_DIAG - ELSE IF( LSAME( DIAG, 'U' ) ) THEN - ILADIAG = BLAS_UNIT_DIAG - ELSE - ILADIAG = -1 - END IF - RETURN -* -* End of ILADIAG -* - END diff --git a/mtx/lapack_src/iladlc.f b/mtx/lapack_src/iladlc.f deleted file mode 100644 index f84bd833a..000000000 --- a/mtx/lapack_src/iladlc.f +++ /dev/null @@ -1,118 +0,0 @@ -*> \brief \b ILADLC -* -* =========== 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. -* -*> \date November 2011 -* -*> \ingroup auxOTHERauxiliary -* -* ===================================================================== - INTEGER FUNCTION ILADLC( M, N, A, LDA ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( N.EQ.0 ) THEN - ILADLC = N - ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILADLC = N - ELSE -* Now scan each column from the end, returning with the first non-zero. - DO ILADLC = N, 1, -1 - DO I = 1, M - IF( A(I, ILADLC).NE.ZERO ) RETURN - END DO - END DO - END IF - RETURN - END diff --git a/mtx/lapack_src/iladlr.f b/mtx/lapack_src/iladlr.f deleted file mode 100644 index 2114c6164..000000000 --- a/mtx/lapack_src/iladlr.f +++ /dev/null @@ -1,121 +0,0 @@ -*> \brief \b ILADLR -* -* =========== 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. -* -*> \date April 2012 -* -*> \ingroup auxOTHERauxiliary -* -* ===================================================================== - INTEGER FUNCTION ILADLR( M, N, A, LDA ) -* -* -- LAPACK auxiliary routine (version 3.4.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( M.EQ.0 ) THEN - ILADLR = M - ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILADLR = M - ELSE -* Scan up each column tracking the last zero row seen. - ILADLR = 0 - DO J = 1, N - I=M - DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) - I=I-1 - ENDDO - ILADLR = MAX( ILADLR, I ) - END DO - END IF - RETURN - END diff --git a/mtx/lapack_src/ilaenv.f b/mtx/lapack_src/ilaenv.f deleted file mode 100644 index 867464de3..000000000 --- a/mtx/lapack_src/ilaenv.f +++ /dev/null @@ -1,624 +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 NaN arithmetic can be trusted not to trap -*> =11: infinity arithmetic can be trusted not to trap -*> 12 <= ISPEC <= 16: -*> xHSEQR or one of its subroutines, -*> 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. -* -*> \date November 2011 -* -*> \ingroup auxOTHERauxiliary -* -*> \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 (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER*( * ) NAME, OPTS - INTEGER ISPEC, N1, N2, N3, N4 -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IC, IZ, NB, NBMIN, NX - LOGICAL CNAME, SNAME - CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6 -* .. -* .. 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 )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 ) -* - 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( 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.'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 - NB = 64 - ELSE - NB = 64 - 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 - NB = 64 - 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 - END IF - ELSE IF( C2.EQ.'LA' ) THEN - IF( C3.EQ.'UUM' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN - IF( C3.EQ.'EBZ' ) THEN - NB = 1 - 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 - 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 - 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 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: 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 <= 16: xHSEQR or one of its subroutines. -* - ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) - RETURN -* -* End of ILAENV -* - END diff --git a/mtx/lapack_src/ilaprec.f b/mtx/lapack_src/ilaprec.f deleted file mode 100644 index 88ae77e4d..000000000 --- a/mtx/lapack_src/ilaprec.f +++ /dev/null @@ -1,98 +0,0 @@ -*> \brief \b ILAPREC -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ILAPREC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION ILAPREC( PREC ) -* -* .. Scalar Arguments .. -* CHARACTER PREC -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> This subroutine translated from a character string specifying an -*> intermediate precision to the relevant BLAST-specified integer -*> constant. -*> -*> ILAPREC returns an INTEGER. If ILAPREC < 0, then the input is not a -*> character indicating a supported intermediate precision. Otherwise -*> ILAPREC returns the constant value corresponding to PREC. -*> \endverbatim -* -* Arguments: -* ========== -* -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - INTEGER FUNCTION ILAPREC( PREC ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER PREC -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER BLAS_PREC_SINGLE, BLAS_PREC_DOUBLE, BLAS_PREC_INDIGENOUS, - $ BLAS_PREC_EXTRA - PARAMETER ( BLAS_PREC_SINGLE = 211, BLAS_PREC_DOUBLE = 212, - $ BLAS_PREC_INDIGENOUS = 213, BLAS_PREC_EXTRA = 214 ) -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. - IF( LSAME( PREC, 'S' ) ) THEN - ILAPREC = BLAS_PREC_SINGLE - ELSE IF( LSAME( PREC, 'D' ) ) THEN - ILAPREC = BLAS_PREC_DOUBLE - ELSE IF( LSAME( PREC, 'I' ) ) THEN - ILAPREC = BLAS_PREC_INDIGENOUS - ELSE IF( LSAME( PREC, 'X' ) .OR. LSAME( PREC, 'E' ) ) THEN - ILAPREC = BLAS_PREC_EXTRA - ELSE - ILAPREC = -1 - END IF - RETURN -* -* End of ILAPREC -* - END diff --git a/mtx/lapack_src/ilaslc.f b/mtx/lapack_src/ilaslc.f deleted file mode 100644 index e3db0f4ae..000000000 --- a/mtx/lapack_src/ilaslc.f +++ /dev/null @@ -1,118 +0,0 @@ -*> \brief \b ILASLC -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ILASLC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION ILASLC( M, N, A, LDA ) -* -* .. Scalar Arguments .. -* INTEGER M, N, LDA -* .. -* .. Array Arguments .. -* REAL A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ILASLC scans A for its last non-zero column. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is REAL array, dimension (LDA,N) -*> The m by n matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup realOTHERauxiliary -* -* ===================================================================== - INTEGER FUNCTION ILASLC( M, N, A, LDA ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - REAL A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( N.EQ.0 ) THEN - ILASLC = N - ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILASLC = N - ELSE -* Now scan each column from the end, returning with the first non-zero. - DO ILASLC = N, 1, -1 - DO I = 1, M - IF( A(I, ILASLC).NE.ZERO ) RETURN - END DO - END DO - END IF - RETURN - END diff --git a/mtx/lapack_src/ilaslr.f b/mtx/lapack_src/ilaslr.f deleted file mode 100644 index 48b73f44d..000000000 --- a/mtx/lapack_src/ilaslr.f +++ /dev/null @@ -1,121 +0,0 @@ -*> \brief \b ILASLR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ILASLR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION ILASLR( M, N, A, LDA ) -* -* .. Scalar Arguments .. -* INTEGER M, N, LDA -* .. -* .. Array Arguments .. -* REAL A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ILASLR scans A for its last non-zero row. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is REAL array, dimension (LDA,N) -*> The m by n matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date April 2012 -* -*> \ingroup realOTHERauxiliary -* -* ===================================================================== - INTEGER FUNCTION ILASLR( M, N, A, LDA ) -* -* -- LAPACK auxiliary routine (version 3.4.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - REAL A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( M.EQ.0 ) THEN - ILASLR = M - ELSEIF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILASLR = M - ELSE -* Scan up each column tracking the last zero row seen. - ILASLR = 0 - DO J = 1, N - I=M - DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) - I=I-1 - ENDDO - ILASLR = MAX( ILASLR, I ) - END DO - END IF - RETURN - END diff --git a/mtx/lapack_src/ilatrans.f b/mtx/lapack_src/ilatrans.f deleted file mode 100644 index d8fc9bc64..000000000 --- a/mtx/lapack_src/ilatrans.f +++ /dev/null @@ -1,95 +0,0 @@ -*> \brief \b ILATRANS -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ILATRANS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION ILATRANS( TRANS ) -* -* .. Scalar Arguments .. -* CHARACTER TRANS -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> This subroutine translates from a character string specifying a -*> transposition operation to the relevant BLAST-specified integer -*> constant. -*> -*> ILATRANS returns an INTEGER. If ILATRANS < 0, then the input is not -*> a character indicating a transposition operator. Otherwise ILATRANS -*> returns the constant value corresponding to TRANS. -*> \endverbatim -* -* Arguments: -* ========== -* -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - INTEGER FUNCTION ILATRANS( TRANS ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER TRANS -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER BLAS_NO_TRANS, BLAS_TRANS, BLAS_CONJ_TRANS - PARAMETER ( BLAS_NO_TRANS = 111, BLAS_TRANS = 112, - $ BLAS_CONJ_TRANS = 113 ) -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. - IF( LSAME( TRANS, 'N' ) ) THEN - ILATRANS = BLAS_NO_TRANS - ELSE IF( LSAME( TRANS, 'T' ) ) THEN - ILATRANS = BLAS_TRANS - ELSE IF( LSAME( TRANS, 'C' ) ) THEN - ILATRANS = BLAS_CONJ_TRANS - ELSE - ILATRANS = -1 - END IF - RETURN -* -* End of ILATRANS -* - END diff --git a/mtx/lapack_src/ilauplo.f b/mtx/lapack_src/ilauplo.f deleted file mode 100644 index e65c103e7..000000000 --- a/mtx/lapack_src/ilauplo.f +++ /dev/null @@ -1,92 +0,0 @@ -*> \brief \b ILAUPLO -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ILAUPLO + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION ILAUPLO( UPLO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> This subroutine translated from a character string specifying a -*> upper- or lower-triangular matrix to the relevant BLAST-specified -*> integer constant. -*> -*> ILAUPLO returns an INTEGER. If ILAUPLO < 0, then the input is not -*> a character indicating an upper- or lower-triangular matrix. -*> Otherwise ILAUPLO returns the constant value corresponding to UPLO. -*> \endverbatim -* -* Arguments: -* ========== -* -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - INTEGER FUNCTION ILAUPLO( UPLO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER UPLO -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER BLAS_UPPER, BLAS_LOWER - PARAMETER ( BLAS_UPPER = 121, BLAS_LOWER = 122 ) -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. - IF( LSAME( UPLO, 'U' ) ) THEN - ILAUPLO = BLAS_UPPER - ELSE IF( LSAME( UPLO, 'L' ) ) THEN - ILAUPLO = BLAS_LOWER - ELSE - ILAUPLO = -1 - END IF - RETURN -* -* End of ILAUPLO -* - END diff --git a/mtx/lapack_src/ilaver.f b/mtx/lapack_src/ilaver.f deleted file mode 100644 index 56abb66a6..000000000 --- a/mtx/lapack_src/ilaver.f +++ /dev/null @@ -1,66 +0,0 @@ -*> \brief \b ILAVER returns the LAPACK version. -** -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) -* -* INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> This subroutine returns the LAPACK version. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[out] VERS_MAJOR -*> return the lapack major version -*> -*> \param[out] VERS_MINOR -*> return the lapack minor version from the major version -*> -*> \param[out] VERS_PATCH -*> return the lapack patch version from the minor version -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup auxOTHERauxiliary -* -* ===================================================================== - SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) -* -* -- LAPACK computational routine (version 3.4.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* ===================================================================== -* - INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH -* ===================================================================== - VERS_MAJOR = 3 - VERS_MINOR = 4 - VERS_PATCH = 1 -* ===================================================================== -* - RETURN - END diff --git a/mtx/lapack_src/ilazlc.f b/mtx/lapack_src/ilazlc.f deleted file mode 100644 index 15b149022..000000000 --- a/mtx/lapack_src/ilazlc.f +++ /dev/null @@ -1,118 +0,0 @@ -*> \brief \b ILAZLC -* -* =========== 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. -* -*> \date November 2011 -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - INTEGER FUNCTION ILAZLC( M, N, A, LDA ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = (0.0D+0, 0.0D+0) ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( N.EQ.0 ) THEN - ILAZLC = N - ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILAZLC = N - ELSE -* Now scan each column from the end, returning with the first non-zero. - DO ILAZLC = N, 1, -1 - DO I = 1, M - IF( A(I, ILAZLC).NE.ZERO ) RETURN - END DO - END DO - END IF - RETURN - END diff --git a/mtx/lapack_src/ilazlr.f b/mtx/lapack_src/ilazlr.f deleted file mode 100644 index b2ab943ca..000000000 --- a/mtx/lapack_src/ilazlr.f +++ /dev/null @@ -1,121 +0,0 @@ -*> \brief \b ILAZLR -* -* =========== 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. -* -*> \date April 2012 -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - INTEGER FUNCTION ILAZLR( M, N, A, LDA ) -* -* -- LAPACK auxiliary routine (version 3.4.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = (0.0D+0, 0.0D+0) ) -* .. -* .. Local Scalars .. - INTEGER I, J -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( M.EQ.0 ) THEN - ILAZLR = M - ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILAZLR = M - ELSE -* Scan up each column tracking the last zero row seen. - ILAZLR = 0 - DO J = 1, N - I=M - DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) - I=I-1 - ENDDO - ILAZLR = MAX( ILAZLR, I ) - END DO - END IF - RETURN - END diff --git a/mtx/lapack_src/iparmq.f b/mtx/lapack_src/iparmq.f deleted file mode 100644 index bd5bd7a0d..000000000 --- a/mtx/lapack_src/iparmq.f +++ /dev/null @@ -1,322 +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 its subroutines. It is called whenever -*> ILAENV is called with 12 <= ISPEC <= 16 -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ISPEC -*> \verbatim -*> ISPEC is integer scalar -*> 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.GT.(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 sweep, -*> xLAQR5 does not accumulate reflections and -*> does not use matrix-matrix multiply to -*> update the far-from-diagonal matrix -*> entries. -*> 1: During the multi-shift QR sweep, -*> xLAQR5 and/or xLAQRaccumulates reflections and uses -*> matrix-matrix multiply to update the -*> far-from-diagonal matrix entries. -*> 2: During the multi-shift QR sweep. -*> xLAQR5 accumulates reflections and takes -*> advantage of 2-by-2 block structure during -*> matrix-matrix multiplies. -*> (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.) -*> \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 scalar -*> 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 scalar -*> The amount of workspace available. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup auxOTHERauxiliary -* -*> \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).LE.500 is NS. The default -*> for (IHI-ILO+1).GT.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. -*> \endverbatim -*> -* ===================================================================== - INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER IHI, ILO, ISPEC, LWORK, N - CHARACTER NAME*( * ), OPTS*( * ) -* -* ================================================================ -* .. Parameters .. - INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 - PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, - $ ISHFTS = 15, IACC22 = 16 ) - INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP - PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, - $ NIBBLE = 14, KNWSWP = 500 ) - REAL TWO - PARAMETER ( TWO = 2.0 ) -* .. -* .. Local Scalars .. - INTEGER NH, NS -* .. -* .. 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. -* - IPARMQ = 0 - IF( NS.GE.KACMIN ) - $ IPARMQ = 1 - IF( NS.GE.K22MIN ) - $ IPARMQ = 2 -* - ELSE -* ===== invalid value of ispec ===== - IPARMQ = -1 -* - END IF -* -* ==== End of IPARMQ ==== -* - END diff --git a/mtx/lapack_src/izamax.f b/mtx/lapack_src/izamax.f deleted file mode 100644 index 9bd7fdd4c..000000000 --- a/mtx/lapack_src/izamax.f +++ /dev/null @@ -1,55 +0,0 @@ - INTEGER FUNCTION IZAMAX(N,ZX,INCX) -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE COMPLEX ZX(*) -* .. -* -* Purpose -* ======= -* -* finds the index of element having max. absolute value. -* jack dongarra, 1/15/85. -* modified 3/93 to return if incx .le. 0. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* -* .. Local Scalars .. - DOUBLE PRECISION SMAX - INTEGER I,IX -* .. -* .. External Functions .. - DOUBLE PRECISION DCABS1 - EXTERNAL DCABS1 -* .. - IZAMAX = 0 - IF (N.LT.1 .OR. INCX.LE.0) RETURN - IZAMAX = 1 - IF (N.EQ.1) RETURN - IF (INCX.EQ.1) GO TO 20 -* -* code for increment not equal to 1 -* - IX = 1 - SMAX = DCABS1(ZX(1)) - IX = IX + INCX - DO 10 I = 2,N - IF (DCABS1(ZX(IX)).LE.SMAX) GO TO 5 - IZAMAX = I - SMAX = DCABS1(ZX(IX)) - 5 IX = IX + INCX - 10 CONTINUE - RETURN -* -* code for increment equal to 1 -* - 20 SMAX = DCABS1(ZX(1)) - DO 30 I = 2,N - IF (DCABS1(ZX(I)).LE.SMAX) GO TO 30 - IZAMAX = I - SMAX = DCABS1(ZX(I)) - 30 CONTINUE - RETURN - END - diff --git a/mtx/lapack_src/izmax1.f b/mtx/lapack_src/izmax1.f deleted file mode 100644 index a156c923f..000000000 --- a/mtx/lapack_src/izmax1.f +++ /dev/null @@ -1,154 +0,0 @@ -*> \brief \b IZMAX1 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download IZMAX1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION IZMAX1( N, CX, INCX ) -* -* .. Scalar Arguments .. -* INTEGER INCX, N -* .. -* .. Array Arguments .. -* COMPLEX*16 CX( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> IZMAX1 finds the index of the element whose real part has maximum -*> absolute value. -*> -*> Based on IZAMAX from Level 1 BLAS. -*> The change is to use the 'genuine' absolute value. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of elements in the vector CX. -*> \endverbatim -*> -*> \param[in] CX -*> \verbatim -*> CX is COMPLEX*16 array, dimension (N) -*> The vector whose elements will be summed. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> The spacing between successive values of CX. INCX >= 1. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup complex16OTHERauxiliary -* -*> \par Contributors: -* ================== -*> -*> Nick Higham for use with ZLACON. -* -* ===================================================================== - INTEGER FUNCTION IZMAX1( N, CX, INCX ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INCX, N -* .. -* .. Array Arguments .. - COMPLEX*16 CX( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IX - DOUBLE PRECISION SMAX - COMPLEX*16 ZDUM -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Statement Functions .. - DOUBLE PRECISION CABS1 -* .. -* .. Statement Function definitions .. -* -* NEXT LINE IS THE ONLY MODIFICATION. - CABS1( ZDUM ) = ABS( ZDUM ) -* .. -* .. Executable Statements .. -* - IZMAX1 = 0 - IF( N.LT.1 ) - $ RETURN - IZMAX1 = 1 - IF( N.EQ.1 ) - $ RETURN - IF( INCX.EQ.1 ) - $ GO TO 30 -* -* CODE FOR INCREMENT NOT EQUAL TO 1 -* - IX = 1 - SMAX = CABS1( CX( 1 ) ) - IX = IX + INCX - DO 20 I = 2, N - IF( CABS1( CX( IX ) ).LE.SMAX ) - $ GO TO 10 - IZMAX1 = I - SMAX = CABS1( CX( IX ) ) - 10 CONTINUE - IX = IX + INCX - 20 CONTINUE - RETURN -* -* CODE FOR INCREMENT EQUAL TO 1 -* - 30 CONTINUE - SMAX = CABS1( CX( 1 ) ) - DO 40 I = 2, N - IF( CABS1( CX( I ) ).LE.SMAX ) - $ GO TO 40 - IZMAX1 = I - SMAX = CABS1( CX( I ) ) - 40 CONTINUE - RETURN -* -* End of IZMAX1 -* - END diff --git a/mtx/lapack_src/sgesv.f b/mtx/lapack_src/sgesv.f deleted file mode 100644 index 40509d3cd..000000000 --- a/mtx/lapack_src/sgesv.f +++ /dev/null @@ -1,179 +0,0 @@ -*> \brief SGESV computes the solution to system of linear equations A * X = B for GE matrices (simple driver) -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download SGESV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE SGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* REAL A( LDA, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> SGESV 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 REAL 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 REAL 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. -* -*> \date November 2011 -* -*> \ingroup realGEsolve -* -* ===================================================================== - SUBROUTINE SGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK driver routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - REAL A( LDA, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. External Subroutines .. - EXTERNAL SGETRF, SGETRS, 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( 'SGESV ', -INFO ) - RETURN - END IF -* -* Compute the LU factorization of A. -* - CALL SGETRF( N, N, A, LDA, IPIV, INFO ) - IF( INFO.EQ.0 ) THEN -* -* Solve the system A*X = B, overwriting B with X. -* - CALL SGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, - $ INFO ) - END IF - RETURN -* -* End of SGESV -* - END diff --git a/mtx/lapack_src/sgetf2.f b/mtx/lapack_src/sgetf2.f deleted file mode 100644 index 0cab948b5..000000000 --- a/mtx/lapack_src/sgetf2.f +++ /dev/null @@ -1,213 +0,0 @@ -*> \brief \b SGETF2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download SGETF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE SGETF2( M, N, A, LDA, IPIV, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* REAL A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> SGETF2 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 REAL 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. -* -*> \date November 2011 -* -*> \ingroup realGEcomputational -* -* ===================================================================== - SUBROUTINE SGETF2( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - REAL A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - REAL ONE, ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. -* .. Local Scalars .. - REAL SFMIN - INTEGER I, J, JP -* .. -* .. External Functions .. - REAL SLAMCH - INTEGER ISAMAX - EXTERNAL SLAMCH, ISAMAX -* .. -* .. External Subroutines .. - EXTERNAL SGER, SSCAL, SSWAP, 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( 'SGETF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Compute machine safe minimum -* - SFMIN = SLAMCH('S') -* - DO 10 J = 1, MIN( M, N ) -* -* Find pivot and test for singularity. -* - JP = J - 1 + ISAMAX( 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 SSWAP( 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 SSCAL( 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 SGER( 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 SGETF2 -* - END diff --git a/mtx/lapack_src/sgetrf.f b/mtx/lapack_src/sgetrf.f deleted file mode 100644 index b7ac344de..000000000 --- a/mtx/lapack_src/sgetrf.f +++ /dev/null @@ -1,225 +0,0 @@ -*> \brief \b SGETRF -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download SGETRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE SGETRF( M, N, A, LDA, IPIV, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* REAL A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> SGETRF 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 REAL array, dimension (LDA,N) -*> On entry, the M-by-N matrix to be factored. -*> On exit, the factors L and U from the factorization -*> A = P*L*U; the unit diagonal elements of L are not stored. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (min(M,N)) -*> The pivot indices; for 1 <= i <= min(M,N), row i of the -*> matrix was interchanged with row IPIV(i). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: if INFO = i, U(i,i) is exactly zero. The factorization -*> has been completed, but the factor U is exactly -*> singular, and division by zero will occur if it is used -*> to solve a system of equations. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup realGEcomputational -* -* ===================================================================== - SUBROUTINE SGETRF( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - REAL A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO, J, JB, NB -* .. -* .. External Subroutines .. - EXTERNAL SGEMM, SGETF2, SLASWP, STRSM, 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( 'SGETRF', -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, 'SGETRF', ' ', M, N, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN -* -* Use unblocked code. -* - CALL SGETF2( 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 SGETF2( 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 SLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) -* - IF( J+JB.LE.N ) THEN -* -* Apply interchanges to columns J+JB:N. -* - CALL SLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, - $ IPIV, 1 ) -* -* Compute block row of U. -* - CALL STRSM( '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 SGEMM( '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 SGETRF -* - END diff --git a/mtx/lapack_src/sgetrs.f b/mtx/lapack_src/sgetrs.f deleted file mode 100644 index caa45670c..000000000 --- a/mtx/lapack_src/sgetrs.f +++ /dev/null @@ -1,225 +0,0 @@ -*> \brief \b SGETRS -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download SGETRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE SGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER TRANS -* INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* REAL A( LDA, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> SGETRS 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 SGETRF. -*> \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 REAL array, dimension (LDA,N) -*> The factors L and U from the factorization A = P*L*U -*> as computed by SGETRF. -*> \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 SGETRF; for 1<=i<=N, row i of the -*> matrix was interchanged with row IPIV(i). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is REAL 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. -* -*> \date November 2011 -* -*> \ingroup realGEcomputational -* -* ===================================================================== - SUBROUTINE SGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - REAL A( LDA, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL SLASWP, STRSM, 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( 'SGETRS', -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 SLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) -* -* Solve L*X = B, overwriting B with X. -* - CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL STRSM( '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 STRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve L**T *X = B, overwriting B with X. -* - CALL STRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, - $ A, LDA, B, LDB ) -* -* Apply row interchanges to the solution vectors. -* - CALL SLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) - END IF -* - RETURN -* -* End of SGETRS -* - END diff --git a/mtx/lapack_src/slaswp.f b/mtx/lapack_src/slaswp.f deleted file mode 100644 index 6fba8d624..000000000 --- a/mtx/lapack_src/slaswp.f +++ /dev/null @@ -1,191 +0,0 @@ -*> \brief \b SLASWP -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download SLASWP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE SLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* -* .. Scalar Arguments .. -* INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* REAL A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> SLASWP 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 REAL 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 -*> The last element of IPIV for which a row interchange will -*> be done. -*> \endverbatim -*> -*> \param[in] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (K2*abs(INCX)) -*> The vector of pivot indices. Only the elements in positions -*> K1 through K2 of IPIV are accessed. -*> IPIV(K) = L implies rows K and L are to be interchanged. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> The increment between successive values of IPIV. If IPIV -*> 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. -* -*> \date November 2011 -* -*> \ingroup realOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Modified by -*> R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE SLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - REAL A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 - REAL TEMP -* .. -* .. Executable Statements .. -* -* Interchange row I with row IPIV(I) 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 = 1 + ( 1-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 SLASWP -* - END diff --git a/mtx/lapack_src/zcopy.f b/mtx/lapack_src/zcopy.f deleted file mode 100644 index f9a264f3d..000000000 --- a/mtx/lapack_src/zcopy.f +++ /dev/null @@ -1,44 +0,0 @@ - SUBROUTINE ZCOPY(N,ZX,INCX,ZY,INCY) -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE COMPLEX ZX(*),ZY(*) -* .. -* -* Purpose -* ======= -* -* copies a vector, x, to a vector, y. -* jack dongarra, linpack, 4/11/78. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* -* .. Local Scalars .. - INTEGER I,IX,IY -* .. - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20 -* -* 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 10 I = 1,N - ZY(IY) = ZX(IX) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -* -* code for both increments equal to 1 -* - 20 DO 30 I = 1,N - ZY(I) = ZX(I) - 30 CONTINUE - RETURN - END - diff --git a/mtx/lapack_src/zgbtf2.f b/mtx/lapack_src/zgbtf2.f deleted file mode 100644 index 508314c65..000000000 --- a/mtx/lapack_src/zgbtf2.f +++ /dev/null @@ -1,277 +0,0 @@ -*> \brief \b ZGBTF2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZGBTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, KL, KU, LDAB, M, N -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* COMPLEX*16 AB( LDAB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZGBTF2 computes an LU factorization of a complex m-by-n band matrix -*> A using partial pivoting with row interchanges. -*> -*> This is the unblocked version of the algorithm, calling Level 2 BLAS. -*> \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] KL -*> \verbatim -*> KL is INTEGER -*> The number of subdiagonals within the band of A. KL >= 0. -*> \endverbatim -*> -*> \param[in] KU -*> \verbatim -*> KU is INTEGER -*> The number of superdiagonals within the band of A. KU >= 0. -*> \endverbatim -*> -*> \param[in,out] AB -*> \verbatim -*> AB is COMPLEX*16 array, dimension (LDAB,N) -*> On entry, the matrix A in band storage, in rows KL+1 to -*> 2*KL+KU+1; rows 1 to KL of the array need not be set. -*> The j-th column of A is stored in the j-th column of the -*> array AB as follows: -*> AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) -*> -*> On exit, details of the factorization: U is stored as an -*> upper triangular band matrix with KL+KU superdiagonals in -*> rows 1 to KL+KU+1, and the multipliers used during the -*> factorization are stored in rows KL+KU+2 to 2*KL+KU+1. -*> See below for further details. -*> \endverbatim -*> -*> \param[in] LDAB -*> \verbatim -*> LDAB is INTEGER -*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1. -*> \endverbatim -*> -*> \param[out] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (min(M,N)) -*> The pivot indices; for 1 <= i <= min(M,N), row i of the -*> matrix was interchanged with row IPIV(i). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: if INFO = +i, U(i,i) is exactly zero. The factorization -*> has been completed, but the factor U is exactly -*> singular, and division by zero will occur if it is used -*> to solve a system of equations. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup complex16GBcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The band storage scheme is illustrated by the following example, when -*> M = N = 6, KL = 2, KU = 1: -*> -*> On entry: On exit: -*> -*> * * * + + + * * * u14 u25 u36 -*> * * + + + + * * u13 u24 u35 u46 -*> * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 -*> a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 -*> a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * -*> a31 a42 a53 a64 * * m31 m42 m53 m64 * * -*> -*> Array elements marked * are not used by the routine; elements marked -*> + need not be set on entry, but are required by the routine to store -*> elements of U, because of fill-in resulting from the row -*> interchanges. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INFO, KL, KU, LDAB, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 AB( LDAB, * ) -* .. -* -* ===================================================================== -* -* .. 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, JP, JU, KM, KV -* .. -* .. External Functions .. - INTEGER IZAMAX - EXTERNAL IZAMAX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZGERU, ZSCAL, ZSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* KV is the number of superdiagonals in the factor U, allowing for -* fill-in. -* - KV = KU + KL -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( KL.LT.0 ) THEN - INFO = -3 - ELSE IF( KU.LT.0 ) THEN - INFO = -4 - ELSE IF( LDAB.LT.KL+KV+1 ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGBTF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Gaussian elimination with partial pivoting -* -* Set fill-in elements in columns KU+2 to KV to zero. -* - DO 20 J = KU + 2, MIN( KV, N ) - DO 10 I = KV - J + 2, KL - AB( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE -* -* JU is the index of the last column affected by the current stage -* of the factorization. -* - JU = 1 -* - DO 40 J = 1, MIN( M, N ) -* -* Set fill-in elements in column J+KV to zero. -* - IF( J+KV.LE.N ) THEN - DO 30 I = 1, KL - AB( I, J+KV ) = ZERO - 30 CONTINUE - END IF -* -* Find pivot and test for singularity. KM is the number of -* subdiagonal elements in the current column. -* - KM = MIN( KL, M-J ) - JP = IZAMAX( KM+1, AB( KV+1, J ), 1 ) - IPIV( J ) = JP + J - 1 - IF( AB( KV+JP, J ).NE.ZERO ) THEN - JU = MAX( JU, MIN( J+KU+JP-1, N ) ) -* -* Apply interchange to columns J to JU. -* - IF( JP.NE.1 ) - $ CALL ZSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1, - $ AB( KV+1, J ), LDAB-1 ) - IF( KM.GT.0 ) THEN -* -* Compute multipliers. -* - CALL ZSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 ) -* -* Update trailing submatrix within the band. -* - IF( JU.GT.J ) - $ CALL ZGERU( KM, JU-J, -ONE, AB( KV+2, J ), 1, - $ AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ), - $ LDAB-1 ) - END IF - ELSE -* -* If pivot is zero, set INFO to the index of the pivot -* unless a zero pivot has already been found. -* - IF( INFO.EQ.0 ) - $ INFO = J - END IF - 40 CONTINUE - RETURN -* -* End of ZGBTF2 -* - END diff --git a/mtx/lapack_src/zgbtrf.f b/mtx/lapack_src/zgbtrf.f deleted file mode 100644 index bbdd986d4..000000000 --- a/mtx/lapack_src/zgbtrf.f +++ /dev/null @@ -1,517 +0,0 @@ -*> \brief \b ZGBTRF -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZGBTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, KL, KU, LDAB, M, N -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* COMPLEX*16 AB( LDAB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZGBTRF computes an LU factorization of a complex m-by-n band matrix A -*> using partial pivoting with row interchanges. -*> -*> This is the blocked version of the algorithm, calling Level 3 BLAS. -*> \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] KL -*> \verbatim -*> KL is INTEGER -*> The number of subdiagonals within the band of A. KL >= 0. -*> \endverbatim -*> -*> \param[in] KU -*> \verbatim -*> KU is INTEGER -*> The number of superdiagonals within the band of A. KU >= 0. -*> \endverbatim -*> -*> \param[in,out] AB -*> \verbatim -*> AB is COMPLEX*16 array, dimension (LDAB,N) -*> On entry, the matrix A in band storage, in rows KL+1 to -*> 2*KL+KU+1; rows 1 to KL of the array need not be set. -*> The j-th column of A is stored in the j-th column of the -*> array AB as follows: -*> AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) -*> -*> On exit, details of the factorization: U is stored as an -*> upper triangular band matrix with KL+KU superdiagonals in -*> rows 1 to KL+KU+1, and the multipliers used during the -*> factorization are stored in rows KL+KU+2 to 2*KL+KU+1. -*> See below for further details. -*> \endverbatim -*> -*> \param[in] LDAB -*> \verbatim -*> LDAB is INTEGER -*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1. -*> \endverbatim -*> -*> \param[out] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (min(M,N)) -*> The pivot indices; for 1 <= i <= min(M,N), row i of the -*> matrix was interchanged with row IPIV(i). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: if INFO = +i, U(i,i) is exactly zero. The factorization -*> has been completed, but the factor U is exactly -*> singular, and division by zero will occur if it is used -*> to solve a system of equations. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup complex16GBcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The band storage scheme is illustrated by the following example, when -*> M = N = 6, KL = 2, KU = 1: -*> -*> On entry: On exit: -*> -*> * * * + + + * * * u14 u25 u36 -*> * * + + + + * * u13 u24 u35 u46 -*> * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 -*> a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 -*> a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * -*> a31 a42 a53 a64 * * m31 m42 m53 m64 * * -*> -*> Array elements marked * are not used by the routine; elements marked -*> + need not be set on entry, but are required by the routine to store -*> elements of U because of fill-in resulting from the row interchanges. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INFO, KL, KU, LDAB, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 AB( LDAB, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) - INTEGER NBMAX, LDWORK - PARAMETER ( NBMAX = 64, LDWORK = NBMAX+1 ) -* .. -* .. Local Scalars .. - INTEGER I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP, - $ JU, K2, KM, KV, NB, NW - COMPLEX*16 TEMP -* .. -* .. Local Arrays .. - COMPLEX*16 WORK13( LDWORK, NBMAX ), - $ WORK31( LDWORK, NBMAX ) -* .. -* .. External Functions .. - INTEGER ILAENV, IZAMAX - EXTERNAL ILAENV, IZAMAX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZCOPY, ZGBTF2, ZGEMM, ZGERU, ZLASWP, - $ ZSCAL, ZSWAP, ZTRSM -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* KV is the number of superdiagonals in the factor U, allowing for -* fill-in -* - KV = KU + KL -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( KL.LT.0 ) THEN - INFO = -3 - ELSE IF( KU.LT.0 ) THEN - INFO = -4 - ELSE IF( LDAB.LT.KL+KV+1 ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGBTRF', -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, 'ZGBTRF', ' ', M, N, KL, KU ) -* -* The block size must not exceed the limit set by the size of the -* local arrays WORK13 and WORK31. -* - NB = MIN( NB, NBMAX ) -* - IF( NB.LE.1 .OR. NB.GT.KL ) THEN -* -* Use unblocked code -* - CALL ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) - ELSE -* -* Use blocked code -* -* Zero the superdiagonal elements of the work array WORK13 -* - DO 20 J = 1, NB - DO 10 I = 1, J - 1 - WORK13( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE -* -* Zero the subdiagonal elements of the work array WORK31 -* - DO 40 J = 1, NB - DO 30 I = J + 1, NB - WORK31( I, J ) = ZERO - 30 CONTINUE - 40 CONTINUE -* -* Gaussian elimination with partial pivoting -* -* Set fill-in elements in columns KU+2 to KV to zero -* - DO 60 J = KU + 2, MIN( KV, N ) - DO 50 I = KV - J + 2, KL - AB( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE -* -* JU is the index of the last column affected by the current -* stage of the factorization -* - JU = 1 -* - DO 180 J = 1, MIN( M, N ), NB - JB = MIN( NB, MIN( M, N )-J+1 ) -* -* The active part of the matrix is partitioned -* -* A11 A12 A13 -* A21 A22 A23 -* A31 A32 A33 -* -* Here A11, A21 and A31 denote the current block of JB columns -* which is about to be factorized. The number of rows in the -* partitioning are JB, I2, I3 respectively, and the numbers -* of columns are JB, J2, J3. The superdiagonal elements of A13 -* and the subdiagonal elements of A31 lie outside the band. -* - I2 = MIN( KL-JB, M-J-JB+1 ) - I3 = MIN( JB, M-J-KL+1 ) -* -* J2 and J3 are computed after JU has been updated. -* -* Factorize the current block of JB columns -* - DO 80 JJ = J, J + JB - 1 -* -* Set fill-in elements in column JJ+KV to zero -* - IF( JJ+KV.LE.N ) THEN - DO 70 I = 1, KL - AB( I, JJ+KV ) = ZERO - 70 CONTINUE - END IF -* -* Find pivot and test for singularity. KM is the number of -* subdiagonal elements in the current column. -* - KM = MIN( KL, M-JJ ) - JP = IZAMAX( KM+1, AB( KV+1, JJ ), 1 ) - IPIV( JJ ) = JP + JJ - J - IF( AB( KV+JP, JJ ).NE.ZERO ) THEN - JU = MAX( JU, MIN( JJ+KU+JP-1, N ) ) - IF( JP.NE.1 ) THEN -* -* Apply interchange to columns J to J+JB-1 -* - IF( JP+JJ-1.LT.J+KL ) THEN -* - CALL ZSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1, - $ AB( KV+JP+JJ-J, J ), LDAB-1 ) - ELSE -* -* The interchange affects columns J to JJ-1 of A31 -* which are stored in the work array WORK31 -* - CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, - $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) - CALL ZSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1, - $ AB( KV+JP, JJ ), LDAB-1 ) - END IF - END IF -* -* Compute multipliers -* - CALL ZSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ), - $ 1 ) -* -* Update trailing submatrix within the band and within -* the current block. JM is the index of the last column -* which needs to be updated. -* - JM = MIN( JU, J+JB-1 ) - IF( JM.GT.JJ ) - $ CALL ZGERU( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1, - $ AB( KV, JJ+1 ), LDAB-1, - $ AB( KV+1, JJ+1 ), LDAB-1 ) - ELSE -* -* If pivot is zero, set INFO to the index of the pivot -* unless a zero pivot has already been found. -* - IF( INFO.EQ.0 ) - $ INFO = JJ - END IF -* -* Copy current column of A31 into the work array WORK31 -* - NW = MIN( JJ-J+1, I3 ) - IF( NW.GT.0 ) - $ CALL ZCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1, - $ WORK31( 1, JJ-J+1 ), 1 ) - 80 CONTINUE - IF( J+JB.LE.N ) THEN -* -* Apply the row interchanges to the other blocks. -* - J2 = MIN( JU-J+1, KV ) - JB - J3 = MAX( 0, JU-J-KV+1 ) -* -* Use ZLASWP to apply the row interchanges to A12, A22, and -* A32. -* - CALL ZLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB, - $ IPIV( J ), 1 ) -* -* Adjust the pivot indices. -* - DO 90 I = J, J + JB - 1 - IPIV( I ) = IPIV( I ) + J - 1 - 90 CONTINUE -* -* Apply the row interchanges to A13, A23, and A33 -* columnwise. -* - K2 = J - 1 + JB + J2 - DO 110 I = 1, J3 - JJ = K2 + I - DO 100 II = J + I - 1, J + JB - 1 - IP = IPIV( II ) - IF( IP.NE.II ) THEN - TEMP = AB( KV+1+II-JJ, JJ ) - AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ ) - AB( KV+1+IP-JJ, JJ ) = TEMP - END IF - 100 CONTINUE - 110 CONTINUE -* -* Update the relevant part of the trailing submatrix -* - IF( J2.GT.0 ) THEN -* -* Update A12 -* - CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ JB, J2, ONE, AB( KV+1, J ), LDAB-1, - $ AB( KV+1-JB, J+JB ), LDAB-1 ) -* - IF( I2.GT.0 ) THEN -* -* Update A22 -* - CALL ZGEMM( 'No transpose', 'No transpose', I2, J2, - $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, - $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, - $ AB( KV+1, J+JB ), LDAB-1 ) - END IF -* - IF( I3.GT.0 ) THEN -* -* Update A32 -* - CALL ZGEMM( 'No transpose', 'No transpose', I3, J2, - $ JB, -ONE, WORK31, LDWORK, - $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, - $ AB( KV+KL+1-JB, J+JB ), LDAB-1 ) - END IF - END IF -* - IF( J3.GT.0 ) THEN -* -* Copy the lower triangle of A13 into the work array -* WORK13 -* - DO 130 JJ = 1, J3 - DO 120 II = JJ, JB - WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 ) - 120 CONTINUE - 130 CONTINUE -* -* Update A13 in the work array -* - CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ JB, J3, ONE, AB( KV+1, J ), LDAB-1, - $ WORK13, LDWORK ) -* - IF( I2.GT.0 ) THEN -* -* Update A23 -* - CALL ZGEMM( 'No transpose', 'No transpose', I2, J3, - $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, - $ WORK13, LDWORK, ONE, AB( 1+JB, J+KV ), - $ LDAB-1 ) - END IF -* - IF( I3.GT.0 ) THEN -* -* Update A33 -* - CALL ZGEMM( 'No transpose', 'No transpose', I3, J3, - $ JB, -ONE, WORK31, LDWORK, WORK13, - $ LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 ) - END IF -* -* Copy the lower triangle of A13 back into place -* - DO 150 JJ = 1, J3 - DO 140 II = JJ, JB - AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ ) - 140 CONTINUE - 150 CONTINUE - END IF - ELSE -* -* Adjust the pivot indices. -* - DO 160 I = J, J + JB - 1 - IPIV( I ) = IPIV( I ) + J - 1 - 160 CONTINUE - END IF -* -* Partially undo the interchanges in the current block to -* restore the upper triangular form of A31 and copy the upper -* triangle of A31 back into place -* - DO 170 JJ = J + JB - 1, J, -1 - JP = IPIV( JJ ) - JJ + 1 - IF( JP.NE.1 ) THEN -* -* Apply interchange to columns J to JJ-1 -* - IF( JP+JJ-1.LT.J+KL ) THEN -* -* The interchange does not affect A31 -* - CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, - $ AB( KV+JP+JJ-J, J ), LDAB-1 ) - ELSE -* -* The interchange does affect A31 -* - CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, - $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) - END IF - END IF -* -* Copy the current column of A31 back into place -* - NW = MIN( I3, JJ-J+1 ) - IF( NW.GT.0 ) - $ CALL ZCOPY( NW, WORK31( 1, JJ-J+1 ), 1, - $ AB( KV+KL+1-JJ+J, JJ ), 1 ) - 170 CONTINUE - 180 CONTINUE - END IF -* - RETURN -* -* End of ZGBTRF -* - END diff --git a/mtx/lapack_src/zgbtrs.f b/mtx/lapack_src/zgbtrs.f deleted file mode 100644 index 2b41f129a..000000000 --- a/mtx/lapack_src/zgbtrs.f +++ /dev/null @@ -1,297 +0,0 @@ -*> \brief \b ZGBTRS -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZGBTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, -* INFO ) -* -* .. Scalar Arguments .. -* CHARACTER TRANS -* INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* COMPLEX*16 AB( LDAB, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZGBTRS solves a system of linear equations -*> A * X = B, A**T * X = B, or A**H * X = B -*> with a general band matrix A using the LU factorization computed -*> by ZGBTRF. -*> \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**H * X = B (Conjugate transpose) -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in] KL -*> \verbatim -*> KL is INTEGER -*> The number of subdiagonals within the band of A. KL >= 0. -*> \endverbatim -*> -*> \param[in] KU -*> \verbatim -*> KU is INTEGER -*> The number of superdiagonals within the band of A. KU >= 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] AB -*> \verbatim -*> AB is COMPLEX*16 array, dimension (LDAB,N) -*> Details of the LU factorization of the band matrix A, as -*> computed by ZGBTRF. U is stored as an upper triangular band -*> matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and -*> the multipliers used during the factorization are stored in -*> rows KL+KU+2 to 2*KL+KU+1. -*> \endverbatim -*> -*> \param[in] LDAB -*> \verbatim -*> LDAB is INTEGER -*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1. -*> \endverbatim -*> -*> \param[in] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (N) -*> The pivot indices; for 1 <= i <= N, row i of the matrix was -*> interchanged with row IPIV(i). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is COMPLEX*16 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. -* -*> \date November 2011 -* -*> \ingroup complex16GBcomputational -* -* ===================================================================== - SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, - $ INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 AB( LDAB, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LNOTI, NOTRAN - INTEGER I, J, KD, L, LM -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZGEMV, ZGERU, ZLACGV, ZSWAP, ZTBSV -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. 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( KL.LT.0 ) THEN - INFO = -3 - ELSE IF( KU.LT.0 ) THEN - INFO = -4 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -5 - ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGBTRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - KD = KU + KL + 1 - LNOTI = KL.GT.0 -* - IF( NOTRAN ) THEN -* -* Solve A*X = B. -* -* Solve L*X = B, overwriting B with X. -* -* L is represented as a product of permutations and unit lower -* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), -* where each transformation L(i) is a rank-one modification of -* the identity matrix. -* - IF( LNOTI ) THEN - DO 10 J = 1, N - 1 - LM = MIN( KL, N-J ) - L = IPIV( J ) - IF( L.NE.J ) - $ CALL ZSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) - CALL ZGERU( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ), - $ LDB, B( J+1, 1 ), LDB ) - 10 CONTINUE - END IF -* - DO 20 I = 1, NRHS -* -* Solve U*X = B, overwriting B with X. -* - CALL ZTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU, - $ AB, LDAB, B( 1, I ), 1 ) - 20 CONTINUE -* - ELSE IF( LSAME( TRANS, 'T' ) ) THEN -* -* Solve A**T * X = B. -* - DO 30 I = 1, NRHS -* -* Solve U**T * X = B, overwriting B with X. -* - CALL ZTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB, - $ LDAB, B( 1, I ), 1 ) - 30 CONTINUE -* -* Solve L**T * X = B, overwriting B with X. -* - IF( LNOTI ) THEN - DO 40 J = N - 1, 1, -1 - LM = MIN( KL, N-J ) - CALL ZGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ), - $ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB ) - L = IPIV( J ) - IF( L.NE.J ) - $ CALL ZSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) - 40 CONTINUE - END IF -* - ELSE -* -* Solve A**H * X = B. -* - DO 50 I = 1, NRHS -* -* Solve U**H * X = B, overwriting B with X. -* - CALL ZTBSV( 'Upper', 'Conjugate transpose', 'Non-unit', N, - $ KL+KU, AB, LDAB, B( 1, I ), 1 ) - 50 CONTINUE -* -* Solve L**H * X = B, overwriting B with X. -* - IF( LNOTI ) THEN - DO 60 J = N - 1, 1, -1 - LM = MIN( KL, N-J ) - CALL ZLACGV( NRHS, B( J, 1 ), LDB ) - CALL ZGEMV( 'Conjugate transpose', LM, NRHS, -ONE, - $ B( J+1, 1 ), LDB, AB( KD+1, J ), 1, ONE, - $ B( J, 1 ), LDB ) - CALL ZLACGV( NRHS, B( J, 1 ), LDB ) - L = IPIV( J ) - IF( L.NE.J ) - $ CALL ZSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) - 60 CONTINUE - END IF - END IF - RETURN -* -* End of ZGBTRS -* - END diff --git a/mtx/lapack_src/zgemm.f b/mtx/lapack_src/zgemm.f deleted file mode 100644 index 71c9e9a28..000000000 --- a/mtx/lapack_src/zgemm.f +++ /dev/null @@ -1,415 +0,0 @@ - SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* .. Scalar Arguments .. - DOUBLE COMPLEX ALPHA,BETA - INTEGER K,LDA,LDB,LDC,M,N - CHARACTER TRANSA,TRANSB -* .. -* .. Array Arguments .. - DOUBLE COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* Purpose -* ======= -* -* 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' or op( X ) = conjg( X' ), -* -* 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. -* -* Arguments -* ========== -* -* TRANSA - 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'. -* -* TRANSA = 'C' or 'c', op( A ) = conjg( A' ). -* -* Unchanged on exit. -* -* TRANSB - 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'. -* -* TRANSB = 'C' or 'c', op( B ) = conjg( B' ). -* -* Unchanged on exit. -* -* M - 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. -* Unchanged on exit. -* -* N - 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. -* Unchanged on exit. -* -* K - 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. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of 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. -* Unchanged on exit. -* -* LDA - 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 ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of 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. -* Unchanged on exit. -* -* LDB - 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 ). -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - COMPLEX*16 array of 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 ). -* -* LDC - 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 ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG,MAX -* .. -* .. Local Scalars .. - DOUBLE COMPLEX TEMP - INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB - LOGICAL CONJA,CONJB,NOTA,NOTB -* .. -* .. Parameters .. - DOUBLE COMPLEX ONE - PARAMETER (ONE= (1.0D+0,0.0D+0)) - DOUBLE COMPLEX 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, NCOLA and NROWB as the number of rows and columns of A -* and the number of rows of B respectively. -* - NOTA = LSAME(TRANSA,'N') - NOTB = LSAME(TRANSB,'N') - CONJA = LSAME(TRANSA,'C') - CONJB = LSAME(TRANSB,'C') - IF (NOTA) THEN - NROWA = M - NCOLA = K - ELSE - NROWA = K - NCOLA = M - 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 - IF (B(L,J).NE.ZERO) THEN - TEMP = ALPHA*B(L,J) - DO 70 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 70 CONTINUE - END IF - 80 CONTINUE - 90 CONTINUE - ELSE IF (CONJA) THEN -* -* Form C := alpha*conjg( A' )*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'*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*conjg( B' ) + 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 - IF (B(J,L).NE.ZERO) THEN - TEMP = ALPHA*DCONJG(B(J,L)) - DO 180 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 180 CONTINUE - END IF - 190 CONTINUE - 200 CONTINUE - ELSE -* -* Form C := alpha*A*B' + 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 - IF (B(J,L).NE.ZERO) THEN - TEMP = ALPHA*B(J,L) - DO 230 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 230 CONTINUE - END IF - 240 CONTINUE - 250 CONTINUE - END IF - ELSE IF (CONJA) THEN - IF (CONJB) THEN -* -* Form C := alpha*conjg( A' )*conjg( B' ) + 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*conjg( A' )*B' + 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'*conjg( B' ) + 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'*B' + 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/mtx/lapack_src/zgemv.f b/mtx/lapack_src/zgemv.f deleted file mode 100644 index 9d1729ca2..000000000 --- a/mtx/lapack_src/zgemv.f +++ /dev/null @@ -1,282 +0,0 @@ - SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* .. Scalar Arguments .. - DOUBLE COMPLEX ALPHA,BETA - INTEGER INCX,INCY,LDA,M,N - CHARACTER TRANS -* .. -* .. Array Arguments .. - DOUBLE COMPLEX A(LDA,*),X(*),Y(*) -* .. -* -* Purpose -* ======= -* -* ZGEMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or -* -* y := alpha*conjg( A' )*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n matrix. -* -* Arguments -* ========== -* -* TRANS - 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'*x + beta*y. -* -* TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. -* Unchanged on exit. -* -* LDA - 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 ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of 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. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of 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. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* 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. -* -* -* .. Parameters .. - DOUBLE COMPLEX ONE - PARAMETER (ONE= (1.0D+0,0.0D+0)) - DOUBLE COMPLEX ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* .. Local Scalars .. - DOUBLE COMPLEX TEMP - INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY - LOGICAL NOCONJ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC 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 - IF (X(JX).NE.ZERO) THEN - TEMP = ALPHA*X(JX) - DO 50 I = 1,M - Y(I) = Y(I) + TEMP*A(I,J) - 50 CONTINUE - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = ALPHA*X(JX) - IY = KY - DO 70 I = 1,M - Y(IY) = Y(IY) + TEMP*A(I,J) - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*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/mtx/lapack_src/zgeru.f b/mtx/lapack_src/zgeru.f deleted file mode 100644 index 47f1bef48..000000000 --- a/mtx/lapack_src/zgeru.f +++ /dev/null @@ -1,160 +0,0 @@ - SUBROUTINE ZGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* .. Scalar Arguments .. - DOUBLE COMPLEX ALPHA - INTEGER INCX,INCY,LDA,M,N -* .. -* .. Array Arguments .. - DOUBLE COMPLEX A(LDA,*),X(*),Y(*) -* .. -* -* Purpose -* ======= -* -* ZGERU performs the rank 1 operation -* -* A := alpha*x*y' + 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. -* -* Arguments -* ========== -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( m - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the m -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - COMPLEX*16 array of 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. -* -* LDA - 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 ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. Parameters .. - DOUBLE COMPLEX ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* .. Local Scalars .. - DOUBLE COMPLEX TEMP - INTEGER I,INFO,IX,J,JY,KX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (M.LT.0) THEN - INFO = 1 - ELSE IF (N.LT.0) THEN - INFO = 2 - ELSE IF (INCX.EQ.0) THEN - INFO = 5 - ELSE IF (INCY.EQ.0) THEN - INFO = 7 - ELSE IF (LDA.LT.MAX(1,M)) THEN - INFO = 9 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZGERU',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 ZGERU . -* - END - diff --git a/mtx/lapack_src/zgetf2.f b/mtx/lapack_src/zgetf2.f deleted file mode 100644 index acb067170..000000000 --- a/mtx/lapack_src/zgetf2.f +++ /dev/null @@ -1,214 +0,0 @@ -*> \brief \b ZGETF2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZGETF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* COMPLEX*16 A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZGETF2 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 COMPLEX*16 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. -* -*> \date November 2011 -* -*> \ingroup complex16GEcomputational -* -* ===================================================================== - SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION SFMIN - INTEGER I, J, JP -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - INTEGER IZAMAX - EXTERNAL DLAMCH, IZAMAX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZGERU, ZSCAL, ZSWAP -* .. -* .. 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( 'ZGETF2', -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 + IZAMAX( 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 ZSWAP( 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 ZSCAL( 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 ZGERU( 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 ZGETF2 -* - END diff --git a/mtx/lapack_src/zgetrf.f b/mtx/lapack_src/zgetrf.f deleted file mode 100644 index 5428a8ff7..000000000 --- a/mtx/lapack_src/zgetrf.f +++ /dev/null @@ -1,225 +0,0 @@ -*> \brief \b ZGETRF -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZGETRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* COMPLEX*16 A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZGETRF 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 COMPLEX*16 array, dimension (LDA,N) -*> On entry, the M-by-N matrix to be factored. -*> On exit, the factors L and U from the factorization -*> A = P*L*U; the unit diagonal elements of L are not stored. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (min(M,N)) -*> The pivot indices; for 1 <= i <= min(M,N), row i of the -*> matrix was interchanged with row IPIV(i). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: if INFO = i, U(i,i) is exactly zero. The factorization -*> has been completed, but the factor U is exactly -*> singular, and division by zero will occur if it is used -*> to solve a system of equations. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup complex16GEcomputational -* -* ===================================================================== - SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO, J, JB, NB -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZGEMM, ZGETF2, ZLASWP, ZTRSM -* .. -* .. 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( 'ZGETRF', -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, 'ZGETRF', ' ', M, N, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN -* -* Use unblocked code. -* - CALL ZGETF2( 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 ZGETF2( 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 ZLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) -* - IF( J+JB.LE.N ) THEN -* -* Apply interchanges to columns J+JB:N. -* - CALL ZLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, - $ IPIV, 1 ) -* -* Compute block row of U. -* - CALL ZTRSM( '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 ZGEMM( '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 ZGETRF -* - END diff --git a/mtx/lapack_src/zgetrs.f b/mtx/lapack_src/zgetrs.f deleted file mode 100644 index 6400055b4..000000000 --- a/mtx/lapack_src/zgetrs.f +++ /dev/null @@ -1,225 +0,0 @@ -*> \brief \b ZGETRS -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZGETRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER TRANS -* INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* COMPLEX*16 A( LDA, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZGETRS solves a system of linear equations -*> A * X = B, A**T * X = B, or A**H * X = B -*> with a general N-by-N matrix A using the LU factorization computed -*> by ZGETRF. -*> \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**H * X = B (Conjugate 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 COMPLEX*16 array, dimension (LDA,N) -*> The factors L and U from the factorization A = P*L*U -*> as computed by ZGETRF. -*> \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 ZGETRF; for 1<=i<=N, row i of the -*> matrix was interchanged with row IPIV(i). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is COMPLEX*16 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. -* -*> \date November 2011 -* -*> \ingroup complex16GEcomputational -* -* ===================================================================== - SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 A( LDA, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLASWP, ZTRSM -* .. -* .. 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( 'ZGETRS', -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 ZLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) -* -* Solve L*X = B, overwriting B with X. -* - CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A**T * X = B or A**H * X = B. -* -* Solve U**T *X = B or U**H *X = B, overwriting B with X. -* - CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, - $ A, LDA, B, LDB ) -* -* Solve L**T *X = B, or L**H *X = B overwriting B with X. -* - CALL ZTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A, - $ LDA, B, LDB ) -* -* Apply row interchanges to the solution vectors. -* - CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) - END IF -* - RETURN -* -* End of ZGETRS -* - END diff --git a/mtx/lapack_src/zgttrf.f b/mtx/lapack_src/zgttrf.f deleted file mode 100644 index ac8edea97..000000000 --- a/mtx/lapack_src/zgttrf.f +++ /dev/null @@ -1,243 +0,0 @@ -*> \brief \b ZGTTRF -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZGTTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, N -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* COMPLEX*16 D( * ), DL( * ), DU( * ), DU2( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZGTTRF computes an LU factorization of a complex tridiagonal matrix A -*> using elimination with partial pivoting and row interchanges. -*> -*> The factorization has the form -*> A = L * U -*> where L is a product of permutation and unit lower bidiagonal -*> matrices and U is upper triangular with nonzeros in only the main -*> diagonal and first two superdiagonals. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. -*> \endverbatim -*> -*> \param[in,out] DL -*> \verbatim -*> DL is COMPLEX*16 array, dimension (N-1) -*> On entry, DL must contain the (n-1) sub-diagonal elements of -*> A. -*> -*> On exit, DL is overwritten by the (n-1) multipliers that -*> define the matrix L from the LU factorization of A. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is COMPLEX*16 array, dimension (N) -*> On entry, D must contain the diagonal elements of A. -*> -*> On exit, D is overwritten by the n diagonal elements of the -*> upper triangular matrix U from the LU factorization of A. -*> \endverbatim -*> -*> \param[in,out] DU -*> \verbatim -*> DU is COMPLEX*16 array, dimension (N-1) -*> On entry, DU must contain the (n-1) super-diagonal elements -*> of A. -*> -*> On exit, DU is overwritten by the (n-1) elements of the first -*> super-diagonal of U. -*> \endverbatim -*> -*> \param[out] DU2 -*> \verbatim -*> DU2 is COMPLEX*16 array, dimension (N-2) -*> On exit, DU2 is overwritten by the (n-2) elements of the -*> second super-diagonal of U. -*> \endverbatim -*> -*> \param[out] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (N) -*> The pivot indices; for 1 <= i <= n, row i of the matrix was -*> interchanged with row IPIV(i). IPIV(i) will always be either -*> i or i+1; IPIV(i) = i indicates a row interchange was not -*> required. -*> \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. -* -*> \date November 2011 -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INFO, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 D( * ), DL( * ), DU( * ), DU2( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I - COMPLEX*16 FACT, TEMP, ZDUM -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DIMAG -* .. -* .. Statement Functions .. - DOUBLE PRECISION CABS1 -* .. -* .. Statement Function definitions .. - CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) -* .. -* .. Executable Statements .. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - CALL XERBLA( 'ZGTTRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Initialize IPIV(i) = i and DU2(i) = 0 -* - DO 10 I = 1, N - IPIV( I ) = I - 10 CONTINUE - DO 20 I = 1, N - 2 - DU2( I ) = ZERO - 20 CONTINUE -* - DO 30 I = 1, N - 2 - IF( CABS1( D( I ) ).GE.CABS1( DL( I ) ) ) THEN -* -* No row interchange required, eliminate DL(I) -* - IF( CABS1( D( I ) ).NE.ZERO ) THEN - FACT = DL( I ) / D( I ) - DL( I ) = FACT - D( I+1 ) = D( I+1 ) - FACT*DU( I ) - END IF - ELSE -* -* Interchange rows I and I+1, eliminate DL(I) -* - FACT = D( I ) / DL( I ) - D( I ) = DL( I ) - DL( I ) = FACT - TEMP = DU( I ) - DU( I ) = D( I+1 ) - D( I+1 ) = TEMP - FACT*D( I+1 ) - DU2( I ) = DU( I+1 ) - DU( I+1 ) = -FACT*DU( I+1 ) - IPIV( I ) = I + 1 - END IF - 30 CONTINUE - IF( N.GT.1 ) THEN - I = N - 1 - IF( CABS1( D( I ) ).GE.CABS1( DL( I ) ) ) THEN - IF( CABS1( D( I ) ).NE.ZERO ) THEN - FACT = DL( I ) / D( I ) - DL( I ) = FACT - D( I+1 ) = D( I+1 ) - FACT*DU( I ) - END IF - ELSE - FACT = D( I ) / DL( I ) - D( I ) = DL( I ) - DL( I ) = FACT - TEMP = DU( I ) - DU( I ) = D( I+1 ) - D( I+1 ) = TEMP - FACT*D( I+1 ) - IPIV( I ) = I + 1 - END IF - END IF -* -* Check for a zero on the diagonal of U. -* - DO 40 I = 1, N - IF( CABS1( D( I ) ).EQ.ZERO ) THEN - INFO = I - GO TO 50 - END IF - 40 CONTINUE - 50 CONTINUE -* - RETURN -* -* End of ZGTTRF -* - END diff --git a/mtx/lapack_src/zgttrs.f b/mtx/lapack_src/zgttrs.f deleted file mode 100644 index e5d50f311..000000000 --- a/mtx/lapack_src/zgttrs.f +++ /dev/null @@ -1,225 +0,0 @@ -*> \brief \b ZGTTRS -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZGTTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, -* INFO ) -* -* .. Scalar Arguments .. -* CHARACTER TRANS -* INTEGER INFO, LDB, N, NRHS -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZGTTRS solves one of the systems of equations -*> A * X = B, A**T * X = B, or A**H * X = B, -*> with a tridiagonal matrix A using the LU factorization computed -*> by ZGTTRF. -*> \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**H * X = B (Conjugate transpose) -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. -*> \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] DL -*> \verbatim -*> DL is COMPLEX*16 array, dimension (N-1) -*> The (n-1) multipliers that define the matrix L from the -*> LU factorization of A. -*> \endverbatim -*> -*> \param[in] D -*> \verbatim -*> D is COMPLEX*16 array, dimension (N) -*> The n diagonal elements of the upper triangular matrix U from -*> the LU factorization of A. -*> \endverbatim -*> -*> \param[in] DU -*> \verbatim -*> DU is COMPLEX*16 array, dimension (N-1) -*> The (n-1) elements of the first super-diagonal of U. -*> \endverbatim -*> -*> \param[in] DU2 -*> \verbatim -*> DU2 is COMPLEX*16 array, dimension (N-2) -*> The (n-2) elements of the second super-diagonal of U. -*> \endverbatim -*> -*> \param[in] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (N) -*> The pivot indices; for 1 <= i <= n, row i of the matrix was -*> interchanged with row IPIV(i). IPIV(i) will always be either -*> i or i+1; IPIV(i) = i indicates a row interchange was not -*> required. -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is COMPLEX*16 array, dimension (LDB,NRHS) -*> On entry, the matrix of right hand side vectors B. -*> On exit, B is overwritten by the solution vectors 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 = -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. -* -*> \date November 2011 -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, - $ INFO ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL NOTRAN - INTEGER ITRANS, J, JB, NB -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZGTTS2 -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* - INFO = 0 - NOTRAN = ( TRANS.EQ.'N' .OR. TRANS.EQ.'n' ) - IF( .NOT.NOTRAN .AND. .NOT.( TRANS.EQ.'T' .OR. TRANS.EQ. - $ 't' ) .AND. .NOT.( TRANS.EQ.'C' .OR. TRANS.EQ.'c' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGTTRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* -* Decode TRANS -* - IF( NOTRAN ) THEN - ITRANS = 0 - ELSE IF( TRANS.EQ.'T' .OR. TRANS.EQ.'t' ) THEN - ITRANS = 1 - ELSE - ITRANS = 2 - END IF -* -* Determine the number of right-hand sides to solve at a time. -* - IF( NRHS.EQ.1 ) THEN - NB = 1 - ELSE - NB = MAX( 1, ILAENV( 1, 'ZGTTRS', TRANS, N, NRHS, -1, -1 ) ) - END IF -* - IF( NB.GE.NRHS ) THEN - CALL ZGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) - ELSE - DO 10 J = 1, NRHS, NB - JB = MIN( NRHS-J+1, NB ) - CALL ZGTTS2( ITRANS, N, JB, DL, D, DU, DU2, IPIV, B( 1, J ), - $ LDB ) - 10 CONTINUE - END IF -* -* End of ZGTTRS -* - END diff --git a/mtx/lapack_src/zgtts2.f b/mtx/lapack_src/zgtts2.f deleted file mode 100644 index a7c508ab9..000000000 --- a/mtx/lapack_src/zgtts2.f +++ /dev/null @@ -1,349 +0,0 @@ -*> \brief \b ZGTTS2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZGTTS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) -* -* .. Scalar Arguments .. -* INTEGER ITRANS, LDB, N, NRHS -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZGTTS2 solves one of the systems of equations -*> A * X = B, A**T * X = B, or A**H * X = B, -*> with a tridiagonal matrix A using the LU factorization computed -*> by ZGTTRF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ITRANS -*> \verbatim -*> ITRANS is INTEGER -*> Specifies the form of the system of equations. -*> = 0: A * X = B (No transpose) -*> = 1: A**T * X = B (Transpose) -*> = 2: A**H * X = B (Conjugate transpose) -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. -*> \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] DL -*> \verbatim -*> DL is COMPLEX*16 array, dimension (N-1) -*> The (n-1) multipliers that define the matrix L from the -*> LU factorization of A. -*> \endverbatim -*> -*> \param[in] D -*> \verbatim -*> D is COMPLEX*16 array, dimension (N) -*> The n diagonal elements of the upper triangular matrix U from -*> the LU factorization of A. -*> \endverbatim -*> -*> \param[in] DU -*> \verbatim -*> DU is COMPLEX*16 array, dimension (N-1) -*> The (n-1) elements of the first super-diagonal of U. -*> \endverbatim -*> -*> \param[in] DU2 -*> \verbatim -*> DU2 is COMPLEX*16 array, dimension (N-2) -*> The (n-2) elements of the second super-diagonal of U. -*> \endverbatim -*> -*> \param[in] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (N) -*> The pivot indices; for 1 <= i <= n, row i of the matrix was -*> interchanged with row IPIV(i). IPIV(i) will always be either -*> i or i+1; IPIV(i) = i indicates a row interchange was not -*> required. -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is COMPLEX*16 array, dimension (LDB,NRHS) -*> On entry, the matrix of right hand side vectors B. -*> On exit, B is overwritten by the solution vectors X. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,N). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - SUBROUTINE ZGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER ITRANS, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, J - COMPLEX*16 TEMP -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( ITRANS.EQ.0 ) THEN -* -* Solve A*X = B using the LU factorization of A, -* overwriting each right hand side vector with its solution. -* - IF( NRHS.LE.1 ) THEN - J = 1 - 10 CONTINUE -* -* Solve L*x = b. -* - DO 20 I = 1, N - 1 - IF( IPIV( I ).EQ.I ) THEN - B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J ) - ELSE - TEMP = B( I, J ) - B( I, J ) = B( I+1, J ) - B( I+1, J ) = TEMP - DL( I )*B( I, J ) - END IF - 20 CONTINUE -* -* Solve U*x = b. -* - B( N, J ) = B( N, J ) / D( N ) - IF( N.GT.1 ) - $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / - $ D( N-1 ) - DO 30 I = N - 2, 1, -1 - B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* - $ B( I+2, J ) ) / D( I ) - 30 CONTINUE - IF( J.LT.NRHS ) THEN - J = J + 1 - GO TO 10 - END IF - ELSE - DO 60 J = 1, NRHS -* -* Solve L*x = b. -* - DO 40 I = 1, N - 1 - IF( IPIV( I ).EQ.I ) THEN - B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J ) - ELSE - TEMP = B( I, J ) - B( I, J ) = B( I+1, J ) - B( I+1, J ) = TEMP - DL( I )*B( I, J ) - END IF - 40 CONTINUE -* -* Solve U*x = b. -* - B( N, J ) = B( N, J ) / D( N ) - IF( N.GT.1 ) - $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / - $ D( N-1 ) - DO 50 I = N - 2, 1, -1 - B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* - $ B( I+2, J ) ) / D( I ) - 50 CONTINUE - 60 CONTINUE - END IF - ELSE IF( ITRANS.EQ.1 ) THEN -* -* Solve A**T * X = B. -* - IF( NRHS.LE.1 ) THEN - J = 1 - 70 CONTINUE -* -* Solve U**T * x = b. -* - B( 1, J ) = B( 1, J ) / D( 1 ) - IF( N.GT.1 ) - $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) - DO 80 I = 3, N - B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )* - $ B( I-2, J ) ) / D( I ) - 80 CONTINUE -* -* Solve L**T * x = b. -* - DO 90 I = N - 1, 1, -1 - IF( IPIV( I ).EQ.I ) THEN - B( I, J ) = B( I, J ) - DL( I )*B( I+1, J ) - ELSE - TEMP = B( I+1, J ) - B( I+1, J ) = B( I, J ) - DL( I )*TEMP - B( I, J ) = TEMP - END IF - 90 CONTINUE - IF( J.LT.NRHS ) THEN - J = J + 1 - GO TO 70 - END IF - ELSE - DO 120 J = 1, NRHS -* -* Solve U**T * x = b. -* - B( 1, J ) = B( 1, J ) / D( 1 ) - IF( N.GT.1 ) - $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) - DO 100 I = 3, N - B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )- - $ DU2( I-2 )*B( I-2, J ) ) / D( I ) - 100 CONTINUE -* -* Solve L**T * x = b. -* - DO 110 I = N - 1, 1, -1 - IF( IPIV( I ).EQ.I ) THEN - B( I, J ) = B( I, J ) - DL( I )*B( I+1, J ) - ELSE - TEMP = B( I+1, J ) - B( I+1, J ) = B( I, J ) - DL( I )*TEMP - B( I, J ) = TEMP - END IF - 110 CONTINUE - 120 CONTINUE - END IF - ELSE -* -* Solve A**H * X = B. -* - IF( NRHS.LE.1 ) THEN - J = 1 - 130 CONTINUE -* -* Solve U**H * x = b. -* - B( 1, J ) = B( 1, J ) / DCONJG( D( 1 ) ) - IF( N.GT.1 ) - $ B( 2, J ) = ( B( 2, J )-DCONJG( DU( 1 ) )*B( 1, J ) ) / - $ DCONJG( D( 2 ) ) - DO 140 I = 3, N - B( I, J ) = ( B( I, J )-DCONJG( DU( I-1 ) )*B( I-1, J )- - $ DCONJG( DU2( I-2 ) )*B( I-2, J ) ) / - $ DCONJG( D( I ) ) - 140 CONTINUE -* -* Solve L**H * x = b. -* - DO 150 I = N - 1, 1, -1 - IF( IPIV( I ).EQ.I ) THEN - B( I, J ) = B( I, J ) - DCONJG( DL( I ) )*B( I+1, J ) - ELSE - TEMP = B( I+1, J ) - B( I+1, J ) = B( I, J ) - DCONJG( DL( I ) )*TEMP - B( I, J ) = TEMP - END IF - 150 CONTINUE - IF( J.LT.NRHS ) THEN - J = J + 1 - GO TO 130 - END IF - ELSE - DO 180 J = 1, NRHS -* -* Solve U**H * x = b. -* - B( 1, J ) = B( 1, J ) / DCONJG( D( 1 ) ) - IF( N.GT.1 ) - $ B( 2, J ) = ( B( 2, J )-DCONJG( DU( 1 ) )*B( 1, J ) ) - $ / DCONJG( D( 2 ) ) - DO 160 I = 3, N - B( I, J ) = ( B( I, J )-DCONJG( DU( I-1 ) )* - $ B( I-1, J )-DCONJG( DU2( I-2 ) )* - $ B( I-2, J ) ) / DCONJG( D( I ) ) - 160 CONTINUE -* -* Solve L**H * x = b. -* - DO 170 I = N - 1, 1, -1 - IF( IPIV( I ).EQ.I ) THEN - B( I, J ) = B( I, J ) - DCONJG( DL( I ) )* - $ B( I+1, J ) - ELSE - TEMP = B( I+1, J ) - B( I+1, J ) = B( I, J ) - DCONJG( DL( I ) )*TEMP - B( I, J ) = TEMP - END IF - 170 CONTINUE - 180 CONTINUE - END IF - END IF -* -* End of ZGTTS2 -* - END diff --git a/mtx/lapack_src/zlacgv.f b/mtx/lapack_src/zlacgv.f deleted file mode 100644 index 16c2e2ed9..000000000 --- a/mtx/lapack_src/zlacgv.f +++ /dev/null @@ -1,116 +0,0 @@ -*> \brief \b ZLACGV -* -* =========== 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. -* -*> \date November 2011 -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - SUBROUTINE ZLACGV( N, X, INCX ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INCX, N -* .. -* .. Array Arguments .. - COMPLEX*16 X( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IOFF -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG -* .. -* .. Executable Statements .. -* - IF( INCX.EQ.1 ) THEN - DO 10 I = 1, N - X( I ) = DCONJG( X( I ) ) - 10 CONTINUE - ELSE - IOFF = 1 - IF( INCX.LT.0 ) - $ IOFF = 1 - ( N-1 )*INCX - DO 20 I = 1, N - X( IOFF ) = DCONJG( X( IOFF ) ) - IOFF = IOFF + INCX - 20 CONTINUE - END IF - RETURN -* -* End of ZLACGV -* - END diff --git a/mtx/lapack_src/zlaswp.f b/mtx/lapack_src/zlaswp.f deleted file mode 100644 index 65edab111..000000000 --- a/mtx/lapack_src/zlaswp.f +++ /dev/null @@ -1,191 +0,0 @@ -*> \brief \b ZLASWP -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLASWP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* -* .. Scalar Arguments .. -* INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* COMPLEX*16 A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLASWP 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 COMPLEX*16 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 -*> The last element of IPIV for which a row interchange will -*> be done. -*> \endverbatim -*> -*> \param[in] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (K2*abs(INCX)) -*> The vector of pivot indices. Only the elements in positions -*> K1 through K2 of IPIV are accessed. -*> IPIV(K) = L implies rows K and L are to be interchanged. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> The increment between successive values of IPIV. If IPIV -*> 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. -* -*> \date November 2011 -* -*> \ingroup complex16OTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Modified by -*> R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* -* -- LAPACK auxiliary routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 - COMPLEX*16 TEMP -* .. -* .. Executable Statements .. -* -* Interchange row I with row IPIV(I) 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 = 1 + ( 1-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 ZLASWP -* - END diff --git a/mtx/lapack_src/zscal.f b/mtx/lapack_src/zscal.f deleted file mode 100644 index 6ab6007a0..000000000 --- a/mtx/lapack_src/zscal.f +++ /dev/null @@ -1,41 +0,0 @@ - SUBROUTINE ZSCAL(N,ZA,ZX,INCX) -* .. Scalar Arguments .. - DOUBLE COMPLEX ZA - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE COMPLEX ZX(*) -* .. -* -* Purpose -* ======= -* -* scales a vector by a constant. -* jack dongarra, 3/11/78. -* modified 3/93 to return if incx .le. 0. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* -* .. Local Scalars .. - INTEGER I,IX -* .. - IF (N.LE.0 .OR. INCX.LE.0) RETURN - IF (INCX.EQ.1) GO TO 20 -* -* code for increment not equal to 1 -* - IX = 1 - DO 10 I = 1,N - ZX(IX) = ZA*ZX(IX) - IX = IX + INCX - 10 CONTINUE - RETURN -* -* code for increment equal to 1 -* - 20 DO 30 I = 1,N - ZX(I) = ZA*ZX(I) - 30 CONTINUE - RETURN - END - diff --git a/mtx/lapack_src/zswap.f b/mtx/lapack_src/zswap.f deleted file mode 100644 index 2eec2d68d..000000000 --- a/mtx/lapack_src/zswap.f +++ /dev/null @@ -1,48 +0,0 @@ - SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY) -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE COMPLEX ZX(*),ZY(*) -* .. -* -* Purpose -* ======= -* -* interchanges two vectors. -* jack dongarra, 3/11/78. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* -* .. Local Scalars .. - DOUBLE COMPLEX ZTEMP - INTEGER I,IX,IY -* .. - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20 -* -* 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 10 I = 1,N - ZTEMP = ZX(IX) - ZX(IX) = ZY(IY) - ZY(IY) = ZTEMP - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -* -* code for both increments equal to 1 - 20 DO 30 I = 1,N - ZTEMP = ZX(I) - ZX(I) = ZY(I) - ZY(I) = ZTEMP - 30 CONTINUE - RETURN - END - diff --git a/mtx/lapack_src/ztbsv.f b/mtx/lapack_src/ztbsv.f deleted file mode 100644 index 59fcb8047..000000000 --- a/mtx/lapack_src/ztbsv.f +++ /dev/null @@ -1,368 +0,0 @@ - SUBROUTINE ZTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) -* .. Scalar Arguments .. - INTEGER INCX,K,LDA,N - CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. - DOUBLE COMPLEX A(LDA,*),X(*) -* .. -* -* Purpose -* ======= -* -* ZTBSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, or conjg( A' )*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular band matrix, with ( k + 1 ) -* diagonals. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* Arguments -* ========== -* -* UPLO - 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. -* -* Unchanged on exit. -* -* TRANS - 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'*x = b. -* -* TRANS = 'C' or 'c' conjg( A' )*x = b. -* -* Unchanged on exit. -* -* DIAG - 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. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with UPLO = 'U' or 'u', K specifies the number of -* super-diagonals of the matrix A. -* On entry with UPLO = 'L' or 'l', K specifies the number of -* sub-diagonals of the matrix A. -* K must satisfy 0 .le. K. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer an upper -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer a lower -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Note that when DIAG = 'U' or 'u' the elements of the array A -* corresponding to the diagonal elements of the matrix are not -* referenced, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of 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. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* 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. -* -* -* .. Parameters .. - DOUBLE COMPLEX ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* .. Local Scalars .. - DOUBLE COMPLEX TEMP - INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L - LOGICAL NOCONJ,NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG,MAX,MIN -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 2 - ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (K.LT.0) THEN - INFO = 5 - ELSE IF (LDA.LT. (K+1)) THEN - INFO = 7 - ELSE IF (INCX.EQ.0) THEN - INFO = 9 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZTBSV',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOCONJ = LSAME(TRANS,'T') - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed by sequentially with one pass through A. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x := inv( A )*x. -* - IF (LSAME(UPLO,'U')) THEN - KPLUS1 = K + 1 - IF (INCX.EQ.1) THEN - DO 20 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - L = KPLUS1 - J - IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J) - TEMP = X(J) - DO 10 I = J - 1,MAX(1,J-K),-1 - X(I) = X(I) - TEMP*A(L+I,J) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 40 J = N,1,-1 - KX = KX - INCX - IF (X(JX).NE.ZERO) THEN - IX = KX - L = KPLUS1 - J - IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J) - TEMP = X(JX) - DO 30 I = J - 1,MAX(1,J-K),-1 - X(IX) = X(IX) - TEMP*A(L+I,J) - IX = IX - INCX - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 60 J = 1,N - IF (X(J).NE.ZERO) THEN - L = 1 - J - IF (NOUNIT) X(J) = X(J)/A(1,J) - TEMP = X(J) - DO 50 I = J + 1,MIN(N,J+K) - X(I) = X(I) - TEMP*A(L+I,J) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80 J = 1,N - KX = KX + INCX - IF (X(JX).NE.ZERO) THEN - IX = KX - L = 1 - J - IF (NOUNIT) X(JX) = X(JX)/A(1,J) - TEMP = X(JX) - DO 70 I = J + 1,MIN(N,J+K) - X(IX) = X(IX) - TEMP*A(L+I,J) - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A' )*x or x := inv( conjg( A') )*x. -* - IF (LSAME(UPLO,'U')) THEN - KPLUS1 = K + 1 - IF (INCX.EQ.1) THEN - DO 110 J = 1,N - TEMP = X(J) - L = KPLUS1 - J - IF (NOCONJ) THEN - DO 90 I = MAX(1,J-K),J - 1 - TEMP = TEMP - A(L+I,J)*X(I) - 90 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) - ELSE - DO 100 I = MAX(1,J-K),J - 1 - TEMP = TEMP - DCONJG(A(L+I,J))*X(I) - 100 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(A(KPLUS1,J)) - END IF - X(J) = TEMP - 110 CONTINUE - ELSE - JX = KX - DO 140 J = 1,N - TEMP = X(JX) - IX = KX - L = KPLUS1 - J - IF (NOCONJ) THEN - DO 120 I = MAX(1,J-K),J - 1 - TEMP = TEMP - A(L+I,J)*X(IX) - IX = IX + INCX - 120 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) - ELSE - DO 130 I = MAX(1,J-K),J - 1 - TEMP = TEMP - DCONJG(A(L+I,J))*X(IX) - IX = IX + INCX - 130 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(A(KPLUS1,J)) - END IF - X(JX) = TEMP - JX = JX + INCX - IF (J.GT.K) KX = KX + INCX - 140 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 170 J = N,1,-1 - TEMP = X(J) - L = 1 - J - IF (NOCONJ) THEN - DO 150 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - A(L+I,J)*X(I) - 150 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(1,J) - ELSE - DO 160 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - DCONJG(A(L+I,J))*X(I) - 160 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(A(1,J)) - END IF - X(J) = TEMP - 170 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 200 J = N,1,-1 - TEMP = X(JX) - IX = KX - L = 1 - J - IF (NOCONJ) THEN - DO 180 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - A(L+I,J)*X(IX) - IX = IX - INCX - 180 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(1,J) - ELSE - DO 190 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - DCONJG(A(L+I,J))*X(IX) - IX = IX - INCX - 190 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(A(1,J)) - END IF - X(JX) = TEMP - JX = JX - INCX - IF ((N-J).GE.K) KX = KX - INCX - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTBSV . -* - END - diff --git a/mtx/lapack_src/ztrsm.f b/mtx/lapack_src/ztrsm.f deleted file mode 100644 index e199806e6..000000000 --- a/mtx/lapack_src/ztrsm.f +++ /dev/null @@ -1,408 +0,0 @@ - SUBROUTINE ZTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* .. Scalar Arguments .. - DOUBLE COMPLEX ALPHA - INTEGER LDA,LDB,M,N - CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. - DOUBLE COMPLEX A(LDA,*),B(LDB,*) -* .. -* -* Purpose -* ======= -* -* ZTRSM 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' or op( A ) = conjg( A' ). -* -* The matrix X is overwritten on B. -* -* Arguments -* ========== -* -* SIDE - 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. -* -* Unchanged on exit. -* -* UPLO - 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. -* -* Unchanged on exit. -* -* TRANSA - 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'. -* -* TRANSA = 'C' or 'c' op( A ) = conjg( A' ). -* -* Unchanged on exit. -* -* DIAG - 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. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - 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. -* Unchanged on exit. -* -* A - COMPLEX*16 array of 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. -* Unchanged on exit. -* -* LDA - 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 ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of 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. -* -* LDB - 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 ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG,MAX -* .. -* .. Local Scalars .. - DOUBLE COMPLEX TEMP - INTEGER I,INFO,J,K,NROWA - LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER -* .. -* .. Parameters .. - DOUBLE COMPLEX ONE - PARAMETER (ONE= (1.0D+0,0.0D+0)) - DOUBLE COMPLEX 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('ZTRSM',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (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' )*B -* or B := alpha*inv( conjg( A' ) )*B. -* - IF (UPPER) THEN - DO 140 J = 1,N - DO 130 I = 1,M - TEMP = ALPHA*B(I,J) - IF (NOCONJ) THEN - DO 110 K = 1,I - 1 - TEMP = TEMP - A(K,I)*B(K,J) - 110 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(I,I) - ELSE - DO 120 K = 1,I - 1 - TEMP = TEMP - DCONJG(A(K,I))*B(K,J) - 120 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(A(I,I)) - END IF - B(I,J) = TEMP - 130 CONTINUE - 140 CONTINUE - ELSE - DO 180 J = 1,N - DO 170 I = M,1,-1 - TEMP = ALPHA*B(I,J) - IF (NOCONJ) THEN - DO 150 K = I + 1,M - TEMP = TEMP - A(K,I)*B(K,J) - 150 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(I,I) - ELSE - DO 160 K = I + 1,M - TEMP = TEMP - DCONJG(A(K,I))*B(K,J) - 160 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(A(I,I)) - END IF - B(I,J) = TEMP - 170 CONTINUE - 180 CONTINUE - END IF - END IF - ELSE - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*B*inv( A ). -* - IF (UPPER) THEN - DO 230 J = 1,N - IF (ALPHA.NE.ONE) THEN - DO 190 I = 1,M - B(I,J) = ALPHA*B(I,J) - 190 CONTINUE - END IF - DO 210 K = 1,J - 1 - IF (A(K,J).NE.ZERO) THEN - DO 200 I = 1,M - B(I,J) = B(I,J) - A(K,J)*B(I,K) - 200 CONTINUE - END IF - 210 CONTINUE - IF (NOUNIT) THEN - TEMP = ONE/A(J,J) - DO 220 I = 1,M - B(I,J) = TEMP*B(I,J) - 220 CONTINUE - END IF - 230 CONTINUE - ELSE - DO 280 J = N,1,-1 - IF (ALPHA.NE.ONE) THEN - DO 240 I = 1,M - B(I,J) = ALPHA*B(I,J) - 240 CONTINUE - END IF - DO 260 K = J + 1,N - IF (A(K,J).NE.ZERO) THEN - DO 250 I = 1,M - B(I,J) = B(I,J) - A(K,J)*B(I,K) - 250 CONTINUE - END IF - 260 CONTINUE - IF (NOUNIT) THEN - TEMP = ONE/A(J,J) - DO 270 I = 1,M - B(I,J) = TEMP*B(I,J) - 270 CONTINUE - END IF - 280 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*inv( A' ) -* or B := alpha*B*inv( conjg( A' ) ). -* - IF (UPPER) THEN - DO 330 K = N,1,-1 - IF (NOUNIT) THEN - IF (NOCONJ) THEN - TEMP = ONE/A(K,K) - ELSE - TEMP = ONE/DCONJG(A(K,K)) - END IF - DO 290 I = 1,M - B(I,K) = TEMP*B(I,K) - 290 CONTINUE - END IF - DO 310 J = 1,K - 1 - IF (A(J,K).NE.ZERO) THEN - IF (NOCONJ) THEN - TEMP = A(J,K) - ELSE - TEMP = DCONJG(A(J,K)) - END IF - DO 300 I = 1,M - B(I,J) = B(I,J) - TEMP*B(I,K) - 300 CONTINUE - END IF - 310 CONTINUE - IF (ALPHA.NE.ONE) THEN - DO 320 I = 1,M - B(I,K) = ALPHA*B(I,K) - 320 CONTINUE - END IF - 330 CONTINUE - ELSE - DO 380 K = 1,N - IF (NOUNIT) THEN - IF (NOCONJ) THEN - TEMP = ONE/A(K,K) - ELSE - TEMP = ONE/DCONJG(A(K,K)) - END IF - DO 340 I = 1,M - B(I,K) = TEMP*B(I,K) - 340 CONTINUE - END IF - DO 360 J = K + 1,N - IF (A(J,K).NE.ZERO) THEN - IF (NOCONJ) THEN - TEMP = A(J,K) - ELSE - TEMP = DCONJG(A(J,K)) - END IF - DO 350 I = 1,M - B(I,J) = B(I,J) - TEMP*B(I,K) - 350 CONTINUE - END IF - 360 CONTINUE - IF (ALPHA.NE.ONE) THEN - DO 370 I = 1,M - B(I,K) = ALPHA*B(I,K) - 370 CONTINUE - END IF - 380 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTRSM . -* - END - diff --git a/mtx/make/makefile_base b/mtx/make/makefile_base index a288df3cd..a21ae3cb3 100644 --- a/mtx/make/makefile_base +++ b/mtx/make/makefile_base @@ -12,176 +12,6 @@ include $(MESA_DIR)/utils/makefile_header # # SOURCES -# WHB removed dlazq3.f because it fails to compile with ifort 2018: -# ../lapack_src/dlazq3.f(219): error #6633: The type of the actual argument differs from the type of the dummy argument. [IEEE] -# $ DN1, DN2, IEEE ) -# --------------------------------^ -# ../lapack_src/dlazq3.f(218): error #6631: A non-optional actual argument must be present when invoking a procedure with an explicit interface. [IEEE] -# CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, -# --------------^ -# ../lapack_src/dlazq3.f(218): error #6631: A non-optional actual argument must be present when invoking a procedure with an explicit interface. [EPS] -# CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, -# --------------^ - -ifeq ($(WHICH_LAPACK),USE_SRCS) - LAPACK_SRCS = \ - dgbcon.f \ - dgbequ.f \ - dgbrfs.f \ - dgbsv.f \ - dgbsvx.f \ - dgbtf2.f \ - dgbtrf.f \ - dgbtrs.f \ - dgecon.f \ - dgeequ.f \ - dgerfs.f \ - dgesv.f \ - dgesvx.f \ - dgetf2.f \ - dgetrf.f \ - dgetrs.f \ - dgtcon.f \ - dgtrfs.f \ - dgtsv.f \ - dgtsvx.f \ - dgttrf.f \ - dgttrs.f \ - dgtts2.f \ - disnan.f \ - dlacn2.f \ - dlabad.f \ - dlacpy.f \ - dlagtm.f \ - dlangb.f \ - dlange.f \ - dlangt.f \ - dlantb.f \ - dlantr.f \ - dlaqgb.f \ - dlaqge.f \ - dlassq.f \ - dlaswp.f \ - dlatbs.f \ - dlatrs.f \ - drscl.f \ - dgetri.f \ - dgesvd.f \ - dnrm2.f \ - dlasq3.f \ - dlasq4.f \ - dbdsqr.f \ - dgelqf.f \ - dlascl.f \ - dorgbr.f \ - dorgqr.f \ - dtrtri.f \ - dgebrd.f \ - dgeqrf.f \ - dlaset.f \ - dorglq.f \ - dormbr.f \ - dgebd2.f \ - dgeqr2.f \ - dlarfb.f \ - dlartg.f \ - dlasq1.f \ - dlasv2.f \ - dorgl2.f \ - dormqr.f \ - dtrmm.f \ - dgelq2.f \ - dlabrd.f \ - dlarft.f \ - dlas2.f \ - dlasr.f \ - dorg2r.f \ - dormlq.f \ - drot.f \ - dtrti2.f \ - dtrtrs.f \ - dlarf.f \ - dlarfg.f \ - dlasrt.f \ - dorm2r.f \ - dorml2.f \ - dlapy2.f \ - dlasq2.f \ - dtrmv.f \ - dlasq5.f \ - dlasq6.f \ - dlazq4.f \ - dcabs1.f \ - dlamch.f \ - dlaisnan.f \ - icmax1.f \ - ilaclr.f \ - iladlr.f \ - ilaslc.f \ - ilauplo.f \ - ilazlr.f \ - izmax1.f \ - ieeeck.f \ - iladiag.f \ - ilaenv.f \ - ilaslr.f \ - ilaver.f \ - iparmq.f \ - ilaclc.f \ - iladlc.f \ - ilaprec.f \ - ilatrans.f \ - ilazlc.f \ - izamax.f \ - sgesv.f \ - sgetf2.f \ - sgetrf.f \ - sgetrs.f \ - slaswp.f \ - zgbtrf.f \ - zgbtrs.f \ - zgetrf.f \ - zgetrs.f \ - zgetf2.f \ - zlaswp.f \ - zlacgv.f \ - zswap.f \ - zgeru.f \ - ztbsv.f \ - zgemv.f \ - ztrsm.f \ - zgbtf2.f \ - zgttrf.f \ - zgttrs.f \ - zgtts2.f \ - zscal.f \ - zcopy.f \ - zgemm.f \ - dgeev.f \ - dgebal.f \ - dgehrd.f \ - dorghr.f \ - dhseqr.f \ - dtrevc.f \ - dgebak.f \ - dlahr2.f \ - dgehd2.f \ - dlaqr0.f \ - dlahqr.f \ - dlaln2.f \ - dlaqr3.f \ - dlanv2.f \ - dladiv.f \ - dlaqr4.f \ - dlaqr5.f \ - dlaqr1.f \ - dlaqr2.f \ - dormhr.f \ - dtrexc.f \ - dlaexc.f \ - dlasy2.f \ - dlarfx.f -endif LAPACK_QUAD_SRCS = \ qgttrf.f \ @@ -201,39 +31,6 @@ LAPACK_QUAD_SRCS = \ qlamch.f \ qlaswp.f -ifeq ($(WHICH_BLAS),USE_SRCS) - BLAS_SRCS = \ - dgemm.f \ - dtrsm.f \ - xerbla.f \ - lsame.f \ - dger.f \ - dcopy.f \ - dgemv.f \ - dtbsv.f \ - daxpy.f \ - ddot.f \ - dgbmv.f \ - dasum.f \ - dtrsv.f \ - dscal.f \ - dswap.f \ - idamax.f \ - strsm.f \ - sgemm.f \ - slamch.f \ - isamax.f \ - sswap.f \ - sscal.f \ - sger.f \ - zaxpy.f \ - zdotc.f \ - zgerc.f \ - zhemv.f \ - zher2.f \ - ztrsv.f -endif - MTX_SRCS = \ mtx_def.f \ my_lapack95_dble.f90 \ @@ -258,23 +55,10 @@ endif # TARGETS MTX_LIB = libmtx.$(LIB_SUFFIX) -LAPACK_LIB = libmesalapack.$(LIB_SUFFIX) -BLAS_LIB = libmesablas.$(LIB_SUFFIX) - -ifeq ($(WHICH_LAPACK),USE_SRCS) - LAPACK_LIB = libmesalapack.$(LIB_SUFFIX) - BLAS_LIB = libmesablas.$(LIB_SUFFIX) -endif MTX_OBJS = $(patsubst %.f,%.o,$(patsubst %.f90,%.o,$(MTX_SRCS) $(LAPACK_QUAD_SRCS))) -LAPACK_OBJS = $(patsubst %.f,%.o,$(patsubst %.f90,%.o,$(LAPACK_SRCS))) -BLAS_OBJS = $(patsubst %.f,%.o,$(patsubst %.f90,%.o,$(BLAS_SRCS))) -ifeq ($(WHICH_LAPACK),USE_SRCS) - all : $(MTX_LIB) $(LAPACK_LIB) $(BLAS_LIB) -else - all : $(MTX_LIB) -endif +all : $(MTX_LIB) $(MTX_LIB) :$(MTX_OBJS) ifneq ($(QUIET),) @@ -284,22 +68,6 @@ else $(LIB_TOOL) $@ $(MTX_OBJS) endif -$(LAPACK_LIB) : $(LAPACK_OBJS) -ifneq ($(QUIET),) - @echo LIB_TOOL $@ - @$(LIB_TOOL) $@ $(LAPACK_OBJS) -else - $(LIB_TOOL) $@ $(LAPACK_OBJS) -endif - -$(BLAS_LIB) : $(BLAS_OBJS) -ifneq ($(QUIET),) - @echo LIB_TOOL $@ - @$(LIB_TOOL) $@ $(BLAS_OBJS) -else - $(LIB_TOOL) $@ $(BLAS_OBJS) -endif - clean: -@rm -f *.o *.f90 *.mod *genmod.f90 *.so *.a .depend *.smod @@ -309,12 +77,6 @@ install: @$(CP_IF_NEWER) ../public/mtx_*.dek $(MESA_DIR)/include @$(CP_IF_NEWER) ../public/mtx_*.inc $(MESA_DIR)/include @$(CP_IF_NEWER) $(MTX_LIB) $(MESA_DIR)/lib -ifeq ($(WHICH_LAPACK),USE_SRCS) - @$(CP_IF_NEWER) $(BLAS_LIB) $(MESA_DIR)/lib -endif -ifeq ($(WHICH_BLAS),USE_SRCS) - @$(CP_IF_NEWER) $(LAPACK_LIB) $(MESA_DIR)/lib -endif nodeps : $(.DEFAULT_GOAL) @@ -334,15 +96,8 @@ COMPILE_XTRA_NO_OPT = $(COMPILE_BASIC) $(FCnowarn) $(FCfixed) -c COMPILE_CMD = $(COMPILE) -$(LAPACK_OBJS) : COMPILE_CMD = $(COMPILE_XTRA) -std=gnu -w - $(LAPACK_QUAD_OBJS) : COMPILE_CMD = $(COMPILE_XTRA) -w -$(filter-out dlamch.o,$(BLAS_OBJS)) : COMPILE_CMD = $(COMPILE_XTRA) -std=gnu -w - -# must turn off optimization for dlamch or can get infinite loop!!! -dlamch.o : COMPILE_CMD = $(COMPILE_XTRA_NO_OPT) - %.o : %.mod %.o : %.f @@ -368,7 +123,7 @@ endif # # DEPENDENCIES -SRC_PATH = $(MOD_PUBLIC_DIR):$(MOD_PRIVATE_DIR):../blas_src:../lapack_src:../lapack_quad +SRC_PATH = $(MOD_PUBLIC_DIR):$(MOD_PRIVATE_DIR):../lapack_quad vpath %.f $(SRC_PATH) vpath %.f90 $(SRC_PATH) diff --git a/utils/makefile_header b/utils/makefile_header index 368d5ab90..80c721558 100644 --- a/utils/makefile_header +++ b/utils/makefile_header @@ -73,9 +73,6 @@ endif # step 3) specify which LAPACK and BLAS libraries to use for mesa/mtx -WHICH_LAPACK95 = -WHICH_LAPACK = -WHICH_BLAS = LOAD_LAPACK95 = `mesasdk_lapack95_link` LOAD_LAPACK = `mesasdk_lapack_link` LOAD_BLAS = `mesasdk_blas_link` diff --git a/utils/makefile_header_non_mesasdk b/utils/makefile_header_non_mesasdk index 69d983da6..5e8e6f002 100644 --- a/utils/makefile_header_non_mesasdk +++ b/utils/makefile_header_non_mesasdk @@ -40,9 +40,7 @@ endif # step 3) specify which BLAS and LAPACK libraries to use for mesa/mtx # these are the standard defaults -WHICH_LAPACK = USE_SRCS LOAD_LAPACK = -lmesalapack -WHICH_BLAS = USE_SRCS LOAD_BLAS = -lmesablas MKL_INCLUDE =