diff --git a/books/bookvol10.4.pamphlet b/books/bookvol10.4.pamphlet index 2783623..f6ea612 100644 --- a/books/bookvol10.4.pamphlet +++ b/books/bookvol10.4.pamphlet @@ -4102,46 +4102,50 @@ credits() --RGilbert Baumslag Michael Becker Nelson H. F. Beebe --RJay Belanger David Bindel Fred Blair --RVladimir Bondarenko Mark Botch Alexandre Bouyer ---RPeter A. Broadbery Martin Brock Manuel Bronstein ---RStephen Buchwald Florian Bundschuh Luanne Burns ---RWilliam Burge +--RKaren Braman Peter A. Broadbery Martin Brock +--RManuel Bronstein Stephen Buchwald Florian Bundschuh +--RLuanne Burns William Burge Ralph Byers --RQuentin Carpent Robert Caviness Bruce Char ---ROndrej Certik Cheekai Chin David V. Chudnovsky ---RGregory V. Chudnovsky Mark Clements James Cloos ---RJosh Cohen Christophe Conil Don Coppersmith ---RGeorge Corliss Robert Corless Gary Cornell ---RMeino Cramer Claire Di Crescenzo David Cyganski +--ROndrej Certik Tzu-Yi Chen Cheekai Chin +--RDavid V. Chudnovsky Gregory V. Chudnovsky Mark Clements +--RJames Cloos Josh Cohen Christophe Conil +--RDon Coppersmith George Corliss Robert Corless +--RGary Cornell Meino Cramer Claire Di Crescenzo +--RJeremy Du Croz David Cyganski --RNathaniel Daly Timothy Daly Sr. Timothy Daly Jr. ---RJames H. Davenport Didier Deshommes Michael Dewar +--RJames H. Davenport David Day James Demmel +--RDidier Deshommes Michael Dewar Jack Dongarra --RJean Della Dora Gabriel Dos Reis Claire DiCrescendo ---RSam Dooley Lionel Ducos Lee Duhem ---RMartin Dunstan Brian Dupee Dominique Duval +--RSam Dooley Lionel Ducos Iain Duff +--RLee Duhem Martin Dunstan Brian Dupee +--RDominique Duval --RRobert Edwards Heow Eide-Goodman Lars Erickson --RRichard Fateman Bertfried Fauser Stuart Feldman --RJohn Fletcher Brian Ford Albrecht Fortenbacher --RGeorge Frances Constantine Frangos Timothy Freeman --RKorrinn Fu ---RMarc Gaetano Rudiger Gebauer Kathy Gerber ---RPatricia Gianni Samantha Goldrich Holger Gollan ---RTeresa Gomez-Diaz Laureano Gonzalez-Vega Stephen Gortler ---RJohannes Grabmeier Matt Grayson Klaus Ebbe Grue ---RJames Griesmer Vladimir Grinberg Oswald Gschnitzer ---RJocelyn Guidry +--RMarc Gaetano Rudiger Gebauer Van de Geijn +--RKathy Gerber Patricia Gianni Samantha Goldrich +--RHolger Gollan Teresa Gomez-Diaz Laureano Gonzalez-Vega +--RStephen Gortler Johannes Grabmeier Matt Grayson +--RKlaus Ebbe Grue James Griesmer Vladimir Grinberg +--ROswald Gschnitzer Ming Gu Jocelyn Guidry --RGaetan Hache Steve Hague Satoshi Hamaguchi ---RMike Hansen Richard Harke Bill Hart ---RVilya Harvey Martin Hassner Arthur S. Hathaway ---RDan Hatton Waldek Hebisch Karl Hegbloom ---RRalf Hemmecke Henderson Antoine Hersen ---RRoger House Gernot Hueber +--RSven Hammarling Mike Hansen Richard Hanson +--RRichard Harke Bill Hart Vilya Harvey +--RMartin Hassner Arthur S. Hathaway Dan Hatton +--RWaldek Hebisch Karl Hegbloom Ralf Hemmecke +--RHenderson Antoine Hersen Roger House +--RGernot Hueber --RPietro Iglio --RAlejandro Jakubi Richard Jenks ---RKai Kaminski Grant Keady Wilfrid Kendall ---RTony Kennedy Ted Kosan Paul Kosinski ---RKlaus Kusche Bernhard Kutzler +--RWilliam Kahan Kai Kaminski Grant Keady +--RWilfrid Kendall Tony Kennedy Ted Kosan +--RPaul Kosinski Klaus Kusche Bernhard Kutzler --RTim Lahey Larry Lambe Kaj Laurson ---RFranz Lehner Frederic Lehobey Michel Levaud ---RHoward Levy Liu Xiaojun Rudiger Loos ---RMichael Lucks Richard Luczak +--RGeorge L. Legendre Franz Lehner Frederic Lehobey +--RMichel Levaud Howard Levy Ren-Cang Li +--RRudiger Loos Michael Lucks Richard Luczak --RCamm Maguire Francois Maltey Alasdair McAndrew --RBob McElrath Michael McGettrick Ian Meikle --RDavid Mentre Victor S. Miller Gerard Milmeister @@ -4152,22 +4156,23 @@ credits() --RJohn Nelder Godfrey Nolan Arthur Norman --RJinzhong Niu --RMichael O'Connor Summat Oemrawsingh Kostas Oikonomou ---RHumberto Ortiz-Zuazaga +--RHumberto Ortiz-Zuazaga --RJulian A. Padget Bill Page David Parnas --RSusan Pelzel Michel Petitot Didier Pinchon --RAyal Pinkus Jose Alfredo Portes ---RClaude Quitte +--RGregorio Quintana-Orti Claude Quitte --RArthur C. Ralfs Norman Ramsey Anatoly Raportirenko --RAlbert D. Rich Michael Richardson Guilherme Reis ---RRenaud Rioboo Jean Rivlin Nicolas Robidoux ---RSimon Robinson Raymond Rogers Michael Rothstein ---RMartin Rubey +--RHuan Ren Renaud Rioboo Jean Rivlin +--RNicolas Robidoux Simon Robinson Raymond Rogers +--RMichael Rothstein Martin Rubey --RPhilip Santas Alfred Scheerhorn William Schelter --RGerhard Schneider Martin Schoenert Marshall Schor --RFrithjof Schulze Fritz Schwarz Steven Segletes ---RNick Simicich William Sit Elena Smirnova ---RJonathan Steinbach Fabio Stumbo Christine Sundaresan ---RRobert Sutor Moss E. Sweedler Eugene Surowitz +--RV. Sima Nick Simicich William Sit +--RElena Smirnova Jonathan Steinbach Fabio Stumbo +--RChristine Sundaresan Robert Sutor Moss E. Sweedler +--REugene Surowitz --RMax Tegmark T. Doug Telford James Thatcher --RBalbir Thomas Mike Thomas Dylan Thurston --RSteve Toleque Barry Trager Themos T. Tsikas @@ -4175,9 +4180,11 @@ credits() --RBernhard Wall Stephen Watt Jaap Weel --RJuergen Weiss M. Weller Mark Wegman --RJames Wen Thorsten Werther Michael Wester ---RJohn M. Wiley Berhard Will Clifton J. Williamson ---RStephen Wilson Shmuel Winograd Robert Wisbauer ---RSandra Wityak Waldemar Wiwianka Knut Wolf +--RR. Clint Whaley John M. Wiley Berhard Will +--RClifton J. Williamson Stephen Wilson Shmuel Winograd +--RRobert Wisbauer Sandra Wityak Waldemar Wiwianka +--RKnut Wolf +--RLiu Xiaojun --RClifford Yapp David Yun --RVadim Zhytnikov Richard Zippel Evelyn Zoernack --RBruno Zuercher Dan Zwillinger diff --git a/books/bookvol10.5.pamphlet b/books/bookvol10.5.pamphlet index f308ad0..2e20ffd 100644 --- a/books/bookvol10.5.pamphlet +++ b/books/bookvol10.5.pamphlet @@ -743,6 +743,21 @@ the real part and whose cdr is the imaginary part. This fact is used in this implementation. This should really be a macro. +\begin{verbatim} + double precision function dcabs1(z) +C ORIGINAL: +c double complex z,zz +c double precision t(2) +c equivalence (zz,t(1)) +c zz = z +c dcabs1 = dabs(t(1)) + dabs(t(2)) +c NEW + double complex z + dcabs1 = dabs(dble(z)) + dabs(dimag(z)) + return + end + +\end{verbatim} \begin{chunk}{BLAS dcabs1} (defun dcabs1 (z) @@ -766,6 +781,98 @@ This has been replaced everywhere with common lisp's char-equal function which compares characters ignoring case. The type (simple-array character (*)) has been replaced everywhere which character. +\begin{verbatim} + LOGICAL FUNCTION LSAME( CA, CB ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* September 30, 1994 +* +* .. Scalar Arguments .. + CHARACTER CA, CB +* .. +* +* Purpose +* ======= +* +* LSAME returns .TRUE. if CA is the same letter as CB regardless of +* case. +* +* Arguments +* ========= +* +* CA (input) CHARACTER*1 +* CB (input) CHARACTER*1 +* CA and CB specify the single characters to be compared. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ICHAR +* .. +* .. Local Scalars .. + INTEGER INTA, INTB, ZCODE +* .. +* .. Executable Statements .. +* +* 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 + +\end{verbatim} + + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{xerbla BLAS} %\pagehead{xerbla}{xerbla} @@ -777,6 +884,55 @@ It is called if an input parameter has an invalid value. This function has been rewritten everywhere to use the common lisp error function. +\begin{verbatim} + SUBROUTINE XERBLA( SRNAME, INFO ) +* +* -- LAPACK auxiliary routine (preliminary version) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* February 29, 1992 +* +* .. Scalar Arguments .. + CHARACTER*6 SRNAME + INTEGER INFO +* .. +* +* Purpose +* ======= +* +* 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. +* +* Arguments +* ========= +* +* SRNAME (input) CHARACTER*6 +* The name of the routine which called XERBLA. +* +* INFO (input) INTEGER +* The position of the invalid parameter in the parameter list +* of the calling routine. +* +* + WRITE( *, FMT = 9999 )SRNAME, INFO +* +* +* commented out by RLT +* STOP +* + 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', + $ 'an illegal value' ) +* +* End of XERBLA +* + END + +\end{verbatim} + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{BLAS Level 1} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -1207,6 +1363,53 @@ NOTES: \end{chunk} +\begin{verbatim} + double precision function dasum(n,dx,incx) +c +c takes the sum of the absolute values. +c jack dongarra, linpack, 3/11/78. +c modified 3/93 to return if incx .le. 0. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dtemp + integer i,incx,m,mp1,n,nincx +c + dasum = 0.0d0 + dtemp = 0.0d0 + if( n.le.0 .or. incx.le.0 )return + if(incx.eq.1)go to 20 +c +c code for increment not equal to 1 +c + nincx = n*incx + do 10 i = 1,nincx,incx + dtemp = dtemp + dabs(dx(i)) + 10 continue + dasum = dtemp + return +c +c code for increment equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,6) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dtemp = dtemp + dabs(dx(i)) + 30 continue + if( n .lt. 6 ) go to 60 + 40 mp1 = m + 1 + do 50 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)) + 50 continue + 60 dasum = dtemp + return + end + +\end{verbatim} + \begin{chunk}{BLAS 1 dasum} (defun dasum (n dx incx) (declare (type (simple-array double-float (*)) dx) (type fixnum incx n)) @@ -1571,6 +1774,58 @@ RETURN VALUES \end{chunk} +\begin{verbatim} + subroutine daxpy(n,da,dx,incx,dy,incy) +c +c constant times a vector plus a vector. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*),da + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if (da .eq. 0.0d0) return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + 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 + dy(iy) = dy(iy) + da*dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,4) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dy(i) = dy(i) + da*dx(i) + 30 continue + if( n .lt. 4 ) return + 40 mp1 = m + 1 + do 50 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) + 50 continue + return + end + +\end{verbatim} + \begin{chunk}{BLAS 1 daxpy} (defun daxpy (n da dx incx dy incy) (declare (type (simple-array double-float) dx dy) @@ -1903,6 +2158,60 @@ ARGUMENTS \end{chunk} +\begin{verbatim} + subroutine dcopy(n,dx,incx,dy,incy) +c +c copies a vector, x, to a vector, y. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*) + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + 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 + dy(iy) = dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,7) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dy(i) = dx(i) + 30 continue + if( n .lt. 7 ) return + 40 mp1 = m + 1 + do 50 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) + 50 continue + return + end + +\end{verbatim} + \begin{chunk}{BLAS 1 dcopy} (defun dcopy (n dx incx dy incy) (declare (type (simple-array double-float) dy dx) @@ -2012,6 +2321,59 @@ NOTES \end{chunk} +\begin{verbatim} + double precision function ddot(n,dx,incx,dy,incy) +c +c forms the dot product of two vectors. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*),dtemp + integer i,incx,incy,ix,iy,m,mp1,n +c + ddot = 0.0d0 + dtemp = 0.0d0 + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + 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 + dtemp = dtemp + dx(ix)*dy(iy) + ix = ix + incx + iy = iy + incy + 10 continue + ddot = dtemp + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dtemp = dtemp + dx(i)*dy(i) + 30 continue + if( n .lt. 5 ) go to 60 + 40 mp1 = m + 1 + do 50 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) + 50 continue + 60 ddot = dtemp + return + end + +\end{verbatim} + \begin{chunk}{BLAS 1 ddot} (defun ddot (n dx incx dy incy) (declare (type (simple-array double-float (*)) dy dx) @@ -2180,6 +2542,70 @@ NOTES \end{chunk} +\begin{verbatim} + DOUBLE PRECISION FUNCTION DNRM2 ( N, X, INCX ) +* .. Scalar Arguments .. + INTEGER INCX, N +* .. Array Arguments .. + DOUBLE PRECISION X( * ) +* .. +* +* DNRM2 returns the euclidean norm of a vector via the function +* name, so that +* +* DNRM2 := sqrt( x'*x ) +* +* +* +* -- 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 .. + INTEGER IX + DOUBLE PRECISION ABSXI, NORM, SCALE, SSQ +* .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +* .. +* .. Executable Statements .. + 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 + +\end{verbatim} + \begin{chunk}{BLAS 1 dnrm2} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -2347,6 +2773,37 @@ Returns multiple values where: \item 4 s - double-float \end{itemize} +\begin{verbatim} + subroutine drotg(da,db,c,s) +c +c construct givens plane rotation. +c jack dongarra, linpack, 3/11/78. +c + double precision da,db,c,s,roe,scale,r,z +c + roe = db + if( dabs(da) .gt. dabs(db) ) roe = da + scale = dabs(da) + dabs(db) + if( scale .ne. 0.0d0 ) go to 10 + c = 1.0d0 + s = 0.0d0 + r = 0.0d0 + z = 0.0d0 + go to 20 + 10 r = scale*dsqrt((da/scale)**2 + (db/scale)**2) + r = dsign(1.0d0,roe)*r + c = da/r + s = db/r + z = 1.0d0 + if( dabs(da) .gt. dabs(db) ) z = s + if( dabs(db) .ge. dabs(da) .and. c .ne. 0.0d0 ) z = 1.0d0/c + 20 da = r + db = z + return + end + +\end{verbatim} + \begin{chunk}{BLAS 1 drotg} (defun drotg (da db c s) (declare (type (double-float) s c db da)) @@ -2481,6 +2938,47 @@ NOTES \end{chunk} +\begin{verbatim} + subroutine drot (n,dx,incx,dy,incy,c,s) +c +c applies a plane rotation. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*),dtemp,c,s + integer i,incx,incy,ix,iy,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments not equal +c to 1 +c + 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 + dtemp = c*dx(ix) + s*dy(iy) + dy(iy) = c*dy(iy) - s*dx(ix) + dx(ix) = dtemp + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c + 20 do 30 i = 1,n + dtemp = c*dx(i) + s*dy(i) + dy(i) = c*dy(i) - s*dx(i) + dx(i) = dtemp + 30 continue + return + end + +\end{verbatim} + \begin{chunk}{BLAS 1 drot} (defun drot (n dx incx dy incy c s) (declare (type (double-float) s c) @@ -2603,6 +3101,53 @@ NOTES \end{chunk} +\begin{verbatim} + subroutine dscal(n,da,dx,incx) +c +c scales a vector by a constant. +c uses unrolled loops for increment equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 3/93 to return if incx .le. 0. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision da,dx(*) + integer i,incx,m,mp1,n,nincx +c + if( n.le.0 .or. incx.le.0 )return + if(incx.eq.1)go to 20 +c +c code for increment not equal to 1 +c + nincx = n*incx + do 10 i = 1,nincx,incx + dx(i) = da*dx(i) + 10 continue + return +c +c code for increment equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dx(i) = da*dx(i) + 30 continue + if( n .lt. 5 ) return + 40 mp1 = m + 1 + do 50 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) + 50 continue + return + end + +\end{verbatim} + \begin{chunk}{BLAS 1 dscal} (defun dscal (n da dx incx) (declare (type (simple-array double-float (*)) dx) @@ -2754,6 +3299,66 @@ NOTES \end{chunk} +\begin{verbatim} + subroutine dswap (n,dx,incx,dy,incy) +c +c interchanges two vectors. +c uses unrolled loops for increments equal one. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*),dtemp + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments not equal +c to 1 +c + 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 + dtemp = dx(ix) + dx(ix) = dy(iy) + dy(iy) = dtemp + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,3) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dtemp = dx(i) + dx(i) = dy(i) + dy(i) = dtemp + 30 continue + if( n .lt. 3 ) return + 40 mp1 = m + 1 + do 50 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 + 50 continue + return + end + +\end{verbatim} + \begin{chunk}{BLAS 1 dswap} (defun dswap (n dx incx dy incy) (declare (type (simple-array double-float (*)) dy dx) @@ -2934,6 +3539,44 @@ Return values are: \item 3 nil \end{itemize} +\begin{verbatim} + double precision function dzasum(n,zx,incx) +c +c takes the sum of the absolute values. +c jack dongarra, 3/11/78. +c modified 3/93 to return if incx .le. 0. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double complex zx(*) + double precision stemp,dcabs1 + integer i,incx,ix,n +c + dzasum = 0.0d0 + stemp = 0.0d0 + if( n.le.0 .or. incx.le.0 )return + if(incx.eq.1)go to 20 +c +c code for increment not equal to 1 +c + ix = 1 + do 10 i = 1,n + stemp = stemp + dcabs1(zx(ix)) + ix = ix + incx + 10 continue + dzasum = stemp + return +c +c code for increment equal to 1 +c + 20 do 30 i = 1,n + stemp = stemp + dcabs1(zx(i)) + 30 continue + dzasum = stemp + return + end + +\end{verbatim} + \begin{chunk}{BLAS 1 dzasum} (defun dzasum (n zx incx) (declare (type (simple-array (complex double-float) (*)) zx) @@ -3041,6 +3684,77 @@ NOTES \end{chunk} +\begin{verbatim} + DOUBLE PRECISION FUNCTION DZNRM2( N, X, INCX ) +* .. Scalar Arguments .. + INTEGER INCX, N +* .. Array Arguments .. + COMPLEX*16 X( * ) +* .. +* +* DZNRM2 returns the euclidean norm of a vector via the function +* name, so that +* +* DZNRM2 := sqrt( conjg( x' )*x ) +* +* +* +* -- This version written on 25-October-1982. +* Modified on 14-October-1993 to inline the call to ZLASSQ. +* Sven Hammarling, Nag Ltd. +* +* +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. Local Scalars .. + INTEGER IX + DOUBLE PRECISION NORM, SCALE, SSQ, TEMP +* .. Intrinsic Functions .. + INTRINSIC ABS, DIMAG, DBLE, SQRT +* .. +* .. Executable Statements .. + IF( N.LT.1 .OR. INCX.LT.1 )THEN + NORM = ZERO + ELSE + SCALE = ZERO + SSQ = ONE +* The following loop is equivalent to this call to the LAPACK +* auxiliary routine: +* CALL ZLASSQ( N, X, INCX, SCALE, SSQ ) +* + DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX + IF( DBLE( X( IX ) ).NE.ZERO )THEN + TEMP = ABS( DBLE( X( IX ) ) ) + IF( SCALE.LT.TEMP )THEN + SSQ = ONE + SSQ*( SCALE/TEMP )**2 + SCALE = TEMP + ELSE + SSQ = SSQ + ( TEMP/SCALE )**2 + END IF + END IF + IF( DIMAG( X( IX ) ).NE.ZERO )THEN + TEMP = ABS( DIMAG( X( IX ) ) ) + IF( SCALE.LT.TEMP )THEN + SSQ = ONE + SSQ*( SCALE/TEMP )**2 + SCALE = TEMP + ELSE + SSQ = SSQ + ( TEMP/SCALE )**2 + END IF + END IF + 10 CONTINUE + NORM = SCALE * SQRT( SSQ ) + END IF +* + DZNRM2 = NORM + RETURN +* +* End of DZNRM2. +* + END + +\end{verbatim} + \begin{chunk}{BLAS 1 dznrm2} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -3179,6 +3893,53 @@ NOTES \end{chunk} +\begin{verbatim} + integer function icamax(n,cx,incx) +c +c finds the index of element having max. absolute value. +c jack dongarra, linpack, 3/11/78. +c modified 3/93 to return if incx .le. 0. +c modified 12/3/93, array(1) declarations changed to array(*) +c + complex cx(*) + real smax + integer i,incx,ix,n + complex zdum + real cabs1 + cabs1(zdum) = abs(real(zdum)) + abs(aimag(zdum)) +c + icamax = 0 + if( n.lt.1 .or. incx.le.0 ) return + icamax = 1 + if(n.eq.1)return + if(incx.eq.1)go to 20 +c +c code for increment not equal to 1 +c + ix = 1 + smax = cabs1(cx(1)) + ix = ix + incx + do 10 i = 2,n + if(cabs1(cx(ix)).le.smax) go to 5 + icamax = i + smax = cabs1(cx(ix)) + 5 ix = ix + incx + 10 continue + return +c +c code for increment equal to 1 +c + 20 smax = cabs1(cx(1)) + do 30 i = 2,n + if(cabs1(cx(i)).le.smax) go to 30 + icamax = i + smax = cabs1(cx(i)) + 30 continue + return + end + +\end{verbatim} + \begin{chunk}{BLAS 1 icamax} (defun icamax (n cx incx) (declare (type (simple-array (complex single-float) (*)) cx) @@ -3305,6 +4066,49 @@ NOTES \end{chunk} +\begin{verbatim} + integer function idamax(n,dx,incx) +c +c finds the index of element having max. absolute value. +c jack dongarra, linpack, 3/11/78. +c modified 3/93 to return if incx .le. 0. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dmax + integer i,incx,ix,n +c + idamax = 0 + if( n.lt.1 .or. incx.le.0 ) return + idamax = 1 + if(n.eq.1)return + if(incx.eq.1)go to 20 +c +c code for increment not equal to 1 +c + ix = 1 + dmax = dabs(dx(1)) + ix = ix + incx + do 10 i = 2,n + if(dabs(dx(ix)).le.dmax) go to 5 + idamax = i + dmax = dabs(dx(ix)) + 5 ix = ix + incx + 10 continue + return +c +c code for increment equal to 1 +c + 20 dmax = dabs(dx(1)) + do 30 i = 2,n + if(dabs(dx(i)).le.dmax) go to 30 + idamax = i + dmax = dabs(dx(i)) + 30 continue + return + end + +\end{verbatim} + \begin{chunk}{BLAS 1 idamax} (defun idamax (n dx incx) (declare (type (simple-array double-float (*)) dx) @@ -3445,6 +4249,49 @@ NOTES \end{chunk} +\begin{verbatim} + integer function isamax(n,sx,incx) +c +c finds the index of element having max. absolute value. +c jack dongarra, linpack, 3/11/78. +c modified 3/93 to return if incx .le. 0. +c modified 12/3/93, array(1) declarations changed to array(*) +c + real sx(*),smax + integer i,incx,ix,n +c + isamax = 0 + if( n.lt.1 .or. incx.le.0 ) return + isamax = 1 + if(n.eq.1)return + if(incx.eq.1)go to 20 +c +c code for increment not equal to 1 +c + ix = 1 + smax = abs(sx(1)) + ix = ix + incx + do 10 i = 2,n + if(abs(sx(ix)).le.smax) go to 5 + isamax = i + smax = abs(sx(ix)) + 5 ix = ix + incx + 10 continue + return +c +c code for increment equal to 1 +c + 20 smax = abs(sx(1)) + do 30 i = 2,n + if(abs(sx(i)).le.smax) go to 30 + isamax = i + smax = abs(sx(i)) + 30 continue + return + end + +\end{verbatim} + \begin{chunk}{BLAS 1 isamax} (defun isamax (n sx incx) (declare (type (simple-array single-float (*)) sx) @@ -3565,6 +4412,51 @@ NOTES \end{chunk} +\begin{verbatim} + integer function izamax(n,zx,incx) +c +c finds the index of element having max. absolute value. +c jack dongarra, 1/15/85. +c modified 3/93 to return if incx .le. 0. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double complex zx(*) + double precision smax + integer i,incx,ix,n + double precision dcabs1 +c + 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 +c +c code for increment not equal to 1 +c + 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 +c +c code for increment equal to 1 +c + 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 + +\end{verbatim} + \begin{chunk}{BLAS 1 izamax} (defun izamax (n zx incx) (declare (type (simple-array (complex double-float) (*)) zx) @@ -3725,6 +4617,44 @@ Return values are: \item 6 nil \end{itemize} +\begin{verbatim} + subroutine zaxpy(n,za,zx,incx,zy,incy) +c +c constant times a vector plus a vector. +c jack dongarra, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double complex zx(*),zy(*),za + integer i,incx,incy,ix,iy,n + double precision dcabs1 + if(n.le.0)return + if (dcabs1(za) .eq. 0.0d0) return + if (incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + 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) = zy(iy) + za*zx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c + 20 do 30 i = 1,n + zy(i) = zy(i) + za*zx(i) + 30 continue + return + end + +\end{verbatim} + \begin{chunk}{BLAS 1 zaxpy} (defun zaxpy (n za zx incx zy incy) (declare (type (simple-array (complex double-float) (*)) zy zx) @@ -3849,6 +4779,43 @@ NOTES \end{chunk} +\begin{verbatim} + subroutine zcopy(n,zx,incx,zy,incy) +c +c copies a vector, x, to a vector, y. +c jack dongarra, linpack, 4/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double complex zx(*),zy(*) + integer i,incx,incy,ix,iy,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + 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 +c +c code for both increments equal to 1 +c + 20 do 30 i = 1,n + zy(i) = zx(i) + 30 continue + return + end + +\end{verbatim} + \begin{chunk}{BLAS 1 zcopy} (defun zcopy (n zx incx zy incy) (declare (type (simple-array (complex double-float) (*)) zy zx) @@ -3981,6 +4948,46 @@ NOTES \end{chunk} +\begin{verbatim} + double complex function zdotc(n,zx,incx,zy,incy) +c +c forms the dot product of a vector. +c jack dongarra, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double complex zx(*),zy(*),ztemp + integer i,incx,incy,ix,iy,n + ztemp = (0.0d0,0.0d0) + zdotc = (0.0d0,0.0d0) + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + 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 = ztemp + dconjg(zx(ix))*zy(iy) + ix = ix + incx + iy = iy + incy + 10 continue + zdotc = ztemp + return +c +c code for both increments equal to 1 +c + 20 do 30 i = 1,n + ztemp = ztemp + dconjg(zx(i))*zy(i) + 30 continue + zdotc = ztemp + return + end + +\end{verbatim} + \begin{chunk}{BLAS 1 zdotc} (defun zdotc (n zx incx zy incy) (declare (type (simple-array (complex double-float) (*)) zy zx) @@ -4119,6 +5126,46 @@ NOTES \end{chunk} +\begin{verbatim} + double complex function zdotu(n,zx,incx,zy,incy) +c +c forms the dot product of two vectors. +c jack dongarra, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double complex zx(*),zy(*),ztemp + integer i,incx,incy,ix,iy,n + ztemp = (0.0d0,0.0d0) + zdotu = (0.0d0,0.0d0) + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + 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 = ztemp + zx(ix)*zy(iy) + ix = ix + incx + iy = iy + incy + 10 continue + zdotu = ztemp + return +c +c code for both increments equal to 1 +c + 20 do 30 i = 1,n + ztemp = ztemp + zx(i)*zy(i) + 30 continue + zdotu = ztemp + return + end + +\end{verbatim} + \begin{chunk}{BLAS 1 zdotu} (defun zdotu (n zx incx zy incy) (declare (type (simple-array (complex double-float) (*)) zy zx) @@ -4242,6 +5289,40 @@ NOTES \end{chunk} +\begin{verbatim} + subroutine zdscal(n,da,zx,incx) +c +c scales a vector by a constant. +c jack dongarra, 3/11/78. +c modified 3/93 to return if incx .le. 0. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double complex zx(*) + double precision da + integer i,incx,ix,n +c + if( n.le.0 .or. incx.le.0 )return + if(incx.eq.1)go to 20 +c +c code for increment not equal to 1 +c + ix = 1 + do 10 i = 1,n + zx(ix) = dcmplx(da,0.0d0)*zx(ix) + ix = ix + incx + 10 continue + return +c +c code for increment equal to 1 +c + 20 do 30 i = 1,n + zx(i) = dcmplx(da,0.0d0)*zx(i) + 30 continue + return + end + +\end{verbatim} + \begin{chunk}{BLAS 1 zdscal} (defun zdscal (n da zx incx) (declare (type (simple-array (complex double-float) (*)) zx) @@ -4390,6 +5471,31 @@ Returns multiple values where: \item 4 s - s \end{itemize} +\begin{verbatim} + subroutine zrotg(ca,cb,c,s) + double complex ca,cb,s + double precision c + double precision norm,scale + double complex alpha + if (cdabs(ca) .ne. 0.0d0) go to 10 + c = 0.0d0 + s = (1.0d0,0.0d0) + ca = cb + go to 20 + 10 continue + scale = cdabs(ca) + cdabs(cb) + norm = scale*dsqrt((cdabs(ca/dcmplx(scale,0.0d0)))**2 + + * (cdabs(cb/dcmplx(scale,0.0d0)))**2) + alpha = ca /cdabs(ca) + c = cdabs(ca) / norm + s = alpha * dconjg(cb) / norm + ca = alpha * norm + 20 continue + return + end + +\end{verbatim} + \begin{chunk}{BLAS 1 zrotg} (defun zrotg (ca cb c s) (declare (type (double-float) c) (type (complex double-float) s cb ca)) @@ -4491,6 +5597,39 @@ NOTES \end{chunk} +\begin{verbatim} + subroutine zscal(n,za,zx,incx) +c +c scales a vector by a constant. +c jack dongarra, 3/11/78. +c modified 3/93 to return if incx .le. 0. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double complex za,zx(*) + integer i,incx,ix,n +c + if( n.le.0 .or. incx.le.0 )return + if(incx.eq.1)go to 20 +c +c code for increment not equal to 1 +c + ix = 1 + do 10 i = 1,n + zx(ix) = za*zx(ix) + ix = ix + incx + 10 continue + return +c +c code for increment equal to 1 +c + 20 do 30 i = 1,n + zx(i) = za*zx(i) + 30 continue + return + end + +\end{verbatim} + \begin{chunk}{BLAS 1 zscal} (defun zscal (n za zx incx) (declare (type (simple-array (complex double-float) (*)) zx) @@ -4597,6 +5736,46 @@ NOTES \end{chunk} +\begin{verbatim} + subroutine zswap (n,zx,incx,zy,incy) +c +c interchanges two vectors. +c jack dongarra, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double complex zx(*),zy(*),ztemp + integer i,incx,incy,ix,iy,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments not equal +c to 1 +c + 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 +c +c 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 + +\end{verbatim} + \begin{chunk}{BLAS 1 zswap} (defun zswap (n zx incx zy incy) (declare (type (simple-array (complex double-float) (*)) zy zx) @@ -4786,6 +5965,203 @@ Man Page Details \end{chunk} +\begin{verbatim} + 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*1 TRANS +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* +* 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 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 +* .. +* .. Executable Statements .. +* +* 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'*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 + +\end{verbatim} + \begin{chunk}{BLAS 2 dgbmv} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -5179,6 +6555,190 @@ Man Page Details \end{chunk} +\begin{verbatim} + 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*1 TRANS +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* +* 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 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 +* .. +* .. Executable Statements .. +* +* 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'*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 + +\end{verbatim} + \begin{chunk}{BLAS 2 dgemv} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -5496,6 +7056,106 @@ Man Page Details \end{chunk} +\begin{verbatim} + 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( * ) +* .. +* +* 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 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 +* .. +* .. 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( 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 + +\end{verbatim} + \begin{chunk}{BLAS 2 dger} (let* ((zero 0.0)) (declare (type (double-float 0.0 0.0) zero)) @@ -5748,6 +7408,202 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE DSBMV ( UPLO, N, K, ALPHA, A, LDA, X, INCX, + $ BETA, Y, INCY ) +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, K, LDA, N + CHARACTER*1 UPLO +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* 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 PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP1, TEMP2 + INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( K.LT.0 )THEN + INFO = 3 + ELSE IF( LDA.LT.( K + 1 ) )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( 'DSBMV ', 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 the array 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, 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 upper triangle of A is stored. +* + KPLUS1 = K + 1 + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 60, J = 1, N + TEMP1 = ALPHA*X( J ) + TEMP2 = ZERO + L = KPLUS1 - J + DO 50, I = MAX( 1, J - K ), J - 1 + Y( I ) = Y( I ) + TEMP1*A( L + I, J ) + TEMP2 = TEMP2 + A( L + I, J )*X( I ) + 50 CONTINUE + Y( J ) = Y( J ) + TEMP1*A( KPLUS1, 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 + L = KPLUS1 - J + DO 70, I = MAX( 1, J - K ), J - 1 + Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) + TEMP2 = TEMP2 + A( L + I, J )*X( IX ) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y( JY ) = Y( JY ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + IF( J.GT.K )THEN + KX = KX + INCX + KY = KY + INCY + END IF + 80 CONTINUE + END IF + ELSE +* +* Form y when lower triangle of A is stored. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 100, J = 1, N + TEMP1 = ALPHA*X( J ) + TEMP2 = ZERO + Y( J ) = Y( J ) + TEMP1*A( 1, J ) + L = 1 - J + DO 90, I = J + 1, MIN( N, J + K ) + Y( I ) = Y( I ) + TEMP1*A( L + I, J ) + TEMP2 = TEMP2 + A( L + I, J )*X( I ) + 90 CONTINUE + Y( J ) = Y( J ) + ALPHA*TEMP2 + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120, J = 1, N + TEMP1 = ALPHA*X( JX ) + TEMP2 = ZERO + Y( JY ) = Y( JY ) + TEMP1*A( 1, J ) + L = 1 - J + IX = JX + IY = JY + DO 110, I = J + 1, MIN( N, J + K ) + IX = IX + INCX + IY = IY + INCY + Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) + TEMP2 = TEMP2 + A( L + 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 DSBMV . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 2 dsbmv} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -6173,6 +8029,196 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE DSPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, N + CHARACTER*1 UPLO +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), X( * ), Y( * ) +* .. +* + +* 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 PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP1, TEMP2 + INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( INCX.EQ.0 )THEN + INFO = 6 + ELSE IF( INCY.EQ.0 )THEN + INFO = 9 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSPMV ', 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 the array AP +* are accessed sequentially with one pass through AP. +* +* 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 + KK = 1 + IF( LSAME( UPLO, 'U' ) )THEN +* +* Form y when AP contains the upper triangle. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 60, J = 1, N + TEMP1 = ALPHA*X( J ) + TEMP2 = ZERO + K = KK + DO 50, I = 1, J - 1 + Y( I ) = Y( I ) + TEMP1*AP( K ) + TEMP2 = TEMP2 + AP( K )*X( I ) + K = K + 1 + 50 CONTINUE + Y( J ) = Y( J ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 + KK = KK + J + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80, J = 1, N + TEMP1 = ALPHA*X( JX ) + TEMP2 = ZERO + IX = KX + IY = KY + DO 70, K = KK, KK + J - 2 + Y( IY ) = Y( IY ) + TEMP1*AP( K ) + TEMP2 = TEMP2 + AP( K )*X( IX ) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y( JY ) = Y( JY ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + KK = KK + J + 80 CONTINUE + END IF + ELSE +* +* Form y when AP contains the 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*AP( KK ) + K = KK + 1 + DO 90, I = J + 1, N + Y( I ) = Y( I ) + TEMP1*AP( K ) + TEMP2 = TEMP2 + AP( K )*X( I ) + K = K + 1 + 90 CONTINUE + Y( J ) = Y( J ) + ALPHA*TEMP2 + KK = KK + ( N - J + 1 ) + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120, J = 1, N + TEMP1 = ALPHA*X( JX ) + TEMP2 = ZERO + Y( JY ) = Y( JY ) + TEMP1*AP( KK ) + IX = JX + IY = JY + DO 110, K = KK + 1, KK + N - J + IX = IX + INCX + IY = IY + INCY + Y( IY ) = Y( IY ) + TEMP1*AP( K ) + TEMP2 = TEMP2 + AP( K )*X( IX ) + 110 CONTINUE + Y( JY ) = Y( JY ) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + KK = KK + ( N - J + 1 ) + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSPMV . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 2 dspmv} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -6589,6 +8635,164 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE DSPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP ) +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX, INCY, N + CHARACTER*1 UPLO +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), X( * ), Y( * ) +* .. +* +* 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 PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP1, TEMP2 + INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( INCX.EQ.0 )THEN + INFO = 5 + ELSE IF( INCY.EQ.0 )THEN + INFO = 7 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSPR2 ', 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 the array AP +* are accessed sequentially with one pass through AP. +* + KK = 1 + IF( LSAME( UPLO, 'U' ) )THEN +* +* Form A when upper triangle is stored in AP. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 20, J = 1, N + IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y( J ) + TEMP2 = ALPHA*X( J ) + K = KK + DO 10, I = 1, J + AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 + K = K + 1 + 10 CONTINUE + END IF + KK = KK + J + 20 CONTINUE + ELSE + DO 40, J = 1, N + IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y( JY ) + TEMP2 = ALPHA*X( JX ) + IX = KX + IY = KY + DO 30, K = KK, KK + J - 1 + AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + KK = KK + J + 40 CONTINUE + END IF + ELSE +* +* Form A when lower triangle is stored in AP. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 60, J = 1, N + IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y( J ) + TEMP2 = ALPHA*X( J ) + K = KK + DO 50, I = J, N + AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 + K = K + 1 + 50 CONTINUE + END IF + KK = KK + N - J + 1 + 60 CONTINUE + ELSE + DO 80, J = 1, N + IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y( JY ) + TEMP2 = ALPHA*X( JX ) + IX = JX + IY = JY + DO 70, K = KK, KK + N - J + AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSPR2 . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 2 dspr2} (let* ((zero 0.0)) (declare (type (double-float 0.0 0.0) zero)) @@ -6959,6 +9163,144 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE DSPR ( UPLO, N, ALPHA, X, INCX, AP ) +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX, N + CHARACTER*1 UPLO +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), X( * ) +* .. +* +* 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 PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, J, JX, K, KK, KX +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( INCX.EQ.0 )THEN + INFO = 5 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSPR ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) + $ RETURN +* +* Set the start point in X if the increment is not unity. +* + IF( INCX.LE.0 )THEN + KX = 1 - ( N - 1 )*INCX + ELSE IF( INCX.NE.1 )THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of the array AP +* are accessed sequentially with one pass through AP. +* + KK = 1 + IF( LSAME( UPLO, 'U' ) )THEN +* +* Form A when upper triangle is stored in AP. +* + IF( INCX.EQ.1 )THEN + DO 20, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = ALPHA*X( J ) + K = KK + DO 10, I = 1, J + AP( K ) = AP( K ) + X( I )*TEMP + K = K + 1 + 10 CONTINUE + END IF + KK = KK + J + 20 CONTINUE + ELSE + JX = KX + DO 40, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*X( JX ) + IX = KX + DO 30, K = KK, KK + J - 1 + AP( K ) = AP( K ) + X( IX )*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JX = JX + INCX + KK = KK + J + 40 CONTINUE + END IF + ELSE +* +* Form A when lower triangle is stored in AP. +* + IF( INCX.EQ.1 )THEN + DO 60, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = ALPHA*X( J ) + K = KK + DO 50, I = J, N + AP( K ) = AP( K ) + X( I )*TEMP + K = K + 1 + 50 CONTINUE + END IF + KK = KK + N - J + 1 + 60 CONTINUE + ELSE + JX = KX + DO 80, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*X( JX ) + IX = JX + DO 70, K = KK, KK + N - J + AP( K ) = AP( K ) + X( IX )*TEMP + IX = IX + INCX + 70 CONTINUE + END IF + JX = JX + INCX + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSPR . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 2 dspr} (let* ((zero 0.0)) (declare (type (double-float 0.0 0.0) zero)) @@ -7270,6 +9612,192 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE DSYMV ( UPLO, N, ALPHA, A, LDA, X, INCX, + $ BETA, Y, INCY ) +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, LDA, N + CHARACTER*1 UPLO +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* 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 PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP1, TEMP2 + INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = 5 + ELSE IF( INCX.EQ.0 )THEN + INFO = 7 + ELSE IF( INCY.EQ.0 )THEN + INFO = 10 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSYMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set up the start points in X and Y. +* + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( N - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( N - 1 )*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the triangular part +* of A. +* +* First form y := beta*y. +* + IF( BETA.NE.ONE )THEN + IF( INCY.EQ.1 )THEN + IF( BETA.EQ.ZERO )THEN + DO 10, I = 1, N + Y( I ) = ZERO + 10 CONTINUE + ELSE + DO 20, I = 1, N + Y( I ) = BETA*Y( I ) + 20 CONTINUE + END IF + ELSE + IY = KY + IF( BETA.EQ.ZERO )THEN + DO 30, I = 1, N + Y( IY ) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40, I = 1, N + Y( IY ) = BETA*Y( IY ) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF( ALPHA.EQ.ZERO ) + $ RETURN + IF( LSAME( UPLO, 'U' ) )THEN +* +* Form y when A is stored in upper triangle. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 60, J = 1, N + TEMP1 = ALPHA*X( J ) + TEMP2 = ZERO + DO 50, I = 1, J - 1 + Y( I ) = Y( I ) + TEMP1*A( I, J ) + TEMP2 = TEMP2 + A( I, J )*X( I ) + 50 CONTINUE + Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2 + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80, J = 1, N + TEMP1 = ALPHA*X( JX ) + TEMP2 = ZERO + IX = KX + IY = KY + DO 70, I = 1, J - 1 + Y( IY ) = Y( IY ) + TEMP1*A( I, J ) + TEMP2 = TEMP2 + A( I, J )*X( IX ) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + ELSE +* +* Form y when A is stored in lower triangle. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 100, J = 1, N + TEMP1 = ALPHA*X( J ) + TEMP2 = ZERO + Y( J ) = Y( J ) + TEMP1*A( J, J ) + DO 90, I = J + 1, N + Y( I ) = Y( I ) + TEMP1*A( I, J ) + TEMP2 = TEMP2 + A( I, J )*X( I ) + 90 CONTINUE + Y( J ) = Y( J ) + ALPHA*TEMP2 + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120, J = 1, N + TEMP1 = ALPHA*X( JX ) + TEMP2 = ZERO + Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + IX = JX + IY = JY + DO 110, I = J + 1, N + IX = IX + INCX + IY = IY + INCY + Y( IY ) = Y( IY ) + TEMP1*A( I, J ) + TEMP2 = TEMP2 + A( I, J )*X( IX ) + 110 CONTINUE + Y( JY ) = Y( JY ) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSYMV . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 2 dsymv} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -7665,6 +10193,162 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE DSYR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX, INCY, LDA, N + CHARACTER*1 UPLO +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* 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 PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP1, TEMP2 + INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( INCX.EQ.0 )THEN + INFO = 5 + ELSE IF( INCY.EQ.0 )THEN + INFO = 7 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = 9 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSYR2 ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) + $ RETURN +* +* Set up the start points in X and Y if the increments are not both +* unity. +* + IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( N - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( N - 1 )*INCY + END IF + JX = KX + JY = KY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the triangular part +* of A. +* + IF( LSAME( UPLO, 'U' ) )THEN +* +* Form A when A is stored in the upper triangle. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 20, J = 1, N + IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y( J ) + TEMP2 = ALPHA*X( J ) + DO 10, I = 1, J + A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + DO 40, J = 1, N + IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y( JY ) + TEMP2 = ALPHA*X( JX ) + IX = KX + IY = KY + DO 30, I = 1, J + A( I, J ) = A( I, J ) + X( IX )*TEMP1 + $ + Y( IY )*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + 40 CONTINUE + END IF + ELSE +* +* Form A when A is stored in the lower triangle. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 60, J = 1, N + IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y( J ) + TEMP2 = ALPHA*X( J ) + DO 50, I = J, N + A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + DO 80, J = 1, N + IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y( JY ) + TEMP2 = ALPHA*X( JX ) + IX = JX + IY = JY + DO 70, I = J, N + A( I, J ) = A( I, J ) + X( IX )*TEMP1 + $ + Y( IY )*TEMP2 + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSYR2 . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 2 dsyr2} (let* ((zero 0.0)) (declare (type (double-float 0.0 0.0) zero)) @@ -8017,6 +10701,140 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE DSYR ( UPLO, N, ALPHA, X, INCX, A, LDA ) +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX, LDA, N + CHARACTER*1 UPLO +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ) +* .. +* +* 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 PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, J, JX, KX +* .. 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( 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( LDA.LT.MAX( 1, N ) )THEN + INFO = 7 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSYR ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) + $ RETURN +* +* Set the start point in X if the increment is not unity. +* + IF( INCX.LE.0 )THEN + KX = 1 - ( N - 1 )*INCX + ELSE IF( INCX.NE.1 )THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of 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 upper triangle. +* + IF( INCX.EQ.1 )THEN + DO 20, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = ALPHA*X( J ) + DO 10, I = 1, J + A( I, J ) = A( I, J ) + X( I )*TEMP + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*X( JX ) + IX = KX + DO 30, I = 1, J + A( I, J ) = A( I, J ) + X( IX )*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JX = JX + INCX + 40 CONTINUE + END IF + ELSE +* +* Form A when A is stored in lower triangle. +* + IF( INCX.EQ.1 )THEN + DO 60, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = ALPHA*X( J ) + DO 50, I = J, N + A( I, J ) = A( I, J ) + X( I )*TEMP + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*X( JX ) + IX = JX + DO 70, I = J, N + A( I, J ) = A( I, J ) + X( IX )*TEMP + IX = IX + INCX + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSYR . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 2 dsyr} (let* ((zero 0.0)) (declare (type (double-float 0.0 0.0) zero)) @@ -8340,6 +11158,233 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE DTBMV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) +* .. Scalar Arguments .. + INTEGER INCX, K, LDA, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ) +* .. +* +* 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 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 +* .. +* .. Executable Statements .. +* +* 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( 'DTBMV ', 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 + KPLUS1 = K + 1 + IF( INCX.EQ.1 )THEN + DO 20, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = X( J ) + L = KPLUS1 - J + DO 10, I = MAX( 1, J - K ), J - 1 + X( I ) = X( I ) + TEMP*A( L + I, J ) + 10 CONTINUE + IF( NOUNIT ) + $ X( J ) = X( J )*A( KPLUS1, J ) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = X( JX ) + IX = KX + L = KPLUS1 - J + DO 30, I = MAX( 1, J - K ), J - 1 + X( IX ) = X( IX ) + TEMP*A( L + I, J ) + IX = IX + INCX + 30 CONTINUE + IF( NOUNIT ) + $ X( JX ) = X( JX )*A( KPLUS1, J ) + END IF + JX = JX + INCX + IF( J.GT.K ) + $ KX = KX + 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 ) + L = 1 - J + DO 50, I = MIN( N, J + K ), J + 1, -1 + X( I ) = X( I ) + TEMP*A( L + I, J ) + 50 CONTINUE + IF( NOUNIT ) + $ X( J ) = X( J )*A( 1, 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 + L = 1 - J + DO 70, I = MIN( N, J + K ), J + 1, -1 + X( IX ) = X( IX ) + TEMP*A( L + I, J ) + IX = IX - INCX + 70 CONTINUE + IF( NOUNIT ) + $ X( JX ) = X( JX )*A( 1, J ) + END IF + JX = JX - INCX + IF( ( N - J ).GE.K ) + $ KX = KX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A'*x. +* + IF( LSAME( UPLO, 'U' ) )THEN + KPLUS1 = K + 1 + IF( INCX.EQ.1 )THEN + DO 100, J = N, 1, -1 + TEMP = X( J ) + L = KPLUS1 - J + IF( NOUNIT ) + $ TEMP = TEMP*A( KPLUS1, J ) + DO 90, I = J - 1, MAX( 1, J - K ), -1 + TEMP = TEMP + A( L + I, J )*X( I ) + 90 CONTINUE + X( J ) = TEMP + 100 CONTINUE + ELSE + KX = KX + ( N - 1 )*INCX + JX = KX + DO 120, J = N, 1, -1 + TEMP = X( JX ) + KX = KX - INCX + IX = KX + L = KPLUS1 - J + IF( NOUNIT ) + $ TEMP = TEMP*A( KPLUS1, J ) + DO 110, I = J - 1, MAX( 1, J - K ), -1 + TEMP = TEMP + A( L + I, J )*X( IX ) + IX = IX - INCX + 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 ) + L = 1 - J + IF( NOUNIT ) + $ TEMP = TEMP*A( 1, J ) + DO 130, I = J + 1, MIN( N, J + K ) + TEMP = TEMP + A( L + I, J )*X( I ) + 130 CONTINUE + X( J ) = TEMP + 140 CONTINUE + ELSE + JX = KX + DO 160, J = 1, N + TEMP = X( JX ) + KX = KX + INCX + IX = KX + L = 1 - J + IF( NOUNIT ) + $ TEMP = TEMP*A( 1, J ) + DO 150, I = J + 1, MIN( N, J + K ) + TEMP = TEMP + A( L + I, J )*X( IX ) + IX = IX + INCX + 150 CONTINUE + X( JX ) = TEMP + JX = JX + INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTBMV . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 2 dtbmv} (let* ((zero 0.0)) (declare (type (double-float 0.0 0.0) zero)) @@ -8937,6 +11982,233 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE DTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) +* .. Scalar Arguments .. + INTEGER INCX, K, LDA, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ) +* .. +* +* 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 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 +* .. +* .. Executable Statements .. +* +* 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')*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 + +\end{verbatim} + \begin{chunk}{BLAS 2 dtbsv} (let* ((zero 0.0)) (declare (type (double-float 0.0 0.0) zero)) @@ -9498,6 +12770,230 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE DTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) +* .. Scalar Arguments .. + INTEGER INCX, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), X( * ) +* .. +* +* 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 PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, J, JX, K, KK, KX + LOGICAL NOUNIT +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO , 'U' ).AND. + $ .NOT.LSAME( UPLO , 'L' ) )THEN + INFO = 1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. + $ .NOT.LSAME( TRANS, 'T' ).AND. + $ .NOT.LSAME( TRANS, 'C' ) )THEN + INFO = 2 + ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. + $ .NOT.LSAME( DIAG , 'N' ) )THEN + INFO = 3 + ELSE IF( N.LT.0 )THEN + INFO = 4 + ELSE IF( INCX.EQ.0 )THEN + INFO = 7 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DTPMV ', 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 AP are +* accessed sequentially with one pass through AP. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* Form x:= A*x. +* + IF( LSAME( UPLO, 'U' ) )THEN + KK =1 + IF( INCX.EQ.1 )THEN + DO 20, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = X( J ) + K = KK + DO 10, I = 1, J - 1 + X( I ) = X( I ) + TEMP*AP( K ) + K = K + 1 + 10 CONTINUE + IF( NOUNIT ) + $ X( J ) = X( J )*AP( KK + J - 1 ) + END IF + KK = KK + J + 20 CONTINUE + ELSE + JX = KX + DO 40, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = X( JX ) + IX = KX + DO 30, K = KK, KK + J - 2 + X( IX ) = X( IX ) + TEMP*AP( K ) + IX = IX + INCX + 30 CONTINUE + IF( NOUNIT ) + $ X( JX ) = X( JX )*AP( KK + J - 1 ) + END IF + JX = JX + INCX + KK = KK + J + 40 CONTINUE + END IF + ELSE + KK = ( N*( N + 1 ) )/2 + IF( INCX.EQ.1 )THEN + DO 60, J = N, 1, -1 + IF( X( J ).NE.ZERO )THEN + TEMP = X( J ) + K = KK + DO 50, I = N, J + 1, -1 + X( I ) = X( I ) + TEMP*AP( K ) + K = K - 1 + 50 CONTINUE + IF( NOUNIT ) + $ X( J ) = X( J )*AP( KK - N + J ) + END IF + KK = KK - ( N - J + 1 ) + 60 CONTINUE + ELSE + KX = KX + ( N - 1 )*INCX + JX = KX + DO 80, J = N, 1, -1 + IF( X( JX ).NE.ZERO )THEN + TEMP = X( JX ) + IX = KX + DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1 + X( IX ) = X( IX ) + TEMP*AP( K ) + IX = IX - INCX + 70 CONTINUE + IF( NOUNIT ) + $ X( JX ) = X( JX )*AP( KK - N + J ) + END IF + JX = JX - INCX + KK = KK - ( N - J + 1 ) + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A'*x. +* + IF( LSAME( UPLO, 'U' ) )THEN + KK = ( N*( N + 1 ) )/2 + IF( INCX.EQ.1 )THEN + DO 100, J = N, 1, -1 + TEMP = X( J ) + IF( NOUNIT ) + $ TEMP = TEMP*AP( KK ) + K = KK - 1 + DO 90, I = J - 1, 1, -1 + TEMP = TEMP + AP( K )*X( I ) + K = K - 1 + 90 CONTINUE + X( J ) = TEMP + KK = KK - J + 100 CONTINUE + ELSE + JX = KX + ( N - 1 )*INCX + DO 120, J = N, 1, -1 + TEMP = X( JX ) + IX = JX + IF( NOUNIT ) + $ TEMP = TEMP*AP( KK ) + DO 110, K = KK - 1, KK - J + 1, -1 + IX = IX - INCX + TEMP = TEMP + AP( K )*X( IX ) + 110 CONTINUE + X( JX ) = TEMP + JX = JX - INCX + KK = KK - J + 120 CONTINUE + END IF + ELSE + KK = 1 + IF( INCX.EQ.1 )THEN + DO 140, J = 1, N + TEMP = X( J ) + IF( NOUNIT ) + $ TEMP = TEMP*AP( KK ) + K = KK + 1 + DO 130, I = J + 1, N + TEMP = TEMP + AP( K )*X( I ) + K = K + 1 + 130 CONTINUE + X( J ) = TEMP + KK = KK + ( N - J + 1 ) + 140 CONTINUE + ELSE + JX = KX + DO 160, J = 1, N + TEMP = X( JX ) + IX = JX + IF( NOUNIT ) + $ TEMP = TEMP*AP( KK ) + DO 150, K = KK + 1, KK + N - J + IX = IX + INCX + TEMP = TEMP + AP( K )*X( IX ) + 150 CONTINUE + X( JX ) = TEMP + JX = JX + INCX + KK = KK + ( N - J + 1 ) + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTPMV . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 2 dtpmv} (let* ((zero 0.0)) (declare (type (double-float 0.0 0.0) zero)) @@ -10061,6 +13557,230 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE DTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) +* .. Scalar Arguments .. + INTEGER INCX, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), X( * ) +* .. +* +* 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 PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, J, JX, K, KK, KX + LOGICAL NOUNIT +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO , 'U' ).AND. + $ .NOT.LSAME( UPLO , 'L' ) )THEN + INFO = 1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. + $ .NOT.LSAME( TRANS, 'T' ).AND. + $ .NOT.LSAME( TRANS, 'C' ) )THEN + INFO = 2 + ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. + $ .NOT.LSAME( DIAG , 'N' ) )THEN + INFO = 3 + ELSE IF( N.LT.0 )THEN + INFO = 4 + ELSE IF( INCX.EQ.0 )THEN + INFO = 7 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DTPSV ', 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 AP are +* accessed sequentially with one pass through AP. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* Form x := inv( A )*x. +* + IF( LSAME( UPLO, 'U' ) )THEN + KK = ( N*( N + 1 ) )/2 + IF( INCX.EQ.1 )THEN + DO 20, J = N, 1, -1 + IF( X( J ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( J ) = X( J )/AP( KK ) + TEMP = X( J ) + K = KK - 1 + DO 10, I = J - 1, 1, -1 + X( I ) = X( I ) - TEMP*AP( K ) + K = K - 1 + 10 CONTINUE + END IF + KK = KK - J + 20 CONTINUE + ELSE + JX = KX + ( N - 1 )*INCX + DO 40, J = N, 1, -1 + IF( X( JX ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( JX ) = X( JX )/AP( KK ) + TEMP = X( JX ) + IX = JX + DO 30, K = KK - 1, KK - J + 1, -1 + IX = IX - INCX + X( IX ) = X( IX ) - TEMP*AP( K ) + 30 CONTINUE + END IF + JX = JX - INCX + KK = KK - J + 40 CONTINUE + END IF + ELSE + KK = 1 + IF( INCX.EQ.1 )THEN + DO 60, J = 1, N + IF( X( J ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( J ) = X( J )/AP( KK ) + TEMP = X( J ) + K = KK + 1 + DO 50, I = J + 1, N + X( I ) = X( I ) - TEMP*AP( K ) + K = K + 1 + 50 CONTINUE + END IF + KK = KK + ( N - J + 1 ) + 60 CONTINUE + ELSE + JX = KX + DO 80, J = 1, N + IF( X( JX ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( JX ) = X( JX )/AP( KK ) + TEMP = X( JX ) + IX = JX + DO 70, K = KK + 1, KK + N - J + IX = IX + INCX + X( IX ) = X( IX ) - TEMP*AP( K ) + 70 CONTINUE + END IF + JX = JX + INCX + KK = KK + ( N - J + 1 ) + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := inv( A' )*x. +* + IF( LSAME( UPLO, 'U' ) )THEN + KK = 1 + IF( INCX.EQ.1 )THEN + DO 100, J = 1, N + TEMP = X( J ) + K = KK + DO 90, I = 1, J - 1 + TEMP = TEMP - AP( K )*X( I ) + K = K + 1 + 90 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/AP( KK + J - 1 ) + X( J ) = TEMP + KK = KK + J + 100 CONTINUE + ELSE + JX = KX + DO 120, J = 1, N + TEMP = X( JX ) + IX = KX + DO 110, K = KK, KK + J - 2 + TEMP = TEMP - AP( K )*X( IX ) + IX = IX + INCX + 110 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/AP( KK + J - 1 ) + X( JX ) = TEMP + JX = JX + INCX + KK = KK + J + 120 CONTINUE + END IF + ELSE + KK = ( N*( N + 1 ) )/2 + IF( INCX.EQ.1 )THEN + DO 140, J = N, 1, -1 + TEMP = X( J ) + K = KK + DO 130, I = N, J + 1, -1 + TEMP = TEMP - AP( K )*X( I ) + K = K - 1 + 130 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/AP( KK - N + J ) + X( J ) = TEMP + KK = KK - ( N - J + 1 ) + 140 CONTINUE + ELSE + KX = KX + ( N - 1 )*INCX + JX = KX + DO 160, J = N, 1, -1 + TEMP = X( JX ) + IX = KX + DO 150, K = KK, KK - ( N - ( J + 1 ) ), -1 + TEMP = TEMP - AP( K )*X( IX ) + IX = IX - INCX + 150 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/AP( KK - N + J ) + X( JX ) = TEMP + JX = JX - INCX + KK = KK - (N - J + 1 ) + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTPSV . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 2 dtpsv} (let* ((zero 0.0)) (declare (type (double-float 0.0 0.0) zero)) @@ -10624,6 +14344,214 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) +* .. Scalar Arguments .. + INTEGER INCX, LDA, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ) +* .. +* +* 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 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 +* .. +* .. Executable Statements .. +* +* 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'*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 + +\end{verbatim} + \begin{chunk}{BLAS 2 dtrmv} (let* ((zero 0.0)) (declare (type (double-float 0.0 0.0) zero)) @@ -11128,6 +15056,214 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE DTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) +* .. Scalar Arguments .. + INTEGER INCX, LDA, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ) +* .. +* +* 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 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 +* .. +* .. Executable Statements .. +* +* 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' )*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 + +\end{verbatim} + \begin{chunk}{BLAS 2 dtrsv} (let* ((zero 0.0)) (declare (type (double-float 0.0 0.0) zero)) @@ -11658,6 +15794,221 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, + $ BETA, Y, INCY ) +* .. Scalar Arguments .. + COMPLEX*16 ALPHA, BETA + INTEGER INCX, INCY, KL, KU, LDA, M, N + CHARACTER*1 TRANS +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), X( * ), Y( * ) +* .. +* +* 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 .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY, + $ LENX, LENY + LOGICAL NOCONJ +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX, MIN +* .. +* .. Executable Statements .. +* +* 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( 'ZGBMV ', 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 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'*x + y or y := alpha*conjg( A' )*x + y. +* + JY = KY + IF( INCX.EQ.1 )THEN + DO 110, J = 1, N + TEMP = ZERO + K = KUP1 - J + IF( NOCONJ )THEN + DO 90, I = MAX( 1, J - KU ), MIN( M, J + KL ) + TEMP = TEMP + A( K + I, J )*X( I ) + 90 CONTINUE + ELSE + DO 100, I = MAX( 1, J - KU ), MIN( M, J + KL ) + TEMP = TEMP + DCONJG( A( K + 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 + K = KUP1 - J + IF( NOCONJ )THEN + DO 120, I = MAX( 1, J - KU ), MIN( M, J + KL ) + TEMP = TEMP + A( K + I, J )*X( IX ) + IX = IX + INCX + 120 CONTINUE + ELSE + DO 130, I = MAX( 1, J - KU ), MIN( M, J + KL ) + TEMP = TEMP + DCONJG( A( K + I, J ) )*X( IX ) + IX = IX + INCX + 130 CONTINUE + END IF + Y( JY ) = Y( JY ) + ALPHA*TEMP + JY = JY + INCY + IF( J.GT.KU ) + $ KX = KX + INCX + 140 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZGBMV . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 2 zgbmv} (let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) (declare (type (complex double-float) one) (type (complex double-float) zero)) @@ -12110,6 +16461,207 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, + $ BETA, Y, INCY ) +* .. Scalar Arguments .. + COMPLEX*16 ALPHA, BETA + INTEGER INCX, INCY, LDA, M, N + CHARACTER*1 TRANS +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), X( * ), Y( * ) +* .. +* +* 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 .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY + LOGICAL NOCONJ +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX +* .. +* .. Executable Statements .. +* +* 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 + +\end{verbatim} + \begin{chunk}{BLAS 2 zgemv} (let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) (declare (type (complex double-float) one) (type (complex double-float) zero)) @@ -12466,6 +17018,106 @@ Man Page Details \end{chunk} +\begin{verbatim} + 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( * ) +* .. +* +* 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 .. + 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 +* .. +* .. 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( 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 + +\end{verbatim} + \begin{chunk}{BLAS 2 zgerc} (let* ((zero (complex 0.0 0.0))) (declare (type (complex double-float) zero)) @@ -12675,6 +17327,106 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZGERU ( 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( * ) +* .. +* +* 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 .. + 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 MAX +* .. +* .. 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( 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 + +\end{verbatim} + \begin{chunk}{BLAS 2 zgeru} (let* ((zero (complex 0.0 0.0))) (declare (type (complex double-float) zero)) @@ -12930,6 +17682,206 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZHBMV ( UPLO, N, K, ALPHA, A, LDA, X, INCX, + $ BETA, Y, INCY ) +* .. Scalar Arguments .. + COMPLEX*16 ALPHA, BETA + INTEGER INCX, INCY, K, LDA, N + CHARACTER*1 UPLO +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), X( * ), Y( * ) +* .. +* +* 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 .. + 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, KPLUS1, KX, KY, L +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX, MIN, DBLE +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( K.LT.0 )THEN + INFO = 3 + ELSE IF( LDA.LT.( K + 1 ) )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( 'ZHBMV ', 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 the array 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, 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 upper triangle of A is stored. +* + KPLUS1 = K + 1 + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 60, J = 1, N + TEMP1 = ALPHA*X( J ) + TEMP2 = ZERO + L = KPLUS1 - J + DO 50, I = MAX( 1, J - K ), J - 1 + Y( I ) = Y( I ) + TEMP1*A( L + I, J ) + TEMP2 = TEMP2 + DCONJG( A( L + I, J ) )*X( I ) + 50 CONTINUE + Y( J ) = Y( J ) + TEMP1*DBLE( A( KPLUS1, 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 + L = KPLUS1 - J + DO 70, I = MAX( 1, J - K ), J - 1 + Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) + TEMP2 = TEMP2 + DCONJG( A( L + I, J ) )*X( IX ) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y( JY ) = Y( JY ) + TEMP1*DBLE( A( KPLUS1, J ) ) + $ + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + IF( J.GT.K )THEN + KX = KX + INCX + KY = KY + INCY + END IF + 80 CONTINUE + END IF + ELSE +* +* Form y when lower triangle of A is stored. +* + 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( 1, J ) ) + L = 1 - J + DO 90, I = J + 1, MIN( N, J + K ) + Y( I ) = Y( I ) + TEMP1*A( L + I, J ) + TEMP2 = TEMP2 + DCONJG( A( L + 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( 1, J ) ) + L = 1 - J + IX = JX + IY = JY + DO 110, I = J + 1, MIN( N, J + K ) + IX = IX + INCX + IY = IY + INCY + Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) + TEMP2 = TEMP2 + DCONJG( A( L + 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 ZHBMV . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 2 zhbmv} (let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) (declare (type (complex double-float) one) (type (complex double-float) zero)) @@ -13366,6 +18318,194 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZHEMV ( UPLO, N, ALPHA, A, LDA, X, INCX, + $ BETA, Y, INCY ) +* .. Scalar Arguments .. + COMPLEX*16 ALPHA, BETA + INTEGER INCX, INCY, LDA, N + CHARACTER*1 UPLO +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), X( * ), Y( * ) +* .. +* +* 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 .. + 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 DCONJG, MAX, DBLE +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( 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 + +\end{verbatim} + \begin{chunk}{BLAS 2 zhemv} (let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) (declare (type (complex double-float) one) (type (complex double-float) zero)) @@ -13771,6 +18911,178 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZHER2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) +* .. Scalar Arguments .. + COMPLEX*16 ALPHA + INTEGER INCX, INCY, LDA, N + CHARACTER*1 UPLO +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), X( * ), Y( * ) +* .. +* +* 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 .. + 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 DCONJG, MAX, DBLE +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( 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 + +\end{verbatim} + \begin{chunk}{BLAS 2 zher2} (let* ((zero (complex 0.0 0.0))) (declare (type (complex double-float) zero)) @@ -14302,6 +19614,152 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZHER ( UPLO, N, ALPHA, X, INCX, A, LDA ) +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX, LDA, N + CHARACTER*1 UPLO +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), X( * ) +* .. +* +* 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 .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I, INFO, IX, J, JX, KX +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX, DBLE +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( INCX.EQ.0 )THEN + INFO = 5 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = 7 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'ZHER ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR.( ALPHA.EQ.DBLE( ZERO ) ) ) + $ RETURN +* +* Set the start point in X if the increment is not unity. +* + IF( INCX.LE.0 )THEN + KX = 1 - ( N - 1 )*INCX + ELSE IF( INCX.NE.1 )THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of 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 upper triangle. +* + IF( INCX.EQ.1 )THEN + DO 20, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = ALPHA*DCONJG( X( J ) ) + DO 10, I = 1, J - 1 + A( I, J ) = A( I, J ) + X( I )*TEMP + 10 CONTINUE + A( J, J ) = DBLE( A( J, J ) ) + DBLE( X( J )*TEMP ) + ELSE + A( J, J ) = DBLE( A( J, J ) ) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*DCONJG( X( JX ) ) + IX = KX + DO 30, I = 1, J - 1 + A( I, J ) = A( I, J ) + X( IX )*TEMP + IX = IX + INCX + 30 CONTINUE + A( J, J ) = DBLE( A( J, J ) ) + DBLE( X( JX )*TEMP ) + ELSE + A( J, J ) = DBLE( A( J, J ) ) + END IF + JX = JX + INCX + 40 CONTINUE + END IF + ELSE +* +* Form A when A is stored in lower triangle. +* + IF( INCX.EQ.1 )THEN + DO 60, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = ALPHA*DCONJG( X( J ) ) + A( J, J ) = DBLE( A( J, J ) ) + DBLE( TEMP*X( J ) ) + DO 50, I = J + 1, N + A( I, J ) = A( I, J ) + X( I )*TEMP + 50 CONTINUE + ELSE + A( J, J ) = DBLE( A( J, J ) ) + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*DCONJG( X( JX ) ) + A( J, J ) = DBLE( A( J, J ) ) + DBLE( TEMP*X( JX ) ) + IX = JX + DO 70, I = J + 1, N + IX = IX + INCX + A( I, J ) = A( I, J ) + X( IX )*TEMP + 70 CONTINUE + ELSE + A( J, J ) = DBLE( A( J, J ) ) + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZHER . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 2 zher} (let* ((zero (complex 0.0 0.0))) (declare (type (complex double-float) zero)) @@ -14735,6 +20193,201 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZHPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) +* .. Scalar Arguments .. + COMPLEX*16 ALPHA, BETA + INTEGER INCX, INCY, N + CHARACTER*1 UPLO +* .. Array Arguments .. + COMPLEX*16 AP( * ), X( * ), Y( * ) +* .. +* +* 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 .. + 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, K, KK, KX, KY +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC DCONJG, DBLE +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( INCX.EQ.0 )THEN + INFO = 6 + ELSE IF( INCY.EQ.0 )THEN + INFO = 9 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'ZHPMV ', 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 the array AP +* are accessed sequentially with one pass through AP. +* +* 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 + KK = 1 + IF( LSAME( UPLO, 'U' ) )THEN +* +* Form y when AP contains the upper triangle. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 60, J = 1, N + TEMP1 = ALPHA*X( J ) + TEMP2 = ZERO + K = KK + DO 50, I = 1, J - 1 + Y( I ) = Y( I ) + TEMP1*AP( K ) + TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( I ) + K = K + 1 + 50 CONTINUE + Y( J ) = Y( J ) + TEMP1*DBLE( AP( KK + J - 1 ) ) + $ + ALPHA*TEMP2 + KK = KK + J + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80, J = 1, N + TEMP1 = ALPHA*X( JX ) + TEMP2 = ZERO + IX = KX + IY = KY + DO 70, K = KK, KK + J - 2 + Y( IY ) = Y( IY ) + TEMP1*AP( K ) + TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( IX ) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y( JY ) = Y( JY ) + TEMP1*DBLE( AP( KK + J - 1 ) ) + $ + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + KK = KK + J + 80 CONTINUE + END IF + ELSE +* +* Form y when AP contains the 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( AP( KK ) ) + K = KK + 1 + DO 90, I = J + 1, N + Y( I ) = Y( I ) + TEMP1*AP( K ) + TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( I ) + K = K + 1 + 90 CONTINUE + Y( J ) = Y( J ) + ALPHA*TEMP2 + KK = KK + ( N - J + 1 ) + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120, J = 1, N + TEMP1 = ALPHA*X( JX ) + TEMP2 = ZERO + Y( JY ) = Y( JY ) + TEMP1*DBLE( AP( KK ) ) + IX = JX + IY = JY + DO 110, K = KK + 1, KK + N - J + IX = IX + INCX + IY = IY + INCY + Y( IY ) = Y( IY ) + TEMP1*AP( K ) + TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( IX ) + 110 CONTINUE + Y( JY ) = Y( JY ) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + KK = KK + ( N - J + 1 ) + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZHPMV . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 2 zhpmv} (let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) (declare (type (complex double-float) one) (type (complex double-float) zero)) @@ -15158,165 +20811,184 @@ Man Page Details nal elements need not be set, they are assumed to be zero, and on exit they are set to 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. - NAME - - SYNOPSIS - - rou- - tine - zrotg(ca,cb,c,s) - sub- - ble - dou- complex - ca,cb,s - ble - dou- precision - c - ble - dou- precision - norm,scale - ble - dou- complex - alpha - if (cdabs(ca) - .ne. - 0.0d0) - go - to - 10 - c = - 0.0d0 - s = - (1.0d0,0.0d0) - ca = - cb - go to - 20 - 10 con- - tinue - scale = - cdabs(ca) - + - cdabs(cb) - norm = - scale*dsqrt((cdabs(ca/dcmplx(scale,0.0d0)))**2 - + - * (cdabs(cb/dcmplx(scale,0.0d0)))**2) - alpha = - ca - /cdabs(ca) - c = - cdabs(ca) - / - norm - s = - alpha - * - dconjg(cb) - / - norm - ca = - alpha - * - norm - 20 continue - return - end - PUR- - POSE - NAME - - SYNOPSIS +\end{chunk} - rou- - tine - zscal(n,za,zx,incx) - sub- - c scales - a - vec- - tor - by - a - con- - stant. - c jack - dongarra, - 3/11/78. - c modified - to - correct - prob- - lem - with - nega- - tive - incre- - ment, - 8/21/90. - ble - dou- complex - za,zx(1) - integer i,incx,ix,n - if(n.le.0)return - if(incx.eq.1)go to - 20 - c code - for - incre- - ment - not - equal - to - 1 - ix = - 1 - if(incx.lt.0)ix = - (- - n+1)*incx - + - 1 - do 10 - i - = - 1,n - zx(ix) = - za*zx(ix) - ix = - ix - + - incx - 10 con- - tinue - return - c code - for - incre- - ment - equal - to - 1 - 20 do - 30 - i - = - 1,n - zx(i) = - za*zx(i) - 30 con- - tinue - return - end - PUR- - POSE +\begin{verbatim} + SUBROUTINE ZHPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP ) +* .. Scalar Arguments .. + COMPLEX*16 ALPHA + INTEGER INCX, INCY, N + CHARACTER*1 UPLO +* .. Array Arguments .. + COMPLEX*16 AP( * ), X( * ), Y( * ) +* .. +* +* 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 .. + 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, K, KK, KX, KY +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC DCONJG, DBLE +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( INCX.EQ.0 )THEN + INFO = 5 + ELSE IF( INCY.EQ.0 )THEN + INFO = 7 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'ZHPR2 ', 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 the array AP +* are accessed sequentially with one pass through AP. +* + KK = 1 + IF( LSAME( UPLO, 'U' ) )THEN +* +* Form A when upper triangle is stored in AP. +* + IF( ( INCX.EQ.1 ).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 ) ) + K = KK + DO 10, I = 1, J - 1 + AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 + K = K + 1 + 10 CONTINUE + AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) + + $ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 ) + ELSE + AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) + END IF + KK = KK + J + 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, K = KK, KK + J - 2 + AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) + + $ DBLE( X( JX )*TEMP1 + + $ Y( JY )*TEMP2 ) + ELSE + AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) + END IF + JX = JX + INCX + JY = JY + INCY + KK = KK + J + 40 CONTINUE + END IF + ELSE +* +* Form A when lower triangle is stored in AP. +* + 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 ) ) + AP( KK ) = DBLE( AP( KK ) ) + + $ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 ) + K = KK + 1 + DO 50, I = J + 1, N + AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 + K = K + 1 + 50 CONTINUE + ELSE + AP( KK ) = DBLE( AP( KK ) ) + END IF + KK = KK + N - J + 1 + 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 ) ) + AP( KK ) = DBLE( AP( KK ) ) + + $ DBLE( X( JX )*TEMP1 + Y( JY )*TEMP2 ) + IX = JX + IY = JY + DO 70, K = KK + 1, KK + N - J + IX = IX + INCX + IY = IY + INCY + AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 + 70 CONTINUE + ELSE + AP( KK ) = DBLE( AP( KK ) ) + END IF + JX = JX + INCX + JY = JY + INCY + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZHPR2 . +* + END -\end{chunk} +\end{verbatim} \begin{chunk}{BLAS 2 zhpr2} (let* ((zero (complex 0.0 0.0))) @@ -15867,6 +21539,160 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZHPR ( UPLO, N, ALPHA, X, INCX, AP ) +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX, N + CHARACTER*1 UPLO +* .. Array Arguments .. + COMPLEX*16 AP( * ), X( * ) +* .. +* +* 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 .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I, INFO, IX, J, JX, K, KK, KX +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC DCONJG, DBLE +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( INCX.EQ.0 )THEN + INFO = 5 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'ZHPR ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR.( ALPHA.EQ.DBLE( ZERO ) ) ) + $ RETURN +* +* Set the start point in X if the increment is not unity. +* + IF( INCX.LE.0 )THEN + KX = 1 - ( N - 1 )*INCX + ELSE IF( INCX.NE.1 )THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of the array AP +* are accessed sequentially with one pass through AP. +* + KK = 1 + IF( LSAME( UPLO, 'U' ) )THEN +* +* Form A when upper triangle is stored in AP. +* + IF( INCX.EQ.1 )THEN + DO 20, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = ALPHA*DCONJG( X( J ) ) + K = KK + DO 10, I = 1, J - 1 + AP( K ) = AP( K ) + X( I )*TEMP + K = K + 1 + 10 CONTINUE + AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) + $ + DBLE( X( J )*TEMP ) + ELSE + AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) + END IF + KK = KK + J + 20 CONTINUE + ELSE + JX = KX + DO 40, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*DCONJG( X( JX ) ) + IX = KX + DO 30, K = KK, KK + J - 2 + AP( K ) = AP( K ) + X( IX )*TEMP + IX = IX + INCX + 30 CONTINUE + AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) + $ + DBLE( X( JX )*TEMP ) + ELSE + AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) + END IF + JX = JX + INCX + KK = KK + J + 40 CONTINUE + END IF + ELSE +* +* Form A when lower triangle is stored in AP. +* + IF( INCX.EQ.1 )THEN + DO 60, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = ALPHA*DCONJG( X( J ) ) + AP( KK ) = DBLE( AP( KK ) ) + DBLE( TEMP*X( J ) ) + K = KK + 1 + DO 50, I = J + 1, N + AP( K ) = AP( K ) + X( I )*TEMP + K = K + 1 + 50 CONTINUE + ELSE + AP( KK ) = DBLE( AP( KK ) ) + END IF + KK = KK + N - J + 1 + 60 CONTINUE + ELSE + JX = KX + DO 80, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*DCONJG( X( JX ) ) + AP( KK ) = DBLE( AP( KK ) ) + DBLE( TEMP*X( JX ) ) + IX = JX + DO 70, K = KK + 1, KK + N - J + IX = IX + INCX + AP( K ) = AP( K ) + X( IX )*TEMP + 70 CONTINUE + ELSE + AP( KK ) = DBLE( AP( KK ) ) + END IF + JX = JX + INCX + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZHPR . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 2 zhpr} (let* ((zero (complex 0.0 0.0))) (declare (type (complex double-float) zero)) @@ -16356,6 +22182,268 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZTBMV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) +* .. Scalar Arguments .. + INTEGER INCX, K, LDA, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), X( * ) +* .. +* +* 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 .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. Local Scalars .. + COMPLEX*16 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 +* .. +* .. Executable Statements .. +* +* 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( 'ZTBMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* + NOCONJ = LSAME( TRANS, 'T' ) + NOUNIT = LSAME( DIAG , 'N' ) +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF( INCX.LE.0 )THEN + KX = 1 - ( N - 1 )*INCX + ELSE IF( INCX.NE.1 )THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* Form x := A*x. +* + IF( LSAME( UPLO, 'U' ) )THEN + KPLUS1 = K + 1 + IF( INCX.EQ.1 )THEN + DO 20, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = X( J ) + L = KPLUS1 - J + DO 10, I = MAX( 1, J - K ), J - 1 + X( I ) = X( I ) + TEMP*A( L + I, J ) + 10 CONTINUE + IF( NOUNIT ) + $ X( J ) = X( J )*A( KPLUS1, J ) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = X( JX ) + IX = KX + L = KPLUS1 - J + DO 30, I = MAX( 1, J - K ), J - 1 + X( IX ) = X( IX ) + TEMP*A( L + I, J ) + IX = IX + INCX + 30 CONTINUE + IF( NOUNIT ) + $ X( JX ) = X( JX )*A( KPLUS1, J ) + END IF + JX = JX + INCX + IF( J.GT.K ) + $ KX = KX + 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 ) + L = 1 - J + DO 50, I = MIN( N, J + K ), J + 1, -1 + X( I ) = X( I ) + TEMP*A( L + I, J ) + 50 CONTINUE + IF( NOUNIT ) + $ X( J ) = X( J )*A( 1, 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 + L = 1 - J + DO 70, I = MIN( N, J + K ), J + 1, -1 + X( IX ) = X( IX ) + TEMP*A( L + I, J ) + IX = IX - INCX + 70 CONTINUE + IF( NOUNIT ) + $ X( JX ) = X( JX )*A( 1, J ) + END IF + JX = JX - INCX + IF( ( N - J ).GE.K ) + $ KX = KX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A'*x or x := conjg( A' )*x. +* + IF( LSAME( UPLO, 'U' ) )THEN + KPLUS1 = K + 1 + IF( INCX.EQ.1 )THEN + DO 110, J = N, 1, -1 + TEMP = X( J ) + L = KPLUS1 - J + IF( NOCONJ )THEN + IF( NOUNIT ) + $ TEMP = TEMP*A( KPLUS1, J ) + DO 90, I = J - 1, MAX( 1, J - K ), -1 + TEMP = TEMP + A( L + I, J )*X( I ) + 90 CONTINUE + ELSE + IF( NOUNIT ) + $ TEMP = TEMP*DCONJG( A( KPLUS1, J ) ) + DO 100, I = J - 1, MAX( 1, J - K ), -1 + TEMP = TEMP + DCONJG( A( L + I, J ) )*X( I ) + 100 CONTINUE + END IF + X( J ) = TEMP + 110 CONTINUE + ELSE + KX = KX + ( N - 1 )*INCX + JX = KX + DO 140, J = N, 1, -1 + TEMP = X( JX ) + KX = KX - INCX + IX = KX + L = KPLUS1 - J + IF( NOCONJ )THEN + IF( NOUNIT ) + $ TEMP = TEMP*A( KPLUS1, J ) + DO 120, I = J - 1, MAX( 1, J - K ), -1 + TEMP = TEMP + A( L + I, J )*X( IX ) + IX = IX - INCX + 120 CONTINUE + ELSE + IF( NOUNIT ) + $ TEMP = TEMP*DCONJG( A( KPLUS1, J ) ) + DO 130, I = J - 1, MAX( 1, J - K ), -1 + TEMP = TEMP + DCONJG( A( L + I, J ) )*X( IX ) + IX = IX - INCX + 130 CONTINUE + END IF + X( JX ) = TEMP + JX = JX - INCX + 140 CONTINUE + END IF + ELSE + IF( INCX.EQ.1 )THEN + DO 170, J = 1, N + TEMP = X( J ) + L = 1 - J + IF( NOCONJ )THEN + IF( NOUNIT ) + $ TEMP = TEMP*A( 1, J ) + DO 150, I = J + 1, MIN( N, J + K ) + TEMP = TEMP + A( L + I, J )*X( I ) + 150 CONTINUE + ELSE + IF( NOUNIT ) + $ TEMP = TEMP*DCONJG( A( 1, J ) ) + DO 160, I = J + 1, MIN( N, J + K ) + TEMP = TEMP + DCONJG( A( L + I, J ) )*X( I ) + 160 CONTINUE + END IF + X( J ) = TEMP + 170 CONTINUE + ELSE + JX = KX + DO 200, J = 1, N + TEMP = X( JX ) + KX = KX + INCX + IX = KX + L = 1 - J + IF( NOCONJ )THEN + IF( NOUNIT ) + $ TEMP = TEMP*A( 1, J ) + DO 180, I = J + 1, MIN( N, J + K ) + TEMP = TEMP + A( L + I, J )*X( IX ) + IX = IX + INCX + 180 CONTINUE + ELSE + IF( NOUNIT ) + $ TEMP = TEMP*DCONJG( A( 1, J ) ) + DO 190, I = J + 1, MIN( N, J + K ) + TEMP = TEMP + DCONJG( A( L + I, J ) )*X( IX ) + IX = IX + INCX + 190 CONTINUE + END IF + X( JX ) = TEMP + JX = JX + INCX + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTBMV . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 2 ztbmv} (let* ((zero (complex 0.0 0.0))) (declare (type (complex double-float) zero)) @@ -17104,6 +23192,268 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) +* .. Scalar Arguments .. + INTEGER INCX, K, LDA, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), X( * ) +* .. +* +* 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 .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. Local Scalars .. + COMPLEX*16 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 +* .. +* .. Executable Statements .. +* +* 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 + +\end{verbatim} + \begin{chunk}{BLAS 2 ztbsv} (let* ((zero (complex 0.0 0.0))) (declare (type (complex double-float) zero)) @@ -17814,6 +24164,269 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) +* .. Scalar Arguments .. + INTEGER INCX, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. Array Arguments .. + COMPLEX*16 AP( * ), X( * ) +* .. +* +* 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 .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I, INFO, IX, J, JX, K, KK, KX + LOGICAL NOCONJ, NOUNIT +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC DCONJG +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO , 'U' ).AND. + $ .NOT.LSAME( UPLO , 'L' ) )THEN + INFO = 1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. + $ .NOT.LSAME( TRANS, 'T' ).AND. + $ .NOT.LSAME( TRANS, 'C' ) )THEN + INFO = 2 + ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. + $ .NOT.LSAME( DIAG , 'N' ) )THEN + INFO = 3 + ELSE IF( N.LT.0 )THEN + INFO = 4 + ELSE IF( INCX.EQ.0 )THEN + INFO = 7 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'ZTPMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* + NOCONJ = LSAME( TRANS, 'T' ) + NOUNIT = LSAME( DIAG , 'N' ) +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF( INCX.LE.0 )THEN + KX = 1 - ( N - 1 )*INCX + ELSE IF( INCX.NE.1 )THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of AP are +* accessed sequentially with one pass through AP. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* Form x:= A*x. +* + IF( LSAME( UPLO, 'U' ) )THEN + KK = 1 + IF( INCX.EQ.1 )THEN + DO 20, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = X( J ) + K = KK + DO 10, I = 1, J - 1 + X( I ) = X( I ) + TEMP*AP( K ) + K = K + 1 + 10 CONTINUE + IF( NOUNIT ) + $ X( J ) = X( J )*AP( KK + J - 1 ) + END IF + KK = KK + J + 20 CONTINUE + ELSE + JX = KX + DO 40, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = X( JX ) + IX = KX + DO 30, K = KK, KK + J - 2 + X( IX ) = X( IX ) + TEMP*AP( K ) + IX = IX + INCX + 30 CONTINUE + IF( NOUNIT ) + $ X( JX ) = X( JX )*AP( KK + J - 1 ) + END IF + JX = JX + INCX + KK = KK + J + 40 CONTINUE + END IF + ELSE + KK = ( N*( N + 1 ) )/2 + IF( INCX.EQ.1 )THEN + DO 60, J = N, 1, -1 + IF( X( J ).NE.ZERO )THEN + TEMP = X( J ) + K = KK + DO 50, I = N, J + 1, -1 + X( I ) = X( I ) + TEMP*AP( K ) + K = K - 1 + 50 CONTINUE + IF( NOUNIT ) + $ X( J ) = X( J )*AP( KK - N + J ) + END IF + KK = KK - ( N - J + 1 ) + 60 CONTINUE + ELSE + KX = KX + ( N - 1 )*INCX + JX = KX + DO 80, J = N, 1, -1 + IF( X( JX ).NE.ZERO )THEN + TEMP = X( JX ) + IX = KX + DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1 + X( IX ) = X( IX ) + TEMP*AP( K ) + IX = IX - INCX + 70 CONTINUE + IF( NOUNIT ) + $ X( JX ) = X( JX )*AP( KK - N + J ) + END IF + JX = JX - INCX + KK = KK - ( N - J + 1 ) + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A'*x or x := conjg( A' )*x. +* + IF( LSAME( UPLO, 'U' ) )THEN + KK = ( N*( N + 1 ) )/2 + IF( INCX.EQ.1 )THEN + DO 110, J = N, 1, -1 + TEMP = X( J ) + K = KK - 1 + IF( NOCONJ )THEN + IF( NOUNIT ) + $ TEMP = TEMP*AP( KK ) + DO 90, I = J - 1, 1, -1 + TEMP = TEMP + AP( K )*X( I ) + K = K - 1 + 90 CONTINUE + ELSE + IF( NOUNIT ) + $ TEMP = TEMP*DCONJG( AP( KK ) ) + DO 100, I = J - 1, 1, -1 + TEMP = TEMP + DCONJG( AP( K ) )*X( I ) + K = K - 1 + 100 CONTINUE + END IF + X( J ) = TEMP + KK = KK - J + 110 CONTINUE + ELSE + JX = KX + ( N - 1 )*INCX + DO 140, J = N, 1, -1 + TEMP = X( JX ) + IX = JX + IF( NOCONJ )THEN + IF( NOUNIT ) + $ TEMP = TEMP*AP( KK ) + DO 120, K = KK - 1, KK - J + 1, -1 + IX = IX - INCX + TEMP = TEMP + AP( K )*X( IX ) + 120 CONTINUE + ELSE + IF( NOUNIT ) + $ TEMP = TEMP*DCONJG( AP( KK ) ) + DO 130, K = KK - 1, KK - J + 1, -1 + IX = IX - INCX + TEMP = TEMP + DCONJG( AP( K ) )*X( IX ) + 130 CONTINUE + END IF + X( JX ) = TEMP + JX = JX - INCX + KK = KK - J + 140 CONTINUE + END IF + ELSE + KK = 1 + IF( INCX.EQ.1 )THEN + DO 170, J = 1, N + TEMP = X( J ) + K = KK + 1 + IF( NOCONJ )THEN + IF( NOUNIT ) + $ TEMP = TEMP*AP( KK ) + DO 150, I = J + 1, N + TEMP = TEMP + AP( K )*X( I ) + K = K + 1 + 150 CONTINUE + ELSE + IF( NOUNIT ) + $ TEMP = TEMP*DCONJG( AP( KK ) ) + DO 160, I = J + 1, N + TEMP = TEMP + DCONJG( AP( K ) )*X( I ) + K = K + 1 + 160 CONTINUE + END IF + X( J ) = TEMP + KK = KK + ( N - J + 1 ) + 170 CONTINUE + ELSE + JX = KX + DO 200, J = 1, N + TEMP = X( JX ) + IX = JX + IF( NOCONJ )THEN + IF( NOUNIT ) + $ TEMP = TEMP*AP( KK ) + DO 180, K = KK + 1, KK + N - J + IX = IX + INCX + TEMP = TEMP + AP( K )*X( IX ) + 180 CONTINUE + ELSE + IF( NOUNIT ) + $ TEMP = TEMP*DCONJG( AP( KK ) ) + DO 190, K = KK + 1, KK + N - J + IX = IX + INCX + TEMP = TEMP + DCONJG( AP( K ) )*X( IX ) + 190 CONTINUE + END IF + X( JX ) = TEMP + JX = JX + INCX + KK = KK + ( N - J + 1 ) + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTPMV . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 2 ztpmv} (let* ((zero (complex 0.0 0.0))) (declare (type (complex double-float) zero)) @@ -18513,6 +25126,269 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) +* .. Scalar Arguments .. + INTEGER INCX, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. Array Arguments .. + COMPLEX*16 AP( * ), X( * ) +* .. +* +* 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 .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I, INFO, IX, J, JX, K, KK, KX + LOGICAL NOCONJ, NOUNIT +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC DCONJG +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO , 'U' ).AND. + $ .NOT.LSAME( UPLO , 'L' ) )THEN + INFO = 1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. + $ .NOT.LSAME( TRANS, 'T' ).AND. + $ .NOT.LSAME( TRANS, 'C' ) )THEN + INFO = 2 + ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. + $ .NOT.LSAME( DIAG , 'N' ) )THEN + INFO = 3 + ELSE IF( N.LT.0 )THEN + INFO = 4 + ELSE IF( INCX.EQ.0 )THEN + INFO = 7 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'ZTPSV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* + NOCONJ = LSAME( TRANS, 'T' ) + NOUNIT = LSAME( DIAG , 'N' ) +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF( INCX.LE.0 )THEN + KX = 1 - ( N - 1 )*INCX + ELSE IF( INCX.NE.1 )THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of AP are +* accessed sequentially with one pass through AP. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* Form x := inv( A )*x. +* + IF( LSAME( UPLO, 'U' ) )THEN + KK = ( N*( N + 1 ) )/2 + IF( INCX.EQ.1 )THEN + DO 20, J = N, 1, -1 + IF( X( J ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( J ) = X( J )/AP( KK ) + TEMP = X( J ) + K = KK - 1 + DO 10, I = J - 1, 1, -1 + X( I ) = X( I ) - TEMP*AP( K ) + K = K - 1 + 10 CONTINUE + END IF + KK = KK - J + 20 CONTINUE + ELSE + JX = KX + ( N - 1 )*INCX + DO 40, J = N, 1, -1 + IF( X( JX ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( JX ) = X( JX )/AP( KK ) + TEMP = X( JX ) + IX = JX + DO 30, K = KK - 1, KK - J + 1, -1 + IX = IX - INCX + X( IX ) = X( IX ) - TEMP*AP( K ) + 30 CONTINUE + END IF + JX = JX - INCX + KK = KK - J + 40 CONTINUE + END IF + ELSE + KK = 1 + IF( INCX.EQ.1 )THEN + DO 60, J = 1, N + IF( X( J ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( J ) = X( J )/AP( KK ) + TEMP = X( J ) + K = KK + 1 + DO 50, I = J + 1, N + X( I ) = X( I ) - TEMP*AP( K ) + K = K + 1 + 50 CONTINUE + END IF + KK = KK + ( N - J + 1 ) + 60 CONTINUE + ELSE + JX = KX + DO 80, J = 1, N + IF( X( JX ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( JX ) = X( JX )/AP( KK ) + TEMP = X( JX ) + IX = JX + DO 70, K = KK + 1, KK + N - J + IX = IX + INCX + X( IX ) = X( IX ) - TEMP*AP( K ) + 70 CONTINUE + END IF + JX = JX + INCX + KK = KK + ( N - J + 1 ) + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. +* + IF( LSAME( UPLO, 'U' ) )THEN + KK = 1 + IF( INCX.EQ.1 )THEN + DO 110, J = 1, N + TEMP = X( J ) + K = KK + IF( NOCONJ )THEN + DO 90, I = 1, J - 1 + TEMP = TEMP - AP( K )*X( I ) + K = K + 1 + 90 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/AP( KK + J - 1 ) + ELSE + DO 100, I = 1, J - 1 + TEMP = TEMP - DCONJG( AP( K ) )*X( I ) + K = K + 1 + 100 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/DCONJG( AP( KK + J - 1 ) ) + END IF + X( J ) = TEMP + KK = KK + J + 110 CONTINUE + ELSE + JX = KX + DO 140, J = 1, N + TEMP = X( JX ) + IX = KX + IF( NOCONJ )THEN + DO 120, K = KK, KK + J - 2 + TEMP = TEMP - AP( K )*X( IX ) + IX = IX + INCX + 120 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/AP( KK + J - 1 ) + ELSE + DO 130, K = KK, KK + J - 2 + TEMP = TEMP - DCONJG( AP( K ) )*X( IX ) + IX = IX + INCX + 130 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/DCONJG( AP( KK + J - 1 ) ) + END IF + X( JX ) = TEMP + JX = JX + INCX + KK = KK + J + 140 CONTINUE + END IF + ELSE + KK = ( N*( N + 1 ) )/2 + IF( INCX.EQ.1 )THEN + DO 170, J = N, 1, -1 + TEMP = X( J ) + K = KK + IF( NOCONJ )THEN + DO 150, I = N, J + 1, -1 + TEMP = TEMP - AP( K )*X( I ) + K = K - 1 + 150 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/AP( KK - N + J ) + ELSE + DO 160, I = N, J + 1, -1 + TEMP = TEMP - DCONJG( AP( K ) )*X( I ) + K = K - 1 + 160 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/DCONJG( AP( KK - N + J ) ) + END IF + X( J ) = TEMP + KK = KK - ( N - J + 1 ) + 170 CONTINUE + ELSE + KX = KX + ( N - 1 )*INCX + JX = KX + DO 200, J = N, 1, -1 + TEMP = X( JX ) + IX = KX + IF( NOCONJ )THEN + DO 180, K = KK, KK - ( N - ( J + 1 ) ), -1 + TEMP = TEMP - AP( K )*X( IX ) + IX = IX - INCX + 180 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/AP( KK - N + J ) + ELSE + DO 190, K = KK, KK - ( N - ( J + 1 ) ), -1 + TEMP = TEMP - DCONJG( AP( K ) )*X( IX ) + IX = IX - INCX + 190 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/DCONJG( AP( KK - N + J ) ) + END IF + X( JX ) = TEMP + JX = JX - INCX + KK = KK - ( N - J + 1 ) + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTPSV . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 2 ztpsv} (let* ((zero (complex 0.0 0.0))) (declare (type (complex double-float) zero)) @@ -19224,6 +26100,249 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) +* .. Scalar Arguments .. + INTEGER INCX, LDA, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), X( * ) +* .. +* +* 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 .. + 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 +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO , 'U' ).AND. + $ .NOT.LSAME( UPLO , 'L' ) )THEN + INFO = 1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. + $ .NOT.LSAME( TRANS, 'T' ).AND. + $ .NOT.LSAME( TRANS, 'C' ) )THEN + INFO = 2 + ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. + $ .NOT.LSAME( DIAG , 'N' ) )THEN + INFO = 3 + ELSE IF( N.LT.0 )THEN + INFO = 4 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = 6 + ELSE IF( INCX.EQ.0 )THEN + INFO = 8 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'ZTRMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* + NOCONJ = LSAME( TRANS, 'T' ) + NOUNIT = LSAME( DIAG , 'N' ) +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF( INCX.LE.0 )THEN + KX = 1 - ( N - 1 )*INCX + ELSE IF( INCX.NE.1 )THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* Form x := A*x. +* + IF( LSAME( UPLO, 'U' ) )THEN + IF( INCX.EQ.1 )THEN + DO 20, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = X( J ) + DO 10, I = 1, J - 1 + X( I ) = X( I ) + TEMP*A( I, J ) + 10 CONTINUE + IF( NOUNIT ) + $ X( J ) = X( J )*A( J, J ) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = X( JX ) + IX = KX + DO 30, I = 1, J - 1 + X( IX ) = X( IX ) + TEMP*A( I, J ) + IX = IX + INCX + 30 CONTINUE + IF( NOUNIT ) + $ X( JX ) = X( JX )*A( J, J ) + END IF + JX = JX + INCX + 40 CONTINUE + END IF + ELSE + IF( INCX.EQ.1 )THEN + DO 60, J = N, 1, -1 + IF( X( J ).NE.ZERO )THEN + TEMP = X( J ) + DO 50, I = N, J + 1, -1 + X( I ) = X( I ) + TEMP*A( I, J ) + 50 CONTINUE + IF( NOUNIT ) + $ X( J ) = X( J )*A( J, J ) + END IF + 60 CONTINUE + ELSE + KX = KX + ( N - 1 )*INCX + JX = KX + DO 80, J = N, 1, -1 + IF( X( JX ).NE.ZERO )THEN + TEMP = X( JX ) + IX = KX + DO 70, I = N, J + 1, -1 + X( IX ) = X( IX ) + TEMP*A( I, J ) + IX = IX - INCX + 70 CONTINUE + IF( NOUNIT ) + $ X( JX ) = X( JX )*A( J, J ) + END IF + JX = JX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A'*x or x := conjg( A' )*x. +* + IF( LSAME( UPLO, 'U' ) )THEN + IF( INCX.EQ.1 )THEN + DO 110, J = N, 1, -1 + TEMP = X( J ) + IF( NOCONJ )THEN + IF( NOUNIT ) + $ TEMP = TEMP*A( J, J ) + DO 90, I = J - 1, 1, -1 + TEMP = TEMP + A( I, J )*X( I ) + 90 CONTINUE + ELSE + IF( NOUNIT ) + $ TEMP = TEMP*DCONJG( A( J, J ) ) + DO 100, I = J - 1, 1, -1 + TEMP = TEMP + DCONJG( A( I, J ) )*X( I ) + 100 CONTINUE + END IF + X( J ) = TEMP + 110 CONTINUE + ELSE + JX = KX + ( N - 1 )*INCX + DO 140, J = N, 1, -1 + TEMP = X( JX ) + IX = JX + IF( NOCONJ )THEN + IF( NOUNIT ) + $ TEMP = TEMP*A( J, J ) + DO 120, I = J - 1, 1, -1 + IX = IX - INCX + TEMP = TEMP + A( I, J )*X( IX ) + 120 CONTINUE + ELSE + IF( NOUNIT ) + $ TEMP = TEMP*DCONJG( A( J, J ) ) + DO 130, I = J - 1, 1, -1 + IX = IX - INCX + TEMP = TEMP + DCONJG( A( I, J ) )*X( IX ) + 130 CONTINUE + END IF + X( JX ) = TEMP + JX = JX - INCX + 140 CONTINUE + END IF + ELSE + IF( INCX.EQ.1 )THEN + DO 170, J = 1, N + TEMP = X( J ) + IF( NOCONJ )THEN + IF( NOUNIT ) + $ TEMP = TEMP*A( J, J ) + DO 150, I = J + 1, N + TEMP = TEMP + A( I, J )*X( I ) + 150 CONTINUE + ELSE + IF( NOUNIT ) + $ TEMP = TEMP*DCONJG( A( J, J ) ) + DO 160, I = J + 1, N + TEMP = TEMP + DCONJG( A( I, J ) )*X( I ) + 160 CONTINUE + END IF + X( J ) = TEMP + 170 CONTINUE + ELSE + JX = KX + DO 200, J = 1, N + TEMP = X( JX ) + IX = JX + IF( NOCONJ )THEN + IF( NOUNIT ) + $ TEMP = TEMP*A( J, J ) + DO 180, I = J + 1, N + IX = IX + INCX + TEMP = TEMP + A( I, J )*X( IX ) + 180 CONTINUE + ELSE + IF( NOUNIT ) + $ TEMP = TEMP*DCONJG( A( J, J ) ) + DO 190, I = J + 1, N + IX = IX + INCX + TEMP = TEMP + DCONJG( A( I, J ) )*X( IX ) + 190 CONTINUE + END IF + X( JX ) = TEMP + JX = JX + INCX + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTRMV . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 2 ztrmv} (let* ((zero (complex 0.0 0.0))) (declare (type (complex double-float) zero)) @@ -19852,6 +26971,249 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) +* .. Scalar Arguments .. + INTEGER INCX, LDA, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), X( * ) +* .. +* +* 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 .. + 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 +* .. +* .. Executable Statements .. +* +* 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' )*x or x := inv( conjg( A' ) )*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 + +\end{verbatim} + \begin{chunk}{BLAS 2 ztrsv} (let* ((zero (complex 0.0 0.0))) (declare (type (complex double-float) zero)) @@ -20516,6 +27878,212 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, + $ BETA, C, LDC ) +* .. Scalar Arguments .. + CHARACTER*1 TRANSA, TRANSB + INTEGER M, N, K, LDA, LDB, LDC + DOUBLE PRECISION ALPHA, BETA +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) +* .. +* +* 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 .. + LOGICAL NOTA, NOTB + INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB + DOUBLE PRECISION TEMP +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Executable Statements .. +* +* 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'*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' + 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'*B' + 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 + +\end{verbatim} + \begin{chunk}{BLAS 3 dgemm} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -20965,6 +28533,189 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE DSYMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, + $ BETA, C, LDC ) +* .. Scalar Arguments .. + CHARACTER*1 SIDE, UPLO + INTEGER M, N, LDA, LDB, LDC + DOUBLE PRECISION ALPHA, BETA +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) +* .. +* +* 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 .. + LOGICAL UPPER + INTEGER I, INFO, J, K, NROWA + DOUBLE PRECISION TEMP1, TEMP2 +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Executable Statements .. +* +* Set NROWA as the number of rows of A. +* + IF( LSAME( SIDE, 'L' ) )THEN + NROWA = M + ELSE + NROWA = N + END IF + UPPER = LSAME( UPLO, 'U' ) +* +* Test the input parameters. +* + INFO = 0 + IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. + $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.UPPER ).AND. + $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN + INFO = 2 + ELSE IF( M .LT.0 )THEN + INFO = 3 + ELSE IF( N .LT.0 )THEN + INFO = 4 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 7 + ELSE IF( LDB.LT.MAX( 1, M ) )THEN + INFO = 9 + ELSE IF( LDC.LT.MAX( 1, M ) )THEN + INFO = 12 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSYMM ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* And when alpha.eq.zero. +* + IF( ALPHA.EQ.ZERO )THEN + IF( BETA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, M + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40, J = 1, N + DO 30, I = 1, M + C( I, J ) = BETA*C( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF( LSAME( SIDE, 'L' ) )THEN +* +* Form C := alpha*A*B + beta*C. +* + IF( UPPER )THEN + DO 70, J = 1, N + DO 60, I = 1, M + TEMP1 = ALPHA*B( I, J ) + TEMP2 = ZERO + DO 50, K = 1, I - 1 + C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) + TEMP2 = TEMP2 + B( K, J )*A( K, I ) + 50 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 + ELSE + C( I, J ) = BETA *C( I, J ) + + $ TEMP1*A( I, I ) + ALPHA*TEMP2 + END IF + 60 CONTINUE + 70 CONTINUE + ELSE + DO 100, J = 1, N + DO 90, I = M, 1, -1 + TEMP1 = ALPHA*B( I, J ) + TEMP2 = ZERO + DO 80, K = I + 1, M + C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) + TEMP2 = TEMP2 + B( K, J )*A( K, I ) + 80 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 + ELSE + C( I, J ) = BETA *C( I, J ) + + $ TEMP1*A( I, I ) + ALPHA*TEMP2 + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form C := alpha*B*A + beta*C. +* + DO 170, J = 1, N + TEMP1 = ALPHA*A( J, J ) + IF( BETA.EQ.ZERO )THEN + DO 110, I = 1, M + C( I, J ) = TEMP1*B( I, J ) + 110 CONTINUE + ELSE + DO 120, I = 1, M + C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) + 120 CONTINUE + END IF + DO 140, K = 1, J - 1 + IF( UPPER )THEN + TEMP1 = ALPHA*A( K, J ) + ELSE + TEMP1 = ALPHA*A( J, K ) + END IF + DO 130, I = 1, M + C( I, J ) = C( I, J ) + TEMP1*B( I, K ) + 130 CONTINUE + 140 CONTINUE + DO 160, K = J + 1, N + IF( UPPER )THEN + TEMP1 = ALPHA*A( J, K ) + ELSE + TEMP1 = ALPHA*A( K, J ) + END IF + DO 150, I = 1, M + C( I, J ) = C( I, J ) + TEMP1*B( I, K ) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + END IF +* + RETURN +* +* End of DSYMM . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 3 dsymm} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -21473,6 +29224,220 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE DSYR2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, + $ BETA, C, LDC ) +* .. Scalar Arguments .. + CHARACTER*1 UPLO, TRANS + INTEGER N, K, LDA, LDB, LDC + DOUBLE PRECISION ALPHA, BETA +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) +* .. +* +* 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 .. + LOGICAL UPPER + INTEGER I, INFO, J, L, NROWA + DOUBLE PRECISION TEMP1, TEMP2 +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + IF( LSAME( TRANS, 'N' ) )THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME( UPLO, 'U' ) +* + INFO = 0 + IF( ( .NOT.UPPER ).AND. + $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. + $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. + $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN + INFO = 2 + ELSE IF( N .LT.0 )THEN + INFO = 3 + ELSE IF( K .LT.0 )THEN + INFO = 4 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 7 + ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN + INFO = 9 + ELSE IF( LDC.LT.MAX( 1, N ) )THEN + INFO = 12 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSYR2K', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR. + $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* And when alpha.eq.zero. +* + IF( ALPHA.EQ.ZERO )THEN + IF( UPPER )THEN + IF( BETA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, J + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40, J = 1, N + DO 30, I = 1, J + C( I, J ) = BETA*C( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE + IF( BETA.EQ.ZERO )THEN + DO 60, J = 1, N + DO 50, I = J, N + C( I, J ) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80, J = 1, N + DO 70, I = J, N + C( I, J ) = BETA*C( I, J ) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* Form C := alpha*A*B' + alpha*B*A' + C. +* + IF( UPPER )THEN + DO 130, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 90, I = 1, J + C( I, J ) = ZERO + 90 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 100, I = 1, J + C( I, J ) = BETA*C( I, J ) + 100 CONTINUE + END IF + DO 120, L = 1, K + IF( ( A( J, L ).NE.ZERO ).OR. + $ ( B( J, L ).NE.ZERO ) )THEN + TEMP1 = ALPHA*B( J, L ) + TEMP2 = ALPHA*A( J, L ) + DO 110, I = 1, J + C( I, J ) = C( I, J ) + + $ A( I, L )*TEMP1 + B( I, L )*TEMP2 + 110 CONTINUE + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 140, I = J, N + C( I, J ) = ZERO + 140 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 150, I = J, N + C( I, J ) = BETA*C( I, J ) + 150 CONTINUE + END IF + DO 170, L = 1, K + IF( ( A( J, L ).NE.ZERO ).OR. + $ ( B( J, L ).NE.ZERO ) )THEN + TEMP1 = ALPHA*B( J, L ) + TEMP2 = ALPHA*A( J, L ) + DO 160, I = J, N + C( I, J ) = C( I, J ) + + $ A( I, L )*TEMP1 + B( I, L )*TEMP2 + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*A'*B + alpha*B'*A + C. +* + IF( UPPER )THEN + DO 210, J = 1, N + DO 200, I = 1, J + TEMP1 = ZERO + TEMP2 = ZERO + DO 190, L = 1, K + TEMP1 = TEMP1 + A( L, I )*B( L, J ) + TEMP2 = TEMP2 + B( L, I )*A( L, J ) + 190 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 + ELSE + C( I, J ) = BETA *C( I, J ) + + $ ALPHA*TEMP1 + ALPHA*TEMP2 + END IF + 200 CONTINUE + 210 CONTINUE + ELSE + DO 240, J = 1, N + DO 230, I = J, N + TEMP1 = ZERO + TEMP2 = ZERO + DO 220, L = 1, K + TEMP1 = TEMP1 + A( L, I )*B( L, J ) + TEMP2 = TEMP2 + B( L, I )*A( L, J ) + 220 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 + ELSE + C( I, J ) = BETA *C( I, J ) + + $ ALPHA*TEMP1 + ALPHA*TEMP2 + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSYR2K. +* + END + +\end{verbatim} + \begin{chunk}{BLAS 3 dsyr2k} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -21981,6 +29946,205 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE DSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA, + $ BETA, C, LDC ) +* .. Scalar Arguments .. + CHARACTER*1 UPLO, TRANS + INTEGER N, K, LDA, LDC + DOUBLE PRECISION ALPHA, BETA +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ) +* .. +* +* 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 .. + LOGICAL UPPER + INTEGER I, INFO, J, L, NROWA + DOUBLE PRECISION TEMP +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + IF( LSAME( TRANS, 'N' ) )THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME( UPLO, 'U' ) +* + INFO = 0 + IF( ( .NOT.UPPER ).AND. + $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. + $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. + $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN + INFO = 2 + ELSE IF( N .LT.0 )THEN + INFO = 3 + ELSE IF( K .LT.0 )THEN + INFO = 4 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 7 + ELSE IF( LDC.LT.MAX( 1, N ) )THEN + INFO = 10 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSYRK ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR. + $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* And when alpha.eq.zero. +* + IF( ALPHA.EQ.ZERO )THEN + IF( UPPER )THEN + IF( BETA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, J + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40, J = 1, N + DO 30, I = 1, J + C( I, J ) = BETA*C( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE + IF( BETA.EQ.ZERO )THEN + DO 60, J = 1, N + DO 50, I = J, N + C( I, J ) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80, J = 1, N + DO 70, I = J, N + C( I, J ) = BETA*C( I, J ) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* Form C := alpha*A*A' + beta*C. +* + IF( UPPER )THEN + DO 130, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 90, I = 1, J + C( I, J ) = ZERO + 90 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 100, I = 1, J + C( I, J ) = BETA*C( I, J ) + 100 CONTINUE + END IF + DO 120, L = 1, K + IF( A( J, L ).NE.ZERO )THEN + TEMP = ALPHA*A( J, L ) + DO 110, I = 1, J + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 110 CONTINUE + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 140, I = J, N + C( I, J ) = ZERO + 140 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 150, I = J, N + C( I, J ) = BETA*C( I, J ) + 150 CONTINUE + END IF + DO 170, L = 1, K + IF( A( J, L ).NE.ZERO )THEN + TEMP = ALPHA*A( J, L ) + DO 160, I = J, N + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*A'*A + beta*C. +* + IF( UPPER )THEN + DO 210, J = 1, N + DO 200, I = 1, J + TEMP = ZERO + DO 190, L = 1, K + TEMP = TEMP + A( L, I )*A( L, J ) + 190 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 200 CONTINUE + 210 CONTINUE + ELSE + DO 240, J = 1, N + DO 230, I = J, N + TEMP = ZERO + DO 220, L = 1, K + TEMP = TEMP + A( L, I )*A( L, J ) + 220 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSYRK . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 3 dsyrk} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -22436,6 +30600,258 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, + $ B, LDB ) +* .. Scalar Arguments .. + CHARACTER*1 SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB + DOUBLE PRECISION ALPHA +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* 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 .. + LOGICAL LSIDE, NOUNIT, UPPER + INTEGER I, INFO, J, K, NROWA + DOUBLE PRECISION TEMP +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Executable Statements .. +* +* 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( 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'*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'. +* + 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 + +\end{verbatim} + \begin{chunk}{BLAS 3 dtrmm} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -23073,6 +31489,279 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, + $ B, LDB ) +* .. Scalar Arguments .. + CHARACTER*1 SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB + DOUBLE PRECISION ALPHA +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* 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 .. + LOGICAL LSIDE, NOUNIT, UPPER + INTEGER I, INFO, J, K, NROWA + DOUBLE PRECISION TEMP +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Executable Statements .. +* +* 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( 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. +* + 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' ). +* + 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 + +\end{verbatim} + \begin{chunk}{BLAS 3 dtrsm} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -23783,6 +32472,314 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, + $ BETA, C, LDC ) +* .. Scalar Arguments .. + CHARACTER*1 TRANSA, TRANSB + INTEGER M, N, K, LDA, LDB, LDC + COMPLEX*16 ALPHA, BETA +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) +* .. +* +* 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 .. + LOGICAL CONJA, CONJB, NOTA, NOTB + INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB + COMPLEX*16 TEMP +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Executable Statements .. +* +* 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 + +\end{verbatim} + \begin{chunk}{BLAS 3 zgemm} (let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) (declare (type (complex double-float) one) (type (complex double-float) zero)) @@ -24458,6 +33455,197 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZHEMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, + $ BETA, C, LDC ) +* .. Scalar Arguments .. + CHARACTER*1 SIDE, UPLO + INTEGER M, N, LDA, LDB, LDC + COMPLEX*16 ALPHA, BETA +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) +* .. +* +* 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, DBLE +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, INFO, J, K, NROWA + COMPLEX*16 TEMP1, TEMP2 +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Executable Statements .. +* +* Set NROWA as the number of rows of A. +* + IF( LSAME( SIDE, 'L' ) )THEN + NROWA = M + ELSE + NROWA = N + END IF + UPPER = LSAME( UPLO, 'U' ) +* +* Test the input parameters. +* + INFO = 0 + IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. + $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.UPPER ).AND. + $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN + INFO = 2 + ELSE IF( M .LT.0 )THEN + INFO = 3 + ELSE IF( N .LT.0 )THEN + INFO = 4 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 7 + ELSE IF( LDB.LT.MAX( 1, M ) )THEN + INFO = 9 + ELSE IF( LDC.LT.MAX( 1, M ) )THEN + INFO = 12 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'ZHEMM ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* And when alpha.eq.zero. +* + IF( ALPHA.EQ.ZERO )THEN + IF( BETA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, M + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40, J = 1, N + DO 30, I = 1, M + C( I, J ) = BETA*C( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF( LSAME( SIDE, 'L' ) )THEN +* +* Form C := alpha*A*B + beta*C. +* + IF( UPPER )THEN + DO 70, J = 1, N + DO 60, I = 1, M + TEMP1 = ALPHA*B( I, J ) + TEMP2 = ZERO + DO 50, K = 1, I - 1 + C( K, J ) = C( K, J ) + TEMP1*A( K, I ) + TEMP2 = TEMP2 + + $ B( K, J )*DCONJG( A( K, I ) ) + 50 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = TEMP1*DBLE( A( I, I ) ) + + $ ALPHA*TEMP2 + ELSE + C( I, J ) = BETA *C( I, J ) + + $ TEMP1*DBLE( A( I, I ) ) + + $ ALPHA*TEMP2 + END IF + 60 CONTINUE + 70 CONTINUE + ELSE + DO 100, J = 1, N + DO 90, I = M, 1, -1 + TEMP1 = ALPHA*B( I, J ) + TEMP2 = ZERO + DO 80, K = I + 1, M + C( K, J ) = C( K, J ) + TEMP1*A( K, I ) + TEMP2 = TEMP2 + + $ B( K, J )*DCONJG( A( K, I ) ) + 80 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = TEMP1*DBLE( A( I, I ) ) + + $ ALPHA*TEMP2 + ELSE + C( I, J ) = BETA *C( I, J ) + + $ TEMP1*DBLE( A( I, I ) ) + + $ ALPHA*TEMP2 + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form C := alpha*B*A + beta*C. +* + DO 170, J = 1, N + TEMP1 = ALPHA*DBLE( A( J, J ) ) + IF( BETA.EQ.ZERO )THEN + DO 110, I = 1, M + C( I, J ) = TEMP1*B( I, J ) + 110 CONTINUE + ELSE + DO 120, I = 1, M + C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) + 120 CONTINUE + END IF + DO 140, K = 1, J - 1 + IF( UPPER )THEN + TEMP1 = ALPHA*A( K, J ) + ELSE + TEMP1 = ALPHA*DCONJG( A( J, K ) ) + END IF + DO 130, I = 1, M + C( I, J ) = C( I, J ) + TEMP1*B( I, K ) + 130 CONTINUE + 140 CONTINUE + DO 160, K = J + 1, N + IF( UPPER )THEN + TEMP1 = ALPHA*DCONJG( A( J, K ) ) + ELSE + TEMP1 = ALPHA*A( K, J ) + END IF + DO 150, I = 1, M + C( I, J ) = C( I, J ) + TEMP1*B( I, K ) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + END IF +* + RETURN +* +* End of ZHEMM . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 3 zhemm} (let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) (declare (type (complex double-float) one) (type (complex double-float) zero)) @@ -24979,6 +34167,263 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZHER2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, + $ C, LDC ) +* .. Scalar Arguments .. + CHARACTER TRANS, UPLO + INTEGER K, LDA, LDB, LDC, N + DOUBLE PRECISION BETA + COMPLEX*16 ALPHA +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) +* .. +* +* Level 3 Blas routine. +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. +* Ed Anderson, Cray Research Inc. +* +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCONJG, MAX +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, INFO, J, L, NROWA + COMPLEX*16 TEMP1, TEMP2 +* .. +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + IF( LSAME( TRANS, 'N' ) ) THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME( UPLO, 'U' ) +* + INFO = 0 + IF( ( .NOT.UPPER ) .AND. ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN + INFO = 1 + ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ) .AND. + $ ( .NOT.LSAME( TRANS, 'C' ) ) ) THEN + INFO = 2 + ELSE IF( N.LT.0 ) THEN + INFO = 3 + ELSE IF( K.LT.0 ) THEN + INFO = 4 + ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN + INFO = 7 + ELSE IF( LDB.LT.MAX( 1, NROWA ) ) THEN + INFO = 9 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = 12 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHER2K', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ) .OR. ( ( ( ALPHA.EQ.ZERO ) .OR. ( K.EQ.0 ) ) .AND. + $ ( BETA.EQ.ONE ) ) )RETURN +* +* And when alpha.eq.zero. +* + IF( ALPHA.EQ.ZERO ) THEN + IF( UPPER ) THEN + IF( BETA.EQ.DBLE( ZERO ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, J + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = 1, J - 1 + C( I, J ) = BETA*C( I, J ) + 30 CONTINUE + C( J, J ) = BETA*DBLE( C( J, J ) ) + 40 CONTINUE + END IF + ELSE + IF( BETA.EQ.DBLE( ZERO ) ) THEN + DO 60 J = 1, N + DO 50 I = J, N + C( I, J ) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80 J = 1, N + C( J, J ) = BETA*DBLE( C( J, J ) ) + DO 70 I = J + 1, N + C( I, J ) = BETA*C( I, J ) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF( LSAME( TRANS, 'N' ) ) THEN +* +* Form C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + +* C. +* + IF( UPPER ) THEN + DO 130 J = 1, N + IF( BETA.EQ.DBLE( ZERO ) ) THEN + DO 90 I = 1, J + C( I, J ) = ZERO + 90 CONTINUE + ELSE IF( BETA.NE.ONE ) THEN + DO 100 I = 1, J - 1 + C( I, J ) = BETA*C( I, J ) + 100 CONTINUE + C( J, J ) = BETA*DBLE( C( J, J ) ) + ELSE + C( J, J ) = DBLE( C( J, J ) ) + END IF + DO 120 L = 1, K + IF( ( A( J, L ).NE.ZERO ) .OR. ( B( J, L ).NE.ZERO ) ) + $ THEN + TEMP1 = ALPHA*DCONJG( B( J, L ) ) + TEMP2 = DCONJG( ALPHA*A( J, L ) ) + DO 110 I = 1, J - 1 + C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + + $ B( I, L )*TEMP2 + 110 CONTINUE + C( J, J ) = DBLE( C( J, J ) ) + + $ DBLE( A( J, L )*TEMP1+B( J, L )*TEMP2 ) + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180 J = 1, N + IF( BETA.EQ.DBLE( ZERO ) ) THEN + DO 140 I = J, N + C( I, J ) = ZERO + 140 CONTINUE + ELSE IF( BETA.NE.ONE ) THEN + DO 150 I = J + 1, N + C( I, J ) = BETA*C( I, J ) + 150 CONTINUE + C( J, J ) = BETA*DBLE( C( J, J ) ) + ELSE + C( J, J ) = DBLE( C( J, J ) ) + END IF + DO 170 L = 1, K + IF( ( A( J, L ).NE.ZERO ) .OR. ( B( J, L ).NE.ZERO ) ) + $ THEN + TEMP1 = ALPHA*DCONJG( B( J, L ) ) + TEMP2 = DCONJG( ALPHA*A( J, L ) ) + DO 160 I = J + 1, N + C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + + $ B( I, L )*TEMP2 + 160 CONTINUE + C( J, J ) = DBLE( C( J, J ) ) + + $ DBLE( A( J, L )*TEMP1+B( J, L )*TEMP2 ) + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + +* C. +* + IF( UPPER ) THEN + DO 210 J = 1, N + DO 200 I = 1, J + TEMP1 = ZERO + TEMP2 = ZERO + DO 190 L = 1, K + TEMP1 = TEMP1 + DCONJG( A( L, I ) )*B( L, J ) + TEMP2 = TEMP2 + DCONJG( B( L, I ) )*A( L, J ) + 190 CONTINUE + IF( I.EQ.J ) THEN + IF( BETA.EQ.DBLE( ZERO ) ) THEN + C( J, J ) = DBLE( ALPHA*TEMP1+DCONJG( ALPHA )* + $ TEMP2 ) + ELSE + C( J, J ) = BETA*DBLE( C( J, J ) ) + + $ DBLE( ALPHA*TEMP1+DCONJG( ALPHA )* + $ TEMP2 ) + END IF + ELSE + IF( BETA.EQ.DBLE( ZERO ) ) THEN + C( I, J ) = ALPHA*TEMP1 + DCONJG( ALPHA )*TEMP2 + ELSE + C( I, J ) = BETA*C( I, J ) + ALPHA*TEMP1 + + $ DCONJG( ALPHA )*TEMP2 + END IF + END IF + 200 CONTINUE + 210 CONTINUE + ELSE + DO 240 J = 1, N + DO 230 I = J, N + TEMP1 = ZERO + TEMP2 = ZERO + DO 220 L = 1, K + TEMP1 = TEMP1 + DCONJG( A( L, I ) )*B( L, J ) + TEMP2 = TEMP2 + DCONJG( B( L, I ) )*A( L, J ) + 220 CONTINUE + IF( I.EQ.J ) THEN + IF( BETA.EQ.DBLE( ZERO ) ) THEN + C( J, J ) = DBLE( ALPHA*TEMP1+DCONJG( ALPHA )* + $ TEMP2 ) + ELSE + C( J, J ) = BETA*DBLE( C( J, J ) ) + + $ DBLE( ALPHA*TEMP1+DCONJG( ALPHA )* + $ TEMP2 ) + END IF + ELSE + IF( BETA.EQ.DBLE( ZERO ) ) THEN + C( I, J ) = ALPHA*TEMP1 + DCONJG( ALPHA )*TEMP2 + ELSE + C( I, J ) = BETA*C( I, J ) + ALPHA*TEMP1 + + $ DCONJG( ALPHA )*TEMP2 + END IF + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZHER2K. +* + END + +\end{verbatim} + \begin{chunk}{BLAS 3 zher2k} (let* ((one 1.0) (zero (complex 0.0 0.0))) (declare (type (double-float 1.0 1.0) one) (type (complex double-float) zero)) @@ -25708,6 +35153,240 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZHERK( UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC ) +* .. Scalar Arguments .. + CHARACTER TRANS, UPLO + INTEGER K, LDA, LDC, N + DOUBLE PRECISION ALPHA, BETA +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ) +* .. +* +* Level 3 Blas routine. +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. +* Ed Anderson, Cray Research Inc. +* +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX, DCONJG, MAX +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, INFO, J, L, NROWA + DOUBLE PRECISION RTEMP + COMPLEX*16 TEMP +* .. +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + IF( LSAME( TRANS, 'N' ) ) THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME( UPLO, 'U' ) +* + INFO = 0 + IF( ( .NOT.UPPER ) .AND. ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN + INFO = 1 + ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ) .AND. + $ ( .NOT.LSAME( TRANS, 'C' ) ) ) THEN + INFO = 2 + ELSE IF( N.LT.0 ) THEN + INFO = 3 + ELSE IF( K.LT.0 ) THEN + INFO = 4 + ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN + INFO = 7 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = 10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHERK ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ) .OR. ( ( ( ALPHA.EQ.ZERO ) .OR. ( K.EQ.0 ) ) .AND. + $ ( BETA.EQ.ONE ) ) )RETURN +* +* And when alpha.eq.zero. +* + IF( ALPHA.EQ.ZERO ) THEN + IF( UPPER ) THEN + IF( BETA.EQ.ZERO ) THEN + DO 20 J = 1, N + DO 10 I = 1, J + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = 1, J - 1 + C( I, J ) = BETA*C( I, J ) + 30 CONTINUE + C( J, J ) = BETA*DBLE( C( J, J ) ) + 40 CONTINUE + END IF + ELSE + IF( BETA.EQ.ZERO ) THEN + DO 60 J = 1, N + DO 50 I = J, N + C( I, J ) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80 J = 1, N + C( J, J ) = BETA*DBLE( C( J, J ) ) + DO 70 I = J + 1, N + C( I, J ) = BETA*C( I, J ) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF( LSAME( TRANS, 'N' ) ) THEN +* +* Form C := alpha*A*conjg( A' ) + beta*C. +* + IF( UPPER ) THEN + DO 130 J = 1, N + IF( BETA.EQ.ZERO ) THEN + DO 90 I = 1, J + C( I, J ) = ZERO + 90 CONTINUE + ELSE IF( BETA.NE.ONE ) THEN + DO 100 I = 1, J - 1 + C( I, J ) = BETA*C( I, J ) + 100 CONTINUE + C( J, J ) = BETA*DBLE( C( J, J ) ) + ELSE + C( J, J ) = DBLE( C( J, J ) ) + END IF + DO 120 L = 1, K + IF( A( J, L ).NE.DCMPLX( ZERO ) ) THEN + TEMP = ALPHA*DCONJG( A( J, L ) ) + DO 110 I = 1, J - 1 + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 110 CONTINUE + C( J, J ) = DBLE( C( J, J ) ) + + $ DBLE( TEMP*A( I, L ) ) + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180 J = 1, N + IF( BETA.EQ.ZERO ) THEN + DO 140 I = J, N + C( I, J ) = ZERO + 140 CONTINUE + ELSE IF( BETA.NE.ONE ) THEN + C( J, J ) = BETA*DBLE( C( J, J ) ) + DO 150 I = J + 1, N + C( I, J ) = BETA*C( I, J ) + 150 CONTINUE + ELSE + C( J, J ) = DBLE( C( J, J ) ) + END IF + DO 170 L = 1, K + IF( A( J, L ).NE.DCMPLX( ZERO ) ) THEN + TEMP = ALPHA*DCONJG( A( J, L ) ) + C( J, J ) = DBLE( C( J, J ) ) + + $ DBLE( TEMP*A( J, L ) ) + DO 160 I = J + 1, N + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*conjg( A' )*A + beta*C. +* + IF( UPPER ) THEN + DO 220 J = 1, N + DO 200 I = 1, J - 1 + TEMP = ZERO + DO 190 L = 1, K + TEMP = TEMP + DCONJG( A( L, I ) )*A( L, J ) + 190 CONTINUE + IF( BETA.EQ.ZERO ) THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 200 CONTINUE + RTEMP = ZERO + DO 210 L = 1, K + RTEMP = RTEMP + DCONJG( A( L, J ) )*A( L, J ) + 210 CONTINUE + IF( BETA.EQ.ZERO ) THEN + C( J, J ) = ALPHA*RTEMP + ELSE + C( J, J ) = ALPHA*RTEMP + BETA*DBLE( C( J, J ) ) + END IF + 220 CONTINUE + ELSE + DO 260 J = 1, N + RTEMP = ZERO + DO 230 L = 1, K + RTEMP = RTEMP + DCONJG( A( L, J ) )*A( L, J ) + 230 CONTINUE + IF( BETA.EQ.ZERO ) THEN + C( J, J ) = ALPHA*RTEMP + ELSE + C( J, J ) = ALPHA*RTEMP + BETA*DBLE( C( J, J ) ) + END IF + DO 250 I = J + 1, N + TEMP = ZERO + DO 240 L = 1, K + TEMP = TEMP + DCONJG( A( L, I ) )*A( L, J ) + 240 CONTINUE + IF( BETA.EQ.ZERO ) THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 250 CONTINUE + 260 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZHERK . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 3 zherk} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -26390,6 +36069,191 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZSYMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, + $ BETA, C, LDC ) +* .. Scalar Arguments .. + CHARACTER*1 SIDE, UPLO + INTEGER M, N, LDA, LDB, LDC + COMPLEX*16 ALPHA, BETA +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) +* .. +* +* 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 .. + LOGICAL UPPER + INTEGER I, INFO, J, K, NROWA + COMPLEX*16 TEMP1, TEMP2 +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Executable Statements .. +* +* Set NROWA as the number of rows of A. +* + IF( LSAME( SIDE, 'L' ) )THEN + NROWA = M + ELSE + NROWA = N + END IF + UPPER = LSAME( UPLO, 'U' ) +* +* Test the input parameters. +* + INFO = 0 + IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. + $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.UPPER ).AND. + $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN + INFO = 2 + ELSE IF( M .LT.0 )THEN + INFO = 3 + ELSE IF( N .LT.0 )THEN + INFO = 4 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 7 + ELSE IF( LDB.LT.MAX( 1, M ) )THEN + INFO = 9 + ELSE IF( LDC.LT.MAX( 1, M ) )THEN + INFO = 12 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'ZSYMM ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* And when alpha.eq.zero. +* + IF( ALPHA.EQ.ZERO )THEN + IF( BETA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, M + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40, J = 1, N + DO 30, I = 1, M + C( I, J ) = BETA*C( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF( LSAME( SIDE, 'L' ) )THEN +* +* Form C := alpha*A*B + beta*C. +* + IF( UPPER )THEN + DO 70, J = 1, N + DO 60, I = 1, M + TEMP1 = ALPHA*B( I, J ) + TEMP2 = ZERO + DO 50, K = 1, I - 1 + C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) + TEMP2 = TEMP2 + B( K, J )*A( K, I ) + 50 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 + ELSE + C( I, J ) = BETA *C( I, J ) + + $ TEMP1*A( I, I ) + ALPHA*TEMP2 + END IF + 60 CONTINUE + 70 CONTINUE + ELSE + DO 100, J = 1, N + DO 90, I = M, 1, -1 + TEMP1 = ALPHA*B( I, J ) + TEMP2 = ZERO + DO 80, K = I + 1, M + C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) + TEMP2 = TEMP2 + B( K, J )*A( K, I ) + 80 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 + ELSE + C( I, J ) = BETA *C( I, J ) + + $ TEMP1*A( I, I ) + ALPHA*TEMP2 + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form C := alpha*B*A + beta*C. +* + DO 170, J = 1, N + TEMP1 = ALPHA*A( J, J ) + IF( BETA.EQ.ZERO )THEN + DO 110, I = 1, M + C( I, J ) = TEMP1*B( I, J ) + 110 CONTINUE + ELSE + DO 120, I = 1, M + C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) + 120 CONTINUE + END IF + DO 140, K = 1, J - 1 + IF( UPPER )THEN + TEMP1 = ALPHA*A( K, J ) + ELSE + TEMP1 = ALPHA*A( J, K ) + END IF + DO 130, I = 1, M + C( I, J ) = C( I, J ) + TEMP1*B( I, K ) + 130 CONTINUE + 140 CONTINUE + DO 160, K = J + 1, N + IF( UPPER )THEN + TEMP1 = ALPHA*A( J, K ) + ELSE + TEMP1 = ALPHA*A( K, J ) + END IF + DO 150, I = 1, M + C( I, J ) = C( I, J ) + TEMP1*B( I, K ) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + END IF +* + RETURN +* +* End of ZSYMM . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 3 zsymm} (let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) (declare (type (complex double-float) one) (type (complex double-float) zero)) @@ -26893,6 +36757,220 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZSYR2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, + $ BETA, C, LDC ) +* .. Scalar Arguments .. + CHARACTER*1 UPLO, TRANS + INTEGER N, K, LDA, LDB, LDC + COMPLEX*16 ALPHA, BETA +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) +* .. +* +* 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 .. + LOGICAL UPPER + INTEGER I, INFO, J, L, NROWA + COMPLEX*16 TEMP1, TEMP2 +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + IF( LSAME( TRANS, 'N' ) )THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME( UPLO, 'U' ) +* + INFO = 0 + IF( ( .NOT.UPPER ).AND. + $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. + $ ( .NOT.LSAME( TRANS, 'T' ) ) )THEN + INFO = 2 + ELSE IF( N .LT.0 )THEN + INFO = 3 + ELSE IF( K .LT.0 )THEN + INFO = 4 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 7 + ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN + INFO = 9 + ELSE IF( LDC.LT.MAX( 1, N ) )THEN + INFO = 12 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'ZSYR2K', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR. + $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* And when alpha.eq.zero. +* + IF( ALPHA.EQ.ZERO )THEN + IF( UPPER )THEN + IF( BETA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, J + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40, J = 1, N + DO 30, I = 1, J + C( I, J ) = BETA*C( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE + IF( BETA.EQ.ZERO )THEN + DO 60, J = 1, N + DO 50, I = J, N + C( I, J ) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80, J = 1, N + DO 70, I = J, N + C( I, J ) = BETA*C( I, J ) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* Form C := alpha*A*B' + alpha*B*A' + C. +* + IF( UPPER )THEN + DO 130, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 90, I = 1, J + C( I, J ) = ZERO + 90 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 100, I = 1, J + C( I, J ) = BETA*C( I, J ) + 100 CONTINUE + END IF + DO 120, L = 1, K + IF( ( A( J, L ).NE.ZERO ).OR. + $ ( B( J, L ).NE.ZERO ) )THEN + TEMP1 = ALPHA*B( J, L ) + TEMP2 = ALPHA*A( J, L ) + DO 110, I = 1, J + C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + + $ B( I, L )*TEMP2 + 110 CONTINUE + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 140, I = J, N + C( I, J ) = ZERO + 140 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 150, I = J, N + C( I, J ) = BETA*C( I, J ) + 150 CONTINUE + END IF + DO 170, L = 1, K + IF( ( A( J, L ).NE.ZERO ).OR. + $ ( B( J, L ).NE.ZERO ) )THEN + TEMP1 = ALPHA*B( J, L ) + TEMP2 = ALPHA*A( J, L ) + DO 160, I = J, N + C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + + $ B( I, L )*TEMP2 + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*A'*B + alpha*B'*A + C. +* + IF( UPPER )THEN + DO 210, J = 1, N + DO 200, I = 1, J + TEMP1 = ZERO + TEMP2 = ZERO + DO 190, L = 1, K + TEMP1 = TEMP1 + A( L, I )*B( L, J ) + TEMP2 = TEMP2 + B( L, I )*A( L, J ) + 190 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 + ELSE + C( I, J ) = BETA *C( I, J ) + + $ ALPHA*TEMP1 + ALPHA*TEMP2 + END IF + 200 CONTINUE + 210 CONTINUE + ELSE + DO 240, J = 1, N + DO 230, I = J, N + TEMP1 = ZERO + TEMP2 = ZERO + DO 220, L = 1, K + TEMP1 = TEMP1 + A( L, I )*B( L, J ) + TEMP2 = TEMP2 + B( L, I )*A( L, J ) + 220 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 + ELSE + C( I, J ) = BETA *C( I, J ) + + $ ALPHA*TEMP1 + ALPHA*TEMP2 + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZSYR2K. +* + END + +\end{verbatim} + \begin{chunk}{BLAS 3 zsyr2k} (let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) (declare (type (complex double-float) one) (type (complex double-float) zero)) @@ -27397,6 +37475,206 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA, + $ BETA, C, LDC ) +* .. Scalar Arguments .. + CHARACTER*1 UPLO, TRANS + INTEGER N, K, LDA, LDC + COMPLEX*16 ALPHA, BETA +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ) +* .. +* +* 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 .. + LOGICAL UPPER + INTEGER I, INFO, J, L, NROWA + COMPLEX*16 TEMP +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + IF( LSAME( TRANS, 'N' ) )THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME( UPLO, 'U' ) +* + INFO = 0 + IF( ( .NOT.UPPER ).AND. + $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. + $ ( .NOT.LSAME( TRANS, 'T' ) ) )THEN + INFO = 2 + ELSE IF( N .LT.0 )THEN + INFO = 3 + ELSE IF( K .LT.0 )THEN + INFO = 4 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 7 + ELSE IF( LDC.LT.MAX( 1, N ) )THEN + INFO = 10 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'ZSYRK ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR. + $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* And when alpha.eq.zero. +* + IF( ALPHA.EQ.ZERO )THEN + IF( UPPER )THEN + IF( BETA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, J + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40, J = 1, N + DO 30, I = 1, J + C( I, J ) = BETA*C( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE + IF( BETA.EQ.ZERO )THEN + DO 60, J = 1, N + DO 50, I = J, N + C( I, J ) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80, J = 1, N + DO 70, I = J, N + C( I, J ) = BETA*C( I, J ) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* Form C := alpha*A*A' + beta*C. +* + IF( UPPER )THEN + DO 130, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 90, I = 1, J + C( I, J ) = ZERO + 90 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 100, I = 1, J + C( I, J ) = BETA*C( I, J ) + 100 CONTINUE + END IF + DO 120, L = 1, K + IF( A( J, L ).NE.ZERO )THEN + TEMP = ALPHA*A( J, L ) + DO 110, I = 1, J + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 110 CONTINUE + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 140, I = J, N + C( I, J ) = ZERO + 140 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 150, I = J, N + C( I, J ) = BETA*C( I, J ) + 150 CONTINUE + END IF + DO 170, L = 1, K + IF( A( J, L ).NE.ZERO )THEN + TEMP = ALPHA*A( J, L ) + DO 160, I = J, N + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*A'*A + beta*C. +* + IF( UPPER )THEN + DO 210, J = 1, N + DO 200, I = 1, J + TEMP = ZERO + DO 190, L = 1, K + TEMP = TEMP + A( L, I )*A( L, J ) + 190 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 200 CONTINUE + 210 CONTINUE + ELSE + DO 240, J = 1, N + DO 230, I = J, N + TEMP = ZERO + DO 220, L = 1, K + TEMP = TEMP + A( L, I )*A( L, J ) + 220 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZSYRK . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 3 zsyrk} (let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) (declare (type (complex double-float) one) (type (complex double-float) zero)) @@ -27846,6 +38124,295 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, + $ B, LDB ) +* .. Scalar Arguments .. + CHARACTER*1 SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB + COMPLEX*16 ALPHA +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ) +* .. +* +* 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 .. + LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER + INTEGER I, INFO, J, K, NROWA + COMPLEX*16 TEMP +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + LSIDE = LSAME( SIDE , 'L' ) + IF( LSIDE )THEN + NROWA = M + ELSE + NROWA = N + END IF + NOCONJ = LSAME( TRANSA, 'T' ) + NOUNIT = LSAME( DIAG , 'N' ) + UPPER = LSAME( UPLO , 'U' ) +* + INFO = 0 + IF( ( .NOT.LSIDE ).AND. + $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.UPPER ).AND. + $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN + INFO = 2 + ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. + $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. + $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN + INFO = 3 + ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. + $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN + INFO = 4 + ELSE IF( M .LT.0 )THEN + INFO = 5 + ELSE IF( N .LT.0 )THEN + INFO = 6 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 9 + ELSE IF( LDB.LT.MAX( 1, M ) )THEN + INFO = 11 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'ZTRMM ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( 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'*B or B := alpha*conjg( A' )*B. +* + IF( UPPER )THEN + DO 120, J = 1, N + DO 110, I = M, 1, -1 + TEMP = B( I, J ) + IF( NOCONJ )THEN + IF( NOUNIT ) + $ TEMP = TEMP*A( I, I ) + DO 90, K = 1, I - 1 + TEMP = TEMP + A( K, I )*B( K, J ) + 90 CONTINUE + ELSE + IF( NOUNIT ) + $ TEMP = TEMP*DCONJG( A( I, I ) ) + DO 100, K = 1, I - 1 + TEMP = TEMP + DCONJG( A( K, I ) )*B( K, J ) + 100 CONTINUE + END IF + B( I, J ) = ALPHA*TEMP + 110 CONTINUE + 120 CONTINUE + ELSE + DO 160, J = 1, N + DO 150, I = 1, M + TEMP = B( I, J ) + IF( NOCONJ )THEN + IF( NOUNIT ) + $ TEMP = TEMP*A( I, I ) + DO 130, K = I + 1, M + TEMP = TEMP + A( K, I )*B( K, J ) + 130 CONTINUE + ELSE + IF( NOUNIT ) + $ TEMP = TEMP*DCONJG( A( I, I ) ) + DO 140, K = I + 1, M + TEMP = TEMP + DCONJG( A( K, I ) )*B( K, J ) + 140 CONTINUE + END IF + B( I, J ) = ALPHA*TEMP + 150 CONTINUE + 160 CONTINUE + END IF + END IF + ELSE + IF( LSAME( TRANSA, 'N' ) )THEN +* +* Form B := alpha*B*A. +* + IF( UPPER )THEN + DO 200, J = N, 1, -1 + TEMP = ALPHA + IF( NOUNIT ) + $ TEMP = TEMP*A( J, J ) + DO 170, I = 1, M + B( I, J ) = TEMP*B( I, J ) + 170 CONTINUE + DO 190, K = 1, J - 1 + IF( A( K, J ).NE.ZERO )THEN + TEMP = ALPHA*A( K, J ) + DO 180, I = 1, M + B( I, J ) = B( I, J ) + TEMP*B( I, K ) + 180 CONTINUE + END IF + 190 CONTINUE + 200 CONTINUE + ELSE + DO 240, J = 1, N + TEMP = ALPHA + IF( NOUNIT ) + $ TEMP = TEMP*A( J, J ) + DO 210, I = 1, M + B( I, J ) = TEMP*B( I, J ) + 210 CONTINUE + DO 230, K = J + 1, N + IF( A( K, J ).NE.ZERO )THEN + TEMP = ALPHA*A( K, J ) + DO 220, I = 1, M + B( I, J ) = B( I, J ) + TEMP*B( I, K ) + 220 CONTINUE + END IF + 230 CONTINUE + 240 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*A' or B := alpha*B*conjg( A' ). +* + IF( UPPER )THEN + DO 280, K = 1, N + DO 260, J = 1, K - 1 + IF( A( J, K ).NE.ZERO )THEN + IF( NOCONJ )THEN + TEMP = ALPHA*A( J, K ) + ELSE + TEMP = ALPHA*DCONJG( A( J, K ) ) + END IF + DO 250, I = 1, M + B( I, J ) = B( I, J ) + TEMP*B( I, K ) + 250 CONTINUE + END IF + 260 CONTINUE + TEMP = ALPHA + IF( NOUNIT )THEN + IF( NOCONJ )THEN + TEMP = TEMP*A( K, K ) + ELSE + TEMP = TEMP*DCONJG( A( K, K ) ) + END IF + END IF + IF( TEMP.NE.ONE )THEN + DO 270, I = 1, M + B( I, K ) = TEMP*B( I, K ) + 270 CONTINUE + END IF + 280 CONTINUE + ELSE + DO 320, K = N, 1, -1 + DO 300, J = K + 1, N + IF( A( J, K ).NE.ZERO )THEN + IF( NOCONJ )THEN + TEMP = ALPHA*A( J, K ) + ELSE + TEMP = ALPHA*DCONJG( A( J, K ) ) + END IF + DO 290, I = 1, M + B( I, J ) = B( I, J ) + TEMP*B( I, K ) + 290 CONTINUE + END IF + 300 CONTINUE + TEMP = ALPHA + IF( NOUNIT )THEN + IF( NOCONJ )THEN + TEMP = TEMP*A( K, K ) + ELSE + TEMP = TEMP*DCONJG( A( K, K ) ) + END IF + END IF + IF( TEMP.NE.ONE )THEN + DO 310, I = 1, M + B( I, K ) = TEMP*B( I, K ) + 310 CONTINUE + END IF + 320 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTRMM . +* + END + +\end{verbatim} + \begin{chunk}{BLAS 3 ztrmm} (let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) (declare (type (complex double-float) one) (type (complex double-float) zero)) @@ -28584,6 +39151,315 @@ Man Page Details \end{chunk} +\begin{verbatim} + SUBROUTINE ZTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, + $ B, LDB ) +* .. Scalar Arguments .. + CHARACTER*1 SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB + COMPLEX*16 ALPHA +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ) +* .. +* +* 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 .. + LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER + INTEGER I, INFO, J, K, NROWA + COMPLEX*16 TEMP +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Executable Statements .. +* +* 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 + +\end{verbatim} + \begin{chunk}{BLAS 3 ztrsm} (let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) (declare (type (complex double-float) one) (type (complex double-float) zero)) @@ -29383,6 +40259,13 @@ ARGUMENTS > 0: The algorithm failed to compute an singular value. The update process of divide and conquer failed. + Further Details + =============== + + Based on contributions by + Ming Gu and Huan Ren, Computer Science Division, University of + California at Berkeley, USA + \end{chunk} The input arguments are: @@ -29436,6 +40319,324 @@ The return values are: \calls{dbdsdc}{xerbla} \calls{dbdsdc}{char-equal} +\begin{verbatim} + SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, + $ WORK, IWORK, INFO ) +* +* -- LAPACK routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* December 1, 1999 +* +* .. Scalar Arguments .. + CHARACTER COMPQ, UPLO + INTEGER INFO, LDU, LDVT, N +* .. +* .. Array Arguments .. + INTEGER IQ( * ), IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), Q( * ), U( LDU, * ), + $ VT( LDVT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER DIFL, DIFR, GIVCOL, GIVNUM, GIVPTR, I, IC, + $ ICOMPQ, IERR, II, IS, IU, IUPLO, IVT, J, K, KK, + $ MLVL, NM1, NSIZE, PERM, POLES, QSTART, SMLSIZ, + $ SMLSZP, SQRE, START, WSTART, Z + DOUBLE PRECISION CS, EPS, ORGNRM, P, R, SN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANST + EXTERNAL LSAME, ILAENV, DLAMCH, DLANST +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLARTG, DLASCL, DLASD0, DLASDA, DLASDQ, + $ DLASET, DLASR, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, LOG, SIGN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IUPLO = 0 + IF( LSAME( UPLO, 'U' ) ) + $ IUPLO = 1 + IF( LSAME( UPLO, 'L' ) ) + $ IUPLO = 2 + IF( LSAME( COMPQ, 'N' ) ) THEN + ICOMPQ = 0 + ELSE IF( LSAME( COMPQ, 'P' ) ) THEN + ICOMPQ = 1 + ELSE IF( LSAME( COMPQ, 'I' ) ) THEN + ICOMPQ = 2 + ELSE + ICOMPQ = -1 + END IF + IF( IUPLO.EQ.0 ) THEN + INFO = -1 + ELSE IF( ICOMPQ.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ( LDU.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDU.LT. + $ N ) ) ) THEN + INFO = -7 + ELSE IF( ( LDVT.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDVT.LT. + $ N ) ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DBDSDC', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + SMLSIZ = ILAENV( 9, 'DBDSDC', ' ', 0, 0, 0, 0 ) + IF( N.EQ.1 ) THEN + IF( ICOMPQ.EQ.1 ) THEN + Q( 1 ) = SIGN( ONE, D( 1 ) ) + Q( 1+SMLSIZ*N ) = ONE + ELSE IF( ICOMPQ.EQ.2 ) THEN + U( 1, 1 ) = SIGN( ONE, D( 1 ) ) + VT( 1, 1 ) = ONE + END IF + D( 1 ) = ABS( D( 1 ) ) + RETURN + END IF + NM1 = N - 1 +* +* If matrix lower bidiagonal, rotate to be upper bidiagonal +* by applying Givens rotations on the left +* + WSTART = 1 + QSTART = 3 + IF( ICOMPQ.EQ.1 ) THEN + CALL DCOPY( N, D, 1, Q( 1 ), 1 ) + CALL DCOPY( N-1, E, 1, Q( N+1 ), 1 ) + END IF + IF( IUPLO.EQ.2 ) THEN + QSTART = 5 + WSTART = 2*N - 1 + DO 10 I = 1, N - 1 + CALL DLARTG( D( I ), E( I ), CS, SN, R ) + D( I ) = R + E( I ) = SN*D( I+1 ) + D( I+1 ) = CS*D( I+1 ) + IF( ICOMPQ.EQ.1 ) THEN + Q( I+2*N ) = CS + Q( I+3*N ) = SN + ELSE IF( ICOMPQ.EQ.2 ) THEN + WORK( I ) = CS + WORK( NM1+I ) = -SN + END IF + 10 CONTINUE + END IF +* +* If ICOMPQ = 0, use DLASDQ to compute the singular values. +* + IF( ICOMPQ.EQ.0 ) THEN + CALL DLASDQ( 'U', 0, N, 0, 0, 0, D, E, VT, LDVT, U, LDU, U, + $ LDU, WORK( WSTART ), INFO ) + GO TO 40 + END IF +* +* If N is smaller than the minimum divide size SMLSIZ, then solve +* the problem with another solver. +* + IF( N.LE.SMLSIZ ) THEN + IF( ICOMPQ.EQ.2 ) THEN + CALL DLASET( 'A', N, N, ZERO, ONE, U, LDU ) + CALL DLASET( 'A', N, N, ZERO, ONE, VT, LDVT ) + CALL DLASDQ( 'U', 0, N, N, N, 0, D, E, VT, LDVT, U, LDU, U, + $ LDU, WORK( WSTART ), INFO ) + ELSE IF( ICOMPQ.EQ.1 ) THEN + IU = 1 + IVT = IU + N + CALL DLASET( 'A', N, N, ZERO, ONE, Q( IU+( QSTART-1 )*N ), + $ N ) + CALL DLASET( 'A', N, N, ZERO, ONE, Q( IVT+( QSTART-1 )*N ), + $ N ) + CALL DLASDQ( 'U', 0, N, N, N, 0, D, E, + $ Q( IVT+( QSTART-1 )*N ), N, + $ Q( IU+( QSTART-1 )*N ), N, + $ Q( IU+( QSTART-1 )*N ), N, WORK( WSTART ), + $ INFO ) + END IF + GO TO 40 + END IF +* + IF( ICOMPQ.EQ.2 ) THEN + CALL DLASET( 'A', N, N, ZERO, ONE, U, LDU ) + CALL DLASET( 'A', N, N, ZERO, ONE, VT, LDVT ) + END IF +* +* Scale. +* + ORGNRM = DLANST( 'M', N, D, E ) + IF( ORGNRM.EQ.ZERO ) + $ RETURN + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, IERR ) + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, IERR ) +* + EPS = DLAMCH( 'Epsilon' ) +* + MLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1 + SMLSZP = SMLSIZ + 1 +* + IF( ICOMPQ.EQ.1 ) THEN + IU = 1 + IVT = 1 + SMLSIZ + DIFL = IVT + SMLSZP + DIFR = DIFL + MLVL + Z = DIFR + MLVL*2 + IC = Z + MLVL + IS = IC + 1 + POLES = IS + 1 + GIVNUM = POLES + 2*MLVL +* + K = 1 + GIVPTR = 2 + PERM = 3 + GIVCOL = PERM + MLVL + END IF +* + DO 20 I = 1, N + IF( ABS( D( I ) ).LT.EPS ) THEN + D( I ) = SIGN( EPS, D( I ) ) + END IF + 20 CONTINUE +* + START = 1 + SQRE = 0 +* + DO 30 I = 1, NM1 + IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN +* +* Subproblem found. First determine its size and then +* apply divide and conquer on it. +* + IF( I.LT.NM1 ) THEN +* +* A subproblem with E(I) small for I < NM1. +* + NSIZE = I - START + 1 + ELSE IF( ABS( E( I ) ).GE.EPS ) THEN +* +* A subproblem with E(NM1) not too small but I = NM1. +* + NSIZE = N - START + 1 + ELSE +* +* A subproblem with E(NM1) small. This implies an +* 1-by-1 subproblem at D(N). Solve this 1-by-1 problem +* first. +* + NSIZE = I - START + 1 + IF( ICOMPQ.EQ.2 ) THEN + U( N, N ) = SIGN( ONE, D( N ) ) + VT( N, N ) = ONE + ELSE IF( ICOMPQ.EQ.1 ) THEN + Q( N+( QSTART-1 )*N ) = SIGN( ONE, D( N ) ) + Q( N+( SMLSIZ+QSTART-1 )*N ) = ONE + END IF + D( N ) = ABS( D( N ) ) + END IF + IF( ICOMPQ.EQ.2 ) THEN + CALL DLASD0( NSIZE, SQRE, D( START ), E( START ), + $ U( START, START ), LDU, VT( START, START ), + $ LDVT, SMLSIZ, IWORK, WORK( WSTART ), INFO ) + ELSE + CALL DLASDA( ICOMPQ, SMLSIZ, NSIZE, SQRE, D( START ), + $ E( START ), Q( START+( IU+QSTART-2 )*N ), N, + $ Q( START+( IVT+QSTART-2 )*N ), + $ IQ( START+K*N ), Q( START+( DIFL+QSTART-2 )* + $ N ), Q( START+( DIFR+QSTART-2 )*N ), + $ Q( START+( Z+QSTART-2 )*N ), + $ Q( START+( POLES+QSTART-2 )*N ), + $ IQ( START+GIVPTR*N ), IQ( START+GIVCOL*N ), + $ N, IQ( START+PERM*N ), + $ Q( START+( GIVNUM+QSTART-2 )*N ), + $ Q( START+( IC+QSTART-2 )*N ), + $ Q( START+( IS+QSTART-2 )*N ), + $ WORK( WSTART ), IWORK, INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + END IF + START = I + 1 + END IF + 30 CONTINUE +* +* Unscale +* + CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, IERR ) + 40 CONTINUE +* +* Use Selection Sort to minimize swaps of singular vectors +* + DO 60 II = 2, N + I = II - 1 + KK = I + P = D( I ) + DO 50 J = II, N + IF( D( J ).GT.P ) THEN + KK = J + P = D( J ) + END IF + 50 CONTINUE + IF( KK.NE.I ) THEN + D( KK ) = D( I ) + D( I ) = P + IF( ICOMPQ.EQ.1 ) THEN + IQ( I ) = KK + ELSE IF( ICOMPQ.EQ.2 ) THEN + CALL DSWAP( N, U( 1, I ), 1, U( 1, KK ), 1 ) + CALL DSWAP( N, VT( I, 1 ), LDVT, VT( KK, 1 ), LDVT ) + END IF + ELSE IF( ICOMPQ.EQ.1 ) THEN + IQ( I ) = I + END IF + 60 CONTINUE +* +* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO +* + IF( ICOMPQ.EQ.1 ) THEN + IF( IUPLO.EQ.1 ) THEN + IQ( N ) = 1 + ELSE + IQ( N ) = 0 + END IF + END IF +* +* If B is lower bidiagonal, update U by those Givens rotations +* which rotated B to be upper bidiagonal +* + IF( ( IUPLO.EQ.2 ) .AND. ( ICOMPQ.EQ.2 ) ) + $ CALL DLASR( 'L', 'V', 'B', N, N, WORK( 1 ), WORK( N ), U, LDU ) +* + RETURN +* +* End of DBDSDC +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dbdsdc} (let* ((zero 0.0) (one 1.0) (two 2.0)) (declare (type (double-float 0.0 0.0) zero) @@ -30023,6 +41224,629 @@ PARAMETERS \end{chunk} +\begin{verbatim} + SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, + $ LDU, C, LDC, WORK, INFO ) +* +* -- LAPACK routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1999 +* +* .. 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, SMINLO, 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 ) + RETURN + 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 + SMINLO = SMINL + 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 + SMINLO = SMINL + 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 + +\end{verbatim} + \begin{chunk}{LAPACK dbdsqr} (let* ((zero 0.0) (one 1.0) @@ -31244,6 +43068,138 @@ ARGUMENTS \end{chunk} +\begin{verbatim} + SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO ) +* +* -- LAPACK routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* September 30, 1994 +* +* .. Scalar Arguments .. + CHARACTER JOB + INTEGER INFO, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), SEP( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL DECR, EIGEN, INCR, LEFT, RIGHT, SING + INTEGER I, K + DOUBLE PRECISION ANORM, EPS, NEWGAP, OLDGAP, SAFMIN, THRESH +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + EIGEN = LSAME( JOB, 'E' ) + LEFT = LSAME( JOB, 'L' ) + RIGHT = LSAME( JOB, 'R' ) + SING = LEFT .OR. RIGHT + IF( EIGEN ) THEN + K = M + ELSE IF( SING ) THEN + K = MIN( M, N ) + END IF + IF( .NOT.EIGEN .AND. .NOT.SING ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( K.LT.0 ) THEN + INFO = -3 + ELSE + INCR = .TRUE. + DECR = .TRUE. + DO 10 I = 1, K - 1 + IF( INCR ) + $ INCR = INCR .AND. D( I ).LE.D( I+1 ) + IF( DECR ) + $ DECR = DECR .AND. D( I ).GE.D( I+1 ) + 10 CONTINUE + IF( SING .AND. K.GT.0 ) THEN + IF( INCR ) + $ INCR = INCR .AND. ZERO.LE.D( 1 ) + IF( DECR ) + $ DECR = DECR .AND. D( K ).GE.ZERO + END IF + IF( .NOT.( INCR .OR. DECR ) ) + $ INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DDISNA', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( K.EQ.0 ) + $ RETURN +* +* Compute reciprocal condition numbers +* + IF( K.EQ.1 ) THEN + SEP( 1 ) = DLAMCH( 'O' ) + ELSE + OLDGAP = ABS( D( 2 )-D( 1 ) ) + SEP( 1 ) = OLDGAP + DO 20 I = 2, K - 1 + NEWGAP = ABS( D( I+1 )-D( I ) ) + SEP( I ) = MIN( OLDGAP, NEWGAP ) + OLDGAP = NEWGAP + 20 CONTINUE + SEP( K ) = OLDGAP + END IF + IF( SING ) THEN + IF( ( LEFT .AND. M.GT.N ) .OR. ( RIGHT .AND. M.LT.N ) ) THEN + IF( INCR ) + $ SEP( 1 ) = MIN( SEP( 1 ), D( 1 ) ) + IF( DECR ) + $ SEP( K ) = MIN( SEP( K ), D( K ) ) + END IF + END IF +* +* Ensure that reciprocal condition numbers are not less than +* threshold, in order to limit the size of the error bound +* + EPS = DLAMCH( 'E' ) + SAFMIN = DLAMCH( 'S' ) + ANORM = MAX( ABS( D( 1 ) ), ABS( D( K ) ) ) + IF( ANORM.EQ.ZERO ) THEN + THRESH = EPS + ELSE + THRESH = MAX( EPS*ANORM, SAFMIN ) + END IF + DO 30 I = 1, K + SEP( I ) = MAX( SEP( I ), THRESH ) + 30 CONTINUE +* + RETURN +* +* End of DDISNA +* + END + +\end{verbatim} + \begin{chunk}{LAPACK ddisna} (let* ((zero 0.0)) (declare (type (double-float 0.0 0.0) zero)) @@ -31481,6 +43437,149 @@ ARGUMENTS \end{chunk} +\begin{verbatim} + SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, + $ INFO ) +* +* -- LAPACK routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* September 30, 1994 +* +* .. 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 + +\end{verbatim} + \begin{chunk}{LAPACK dgebak} (let* ((one 1.0)) (declare (type (double-float 1.0 1.0) one)) @@ -31718,8 +43817,253 @@ FURTHER DETAILS This subroutine is based on the EISPACK routine BALANC. + Modified by Tzu-Yi Chen, Computer Science Division, University of + California at Berkeley, USA + \end{chunk} +\begin{verbatim} + SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) +* +* -- LAPACK 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 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 = 0.8D+1 ) + 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 LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL 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 + 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 + +\end{verbatim} + \begin{chunk}{LAPACK dgebal} (let* ((zero 0.0) (one 1.0) (sclfac 8.0) (factor 0.95)) (declare (type (double-float 0.0 0.0) zero) @@ -32081,6 +44425,139 @@ FURTHER DETAILS \end{chunk} +\begin{verbatim} + SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) +* +* -- LAPACK routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* February 29, 1992 +* +* .. 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 +* + 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 +* + CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAUP( I ), + $ A( MIN( I+1, M ), 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 + +\end{verbatim} + \begin{chunk}{LAPACK dgebd2} (let* ((zero 0.0) (one 1.0)) (declare (type (double-float 0.0 0.0) zero) @@ -32448,6 +44925,159 @@ FURTHER DETAILS \end{chunk} +\begin{verbatim} + SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, + $ INFO ) +* +* -- LAPACK 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 .. + 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' - X*U' +* + 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 + +\end{verbatim} + \begin{chunk}{LAPACK dgebrd} (let* ((one 1.0)) (declare (type (double-float 1.0 1.0) one)) @@ -32760,6 +45390,323 @@ ARGUMENTS \end{chunk} +\begin{verbatim} + SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, + $ LDVR, WORK, LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* December 8, 1999 +* +* .. 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, + $ MAXB, 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, 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, MIN, 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.) +* + MINWRK = 1 + IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) + IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN + MINWRK = MAX( 1, 3*N ) + MAXB = MAX( ILAENV( 8, 'DHSEQR', 'EN', N, 1, N, -1 ), 2 ) + K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'EN', N, 1, + $ N, -1 ) ) ) + HSWORK = MAX( K*( K+2 ), 2*N ) + MAXWRK = MAX( MAXWRK, N+1, N+HSWORK ) + ELSE + MINWRK = MAX( 1, 4*N ) + MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* + $ ILAENV( 1, 'DORGHR', ' ', N, 1, N, -1 ) ) + MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SV', N, 1, N, -1 ), 2 ) + K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SV', N, 1, + $ N, -1 ) ) ) + HSWORK = MAX( K*( K+2 ), 2*N ) + MAXWRK = MAX( MAXWRK, N+1, N+HSWORK ) + MAXWRK = MAX( MAXWRK, 4*N ) + END IF + WORK( 1 ) = MAXWRK + END IF + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -13 + 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 + +\end{verbatim} + \begin{chunk}{LAPACK dgeev} (let* ((zero 0.0) (one 1.0)) (declare (type (double-float 0.0 0.0) zero) @@ -33502,6 +46449,378 @@ ARGUMENTS \end{chunk} +\begin{verbatim} + SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, + $ VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, + $ RCONDE, RCONDV, WORK, LWORK, IWORK, INFO ) +* +* -- LAPACK driver 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 BALANC, JOBVL, JOBVR, SENSE + INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N + DOUBLE PRECISION ABNRM +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), RCONDE( * ), RCONDV( * ), + $ SCALE( * ), 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, WNTSNB, WNTSNE, + $ WNTSNN, WNTSNV + CHARACTER JOB, SIDE + INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K, MAXB, + $ 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, DLACPY, DLARTG, + $ DLASCL, DORGHR, DROT, DSCAL, DTREVC, DTRSNA, + $ 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, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + WANTVL = LSAME( JOBVL, 'V' ) + WANTVR = LSAME( JOBVR, 'V' ) + WNTSNN = LSAME( SENSE, 'N' ) + WNTSNE = LSAME( SENSE, 'E' ) + WNTSNV = LSAME( SENSE, 'V' ) + WNTSNB = LSAME( SENSE, 'B' ) + IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, + $ 'S' ) .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) ) + $ THEN + INFO = -1 + ELSE IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT.( WNTSNN .OR. WNTSNE .OR. WNTSNB .OR. WNTSNV ) .OR. + $ ( ( WNTSNE .OR. WNTSNB ) .AND. .NOT.( WANTVL .AND. + $ WANTVR ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN + INFO = -11 + ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN + INFO = -13 + 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.) +* + MINWRK = 1 + IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + MAXWRK = N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) + IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN + MINWRK = MAX( 1, 2*N ) + IF( .NOT.WNTSNN ) + $ MINWRK = MAX( MINWRK, N*N+6*N ) + MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SN', N, 1, N, -1 ), 2 ) + IF( WNTSNN ) THEN + K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'EN', N, + $ 1, N, -1 ) ) ) + ELSE + K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SN', N, + $ 1, N, -1 ) ) ) + END IF + HSWORK = MAX( K*( K+2 ), 2*N ) + MAXWRK = MAX( MAXWRK, 1, HSWORK ) + IF( .NOT.WNTSNN ) + $ MAXWRK = MAX( MAXWRK, N*N+6*N ) + ELSE + MINWRK = MAX( 1, 3*N ) + IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) ) + $ MINWRK = MAX( MINWRK, N*N+6*N ) + MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SN', N, 1, N, -1 ), 2 ) + K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'EN', N, 1, + $ N, -1 ) ) ) + HSWORK = MAX( K*( K+2 ), 2*N ) + MAXWRK = MAX( MAXWRK, 1, HSWORK ) + MAXWRK = MAX( MAXWRK, N+( N-1 )* + $ ILAENV( 1, 'DORGHR', ' ', N, 1, N, -1 ) ) + IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) ) + $ MAXWRK = MAX( MAXWRK, N*N+6*N ) + MAXWRK = MAX( MAXWRK, 3*N, 1 ) + END IF + WORK( 1 ) = MAXWRK + END IF + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -21 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEEVX', -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] +* + ICOND = 0 + 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 and compute ABNRM +* + CALL DGEBAL( BALANC, N, A, LDA, ILO, IHI, SCALE, IERR ) + ABNRM = DLANGE( '1', N, N, A, LDA, DUM ) + IF( SCALEA ) THEN + DUM( 1 ) = ABNRM + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR ) + ABNRM = DUM( 1 ) + END IF +* +* Reduce to upper Hessenberg form +* (Workspace: need 2*N, prefer N+N*NB) +* + ITAU = 1 + 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 2*N-1, prefer 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 1, prefer 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 2*N-1, prefer 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 1, prefer 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 +* If condition numbers desired, compute Schur form +* + IF( WNTSNN ) THEN + JOB = 'E' + ELSE + JOB = 'S' + END IF +* +* (Workspace: need 1, prefer HSWORK (see comments) ) +* + IWRK = ITAU + CALL DHSEQR( JOB, '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 3*N) +* + CALL DTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, + $ N, NOUT, WORK( IWRK ), IERR ) + END IF +* +* Compute condition numbers if desired +* (Workspace: need N*N+6*N unless SENSE = 'E') +* + IF( .NOT.WNTSNN ) THEN + CALL DTRSNA( SENSE, 'A', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, + $ RCONDE, RCONDV, N, NOUT, WORK( IWRK ), N, IWORK, + $ ICOND ) + END IF +* + IF( WANTVL ) THEN +* +* Undo balancing of left eigenvectors +* + CALL DGEBAK( BALANC, 'L', N, ILO, IHI, SCALE, 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( K ) = VL( K, I )**2 + VL( K, I+1 )**2 + 10 CONTINUE + K = IDAMAX( N, WORK, 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 +* + CALL DGEBAK( BALANC, 'R', N, ILO, IHI, SCALE, 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( K ) = VR( K, I )**2 + VR( K, I+1 )**2 + 30 CONTINUE + K = IDAMAX( N, WORK, 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.EQ.0 ) THEN + IF( ( WNTSNV .OR. WNTSNB ) .AND. ICOND.EQ.0 ) + $ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, RCONDV, N, + $ IERR ) + ELSE + 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 DGEEVX +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dgeevx} (let* ((zero 0.0) (one 1.0)) (declare (type (double-float 0.0 0.0) zero) @@ -34229,13 +47548,13 @@ FURTHER DETAILS 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 ) + ( 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 modi- fied element of the upper Hessenberg matrix H, and vi denotes an ele- @@ -34243,6 +47562,86 @@ FURTHER DETAILS \end{chunk} +\begin{verbatim} + SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK 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 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 + +\end{verbatim} + \begin{chunk}{LAPACK dgehd2} (let* ((one 1.0)) (declare (type (double-float 1.0 1.0) one)) @@ -34430,13 +47829,13 @@ FURTHER DETAILS 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 ) + ( 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 modi- fied element of the upper Hessenberg matrix H, and vi denotes an ele- @@ -34446,6 +47845,179 @@ FURTHER DETAILS \end{chunk} +\begin{verbatim} + SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK 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 .. + 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, LDWORK, LWKOPT, NB, NBMIN, + $ NH, NX + DOUBLE PRECISION EI +* .. +* .. Local Arrays .. + DOUBLE PRECISION T( LDT, NBMAX ) +* .. +* .. External Subroutines .. + EXTERNAL DGEHD2, DGEMM, DLAHRD, DLARFB, 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 30 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' +* which performs the reduction, and also the matrix Y = A*V*T +* + CALL DLAHRD( 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'. 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(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 ) + 30 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 + +\end{verbatim} + \begin{chunk}{LAPACK dgehrd} (let* ((nbmax 64) (ldt (+ nbmax 1)) (zero 0.0) (one 1.0)) (declare (type (fixnum 64 64) nbmax) @@ -34704,6 +48276,81 @@ FURTHER DETAILS \end{chunk} +\begin{verbatim} + SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* February 29, 1992 +* +* .. 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 + +\end{verbatim} + \begin{chunk}{LAPACK dgelq2} (let* ((one 1.0)) (declare (type (double-float 1.0 1.0) one)) @@ -34867,6 +48514,144 @@ FURTHER DETAILS \end{chunk} +\begin{verbatim} + SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK 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 .. + 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 + +\end{verbatim} + \begin{chunk}{LAPACK dgelqf} (defun dgelqf (m n a lda tau work lwork info) (declare (type (simple-array double-float (*)) work tau a) @@ -35064,6 +48849,81 @@ FURTHER DETAILS \end{chunk} +\begin{verbatim} + SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* February 29, 1992 +* +* .. 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 + +\end{verbatim} + \begin{chunk}{LAPACK dgeqr2} (let* ((one 1.0)) (declare (type (double-float 1.0 1.0) one)) @@ -35225,6 +49085,144 @@ FURTHER DETAILS \end{chunk} +\begin{verbatim} + SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK 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 .. + 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' 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 + +\end{verbatim} + \begin{chunk}{LAPACK dgeqrf} (defun dgeqrf (m n a lda tau work lwork info) (declare (type (simple-array double-float (*)) work tau a) @@ -35487,8 +49485,1229 @@ ARGUMENTS < 0: if INFO = -i, the i-th argument had an illegal value. > 0: DBDSDC did not converge, updating process failed. + Further Details + =============== + + Based on contributions by + Ming Gu and Huan Ren, Computer Science Division, University of + California at Berkeley, USA + \end{chunk} +\begin{verbatim} + SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, + $ LWORK, IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1999 +* +* .. Scalar Arguments .. + CHARACTER JOBZ + INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + 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, WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS + INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IL, + $ IR, ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT, + $ LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK, + $ MNTHR, NWORK, WRKBL + DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM +* .. +* .. Local Arrays .. + INTEGER IDUM( 1 ) + DOUBLE PRECISION DUM( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DBDSDC, DGEBRD, DGELQF, DGEMM, DGEQRF, DLACPY, + $ DLASCL, DLASET, DORGBR, DORGLQ, DORGQR, DORMBR, + $ XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + MINMN = MIN( M, N ) + MNTHR = INT( MINMN*11.0D0 / 6.0D0 ) + WNTQA = LSAME( JOBZ, 'A' ) + WNTQS = LSAME( JOBZ, 'S' ) + WNTQAS = WNTQA .OR. WNTQS + WNTQO = LSAME( JOBZ, 'O' ) + WNTQN = LSAME( JOBZ, 'N' ) + MINWRK = 1 + MAXWRK = 1 + LQUERY = ( LWORK.EQ.-1 ) +* + IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) 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 = -5 + ELSE IF( LDU.LT.1 .OR. ( WNTQAS .AND. LDU.LT.M ) .OR. + $ ( WNTQO .AND. M.LT.N .AND. LDU.LT.M ) ) THEN + INFO = -8 + ELSE IF( LDVT.LT.1 .OR. ( WNTQA .AND. LDVT.LT.N ) .OR. + $ ( WNTQS .AND. LDVT.LT.MINMN ) .OR. + $ ( WNTQO .AND. M.GE.N .AND. LDVT.LT.N ) ) THEN + INFO = -10 + 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 .AND. M.GT.0 .AND. N.GT.0 ) THEN + IF( M.GE.N ) THEN +* +* Compute space needed for DBDSDC +* + IF( WNTQN ) THEN + BDSPAC = 7*N + ELSE + BDSPAC = 3*N*N + 4*N + END IF + IF( M.GE.MNTHR ) THEN + IF( WNTQN ) THEN +* +* Path 1 (M much larger than N, JOBZ='N') +* + WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, + $ -1 ) + WRKBL = MAX( WRKBL, 3*N+2*N* + $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) + MAXWRK = MAX( WRKBL, BDSPAC+N ) + MINWRK = BDSPAC + N + ELSE IF( WNTQO ) THEN +* +* Path 2 (M much larger than N, JOBZ='O') +* + WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M, + $ N, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+2*N* + $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+N* + $ ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+N* + $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC+3*N ) + MAXWRK = WRKBL + 2*N*N + MINWRK = BDSPAC + 2*N*N + 3*N + ELSE IF( WNTQS ) THEN +* +* Path 3 (M much larger than N, JOBZ='S') +* + WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M, + $ N, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+2*N* + $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+N* + $ ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+N* + $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC+3*N ) + MAXWRK = WRKBL + N*N + MINWRK = BDSPAC + N*N + 3*N + ELSE IF( WNTQA ) THEN +* +* Path 4 (M much larger than N, JOBZ='A') +* + WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M, + $ M, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+2*N* + $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+N* + $ ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+N* + $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC+3*N ) + MAXWRK = WRKBL + N*N + MINWRK = BDSPAC + N*N + 3*N + END IF + ELSE +* +* Path 5 (M at least N, but not much larger) +* + WRKBL = 3*N + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, -1, + $ -1 ) + IF( WNTQN ) THEN + MAXWRK = MAX( WRKBL, BDSPAC+3*N ) + MINWRK = 3*N + MAX( M, BDSPAC ) + ELSE IF( WNTQO ) THEN + WRKBL = MAX( WRKBL, 3*N+N* + $ ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+N* + $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC+3*N ) + MAXWRK = WRKBL + M*N + MINWRK = 3*N + MAX( M, N*N+BDSPAC ) + ELSE IF( WNTQS ) THEN + WRKBL = MAX( WRKBL, 3*N+N* + $ ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+N* + $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) ) + MAXWRK = MAX( WRKBL, BDSPAC+3*N ) + MINWRK = 3*N + MAX( M, BDSPAC ) + ELSE IF( WNTQA ) THEN + WRKBL = MAX( WRKBL, 3*N+M* + $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*N+N* + $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) ) + MAXWRK = MAX( MAXWRK, BDSPAC+3*N ) + MINWRK = 3*N + MAX( M, BDSPAC ) + END IF + END IF + ELSE +* +* Compute space needed for DBDSDC +* + IF( WNTQN ) THEN + BDSPAC = 7*M + ELSE + BDSPAC = 3*M*M + 4*M + END IF + IF( N.GE.MNTHR ) THEN + IF( WNTQN ) THEN +* +* Path 1t (N much larger than M, JOBZ='N') +* + WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, + $ -1 ) + WRKBL = MAX( WRKBL, 3*M+2*M* + $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) + MAXWRK = MAX( WRKBL, BDSPAC+M ) + MINWRK = BDSPAC + M + ELSE IF( WNTQO ) THEN +* +* Path 2t (N much larger than M, JOBZ='O') +* + WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M, + $ N, M, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+2*M* + $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+M* + $ ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+M* + $ ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC+3*M ) + MAXWRK = WRKBL + 2*M*M + MINWRK = BDSPAC + 2*M*M + 3*M + ELSE IF( WNTQS ) THEN +* +* Path 3t (N much larger than M, JOBZ='S') +* + WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M, + $ N, M, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+2*M* + $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+M* + $ ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+M* + $ ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC+3*M ) + MAXWRK = WRKBL + M*M + MINWRK = BDSPAC + M*M + 3*M + ELSE IF( WNTQA ) THEN +* +* Path 4t (N much larger than M, JOBZ='A') +* + WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) + WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N, + $ N, M, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+2*M* + $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+M* + $ ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+M* + $ ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC+3*M ) + MAXWRK = WRKBL + M*M + MINWRK = BDSPAC + M*M + 3*M + END IF + ELSE +* +* Path 5t (N greater than M, but not much larger) +* + WRKBL = 3*M + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, -1, + $ -1 ) + IF( WNTQN ) THEN + MAXWRK = MAX( WRKBL, BDSPAC+3*M ) + MINWRK = 3*M + MAX( N, BDSPAC ) + ELSE IF( WNTQO ) THEN + WRKBL = MAX( WRKBL, 3*M+M* + $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+M* + $ ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 ) ) + WRKBL = MAX( WRKBL, BDSPAC+3*M ) + MAXWRK = WRKBL + M*N + MINWRK = 3*M + MAX( N, M*M+BDSPAC ) + ELSE IF( WNTQS ) THEN + WRKBL = MAX( WRKBL, 3*M+M* + $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+M* + $ ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 ) ) + MAXWRK = MAX( WRKBL, BDSPAC+3*M ) + MINWRK = 3*M + MAX( N, BDSPAC ) + ELSE IF( WNTQA ) THEN + WRKBL = MAX( WRKBL, 3*M+M* + $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) ) + WRKBL = MAX( WRKBL, 3*M+M* + $ ILAENV( 1, 'DORMBR', 'PRT', N, N, M, -1 ) ) + MAXWRK = MAX( WRKBL, BDSPAC+3*M ) + MINWRK = 3*M + MAX( N, BDSPAC ) + END IF + END IF + END IF + WORK( 1 ) = MAXWRK + END IF +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGESDD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + IF( LWORK.GE.1 ) + $ WORK( 1 ) = ONE + 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( WNTQN ) THEN +* +* Path 1 (M much larger than N, JOBZ='N') +* No singular vectors to be computed +* + ITAU = 1 + NWORK = ITAU + N +* +* Compute A=Q*R +* (Workspace: need 2*N, prefer N+N*NB) +* + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), + $ LWORK-NWORK+1, 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 + NWORK = 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( NWORK ), LWORK-NWORK+1, + $ IERR ) + NWORK = IE + N +* +* Perform bidiagonal SVD, computing singular values only +* (Workspace: need N+BDSPAC) +* + CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1, + $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) +* + ELSE IF( WNTQO ) THEN +* +* Path 2 (M much larger than N, JOBZ = 'O') +* N left singular vectors to be overwritten on A and +* N right singular vectors to be computed in VT +* + IR = 1 +* +* WORK(IR) is LDWRKR by N +* + IF( LWORK.GE.LDA*N+N*N+3*N+BDSPAC ) THEN + LDWRKR = LDA + ELSE + LDWRKR = ( LWORK-N*N-3*N-BDSPAC ) / N + END IF + ITAU = IR + LDWRKR*N + NWORK = 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( NWORK ), + $ LWORK-NWORK+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( NWORK ), LWORK-NWORK+1, IERR ) + IE = ITAU + ITAUQ = IE + N + ITAUP = ITAUQ + N + NWORK = 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, WORK( IR ), LDWRKR, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) +* +* WORK(IU) is N by N +* + IU = NWORK + NWORK = IU + N*N +* +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in WORK(IU) and computing right +* singular vectors of bidiagonal matrix in VT +* (Workspace: need N+N*N+BDSPAC) +* + CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N, + $ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK, + $ INFO ) +* +* Overwrite WORK(IU) by left singular vectors of R +* and VT by right singular vectors of R +* (Workspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB) +* + CALL DORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR, + $ WORK( ITAUQ ), WORK( IU ), N, WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) + CALL DORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR, + $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) +* +* Multiply Q in A by left singular vectors of R in +* WORK(IU), storing result in WORK(IR) and copying to A +* (Workspace: need 2*N*N, prefer N*N+M*N) +* + DO 10 I = 1, M, LDWRKR + CHUNK = MIN( M-I+1, LDWRKR ) + CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), + $ LDA, WORK( IU ), N, ZERO, WORK( IR ), + $ LDWRKR ) + CALL DLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR, + $ A( I, 1 ), LDA ) + 10 CONTINUE +* + ELSE IF( WNTQS ) THEN +* +* Path 3 (M much larger than N, JOBZ='S') +* N left singular vectors to be computed in U and +* N right singular vectors to be computed in VT +* + IR = 1 +* +* WORK(IR) is N by N +* + LDWRKR = N + ITAU = IR + LDWRKR*N + NWORK = 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( NWORK ), + $ LWORK-NWORK+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( NWORK ), LWORK-NWORK+1, IERR ) + IE = ITAU + ITAUQ = IE + N + ITAUP = ITAUQ + N + NWORK = 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( NWORK ), + $ LWORK-NWORK+1, IERR ) +* +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagoal matrix in U and computing right singular +* vectors of bidiagonal matrix in VT +* (Workspace: need N+BDSPAC) +* + CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, + $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, + $ INFO ) +* +* Overwrite U by left singular vectors of R and VT +* by right singular vectors of R +* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB) +* + CALL DORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR, + $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) +* + CALL DORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR, + $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) +* +* Multiply Q in A by left singular vectors of R in +* WORK(IR), storing result in U +* (Workspace: need N*N) +* + CALL DLACPY( 'F', N, N, U, LDU, WORK( IR ), LDWRKR ) + CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, WORK( IR ), + $ LDWRKR, ZERO, U, LDU ) +* + ELSE IF( WNTQA ) THEN +* +* Path 4 (M much larger than N, JOBZ='A') +* M left singular vectors to be computed in U and +* N right singular vectors to be computed in VT +* + IU = 1 +* +* WORK(IU) is N by N +* + LDWRKU = N + ITAU = IU + LDWRKU*N + NWORK = 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( NWORK ), + $ LWORK-NWORK+1, IERR ) + CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) +* +* Generate Q in U +* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) + CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), + $ WORK( NWORK ), LWORK-NWORK+1, IERR ) +* +* Produce R in A, zeroing out other entries +* + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA ) + IE = ITAU + ITAUQ = IE + N + ITAUP = ITAUQ + N + NWORK = ITAUP + N +* +* Bidiagonalize R in A +* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) +* + CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, + $ IERR ) +* +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in WORK(IU) and computing right +* singular vectors of bidiagonal matrix in VT +* (Workspace: need N+N*N+BDSPAC) +* + CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N, + $ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK, + $ INFO ) +* +* Overwrite WORK(IU) by left singular vectors of R and VT +* by right singular vectors of R +* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB) +* + CALL DORMBR( 'Q', 'L', 'N', N, N, N, A, LDA, + $ WORK( ITAUQ ), WORK( IU ), LDWRKU, + $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA, + $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) +* +* 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 ) +* + END IF +* + ELSE +* +* M .LT. MNTHR +* +* Path 5 (M at least N, but not much larger) +* Reduce to bidiagonal form without QR decomposition +* + IE = 1 + ITAUQ = IE + N + ITAUP = ITAUQ + N + NWORK = 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( NWORK ), LWORK-NWORK+1, + $ IERR ) + IF( WNTQN ) THEN +* +* Perform bidiagonal SVD, only computing singular values +* (Workspace: need N+BDSPAC) +* + CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1, + $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) + ELSE IF( WNTQO ) THEN + IU = NWORK + IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN +* +* WORK( IU ) is M by N +* + LDWRKU = M + NWORK = IU + LDWRKU*N + CALL DLASET( 'F', M, N, ZERO, ZERO, WORK( IU ), + $ LDWRKU ) + ELSE +* +* WORK( IU ) is N by N +* + LDWRKU = N + NWORK = IU + LDWRKU*N +* +* WORK(IR) is LDWRKR by N +* + IR = NWORK + LDWRKR = ( LWORK-N*N-3*N ) / N + END IF + NWORK = IU + LDWRKU*N +* +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in WORK(IU) and computing right +* singular vectors of bidiagonal matrix in VT +* (Workspace: need N+N*N+BDSPAC) +* + CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), + $ LDWRKU, VT, LDVT, DUM, IDUM, WORK( NWORK ), + $ IWORK, INFO ) +* +* Overwrite VT by right singular vectors of A +* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* + CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA, + $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) +* + IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN +* +* Overwrite WORK(IU) by left singular vectors of A +* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* + CALL DORMBR( 'Q', 'L', 'N', M, N, N, A, LDA, + $ WORK( ITAUQ ), WORK( IU ), LDWRKU, + $ WORK( NWORK ), LWORK-NWORK+1, IERR ) +* +* Copy left singular vectors of A from WORK(IU) to A +* + CALL DLACPY( 'F', M, N, WORK( IU ), LDWRKU, A, LDA ) + ELSE +* +* Generate Q in A +* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* + CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), + $ WORK( NWORK ), LWORK-NWORK+1, IERR ) +* +* Multiply Q in A by left singular vectors of +* bidiagonal matrix in WORK(IU), storing result in +* WORK(IR) and copying to A +* (Workspace: need 2*N*N, prefer N*N+M*N) +* + DO 20 I = 1, M, LDWRKR + CHUNK = MIN( M-I+1, LDWRKR ) + CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), + $ LDA, WORK( IU ), LDWRKU, ZERO, + $ WORK( IR ), LDWRKR ) + CALL DLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR, + $ A( I, 1 ), LDA ) + 20 CONTINUE + END IF +* + ELSE IF( WNTQS ) THEN +* +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in U and computing right singular +* vectors of bidiagonal matrix in VT +* (Workspace: need N+BDSPAC) +* + CALL DLASET( 'F', M, N, ZERO, ZERO, U, LDU ) + CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, + $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, + $ INFO ) +* +* Overwrite U by left singular vectors of A and VT +* by right singular vectors of A +* (Workspace: need 3*N, prefer 2*N+N*NB) +* + CALL DORMBR( 'Q', 'L', 'N', M, N, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) + CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA, + $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) + ELSE IF( WNTQA ) THEN +* +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in U and computing right singular +* vectors of bidiagonal matrix in VT +* (Workspace: need N+BDSPAC) +* + CALL DLASET( 'F', M, M, ZERO, ZERO, U, LDU ) + CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, + $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, + $ INFO ) +* +* Set the right corner of U to identity matrix +* + CALL DLASET( 'F', M-N, M-N, ZERO, ONE, U( N+1, N+1 ), + $ LDU ) +* +* Overwrite U by left singular vectors of A and VT +* by right singular vectors of A +* (Workspace: need N*N+2*N+M, prefer N*N+2*N+M*NB) +* + CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) + CALL DORMBR( 'P', 'R', 'T', N, N, M, A, LDA, + $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) + 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( WNTQN ) THEN +* +* Path 1t (N much larger than M, JOBZ='N') +* No singular vectors to be computed +* + ITAU = 1 + NWORK = ITAU + M +* +* Compute A=L*Q +* (Workspace: need 2*M, prefer M+M*NB) +* + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), + $ LWORK-NWORK+1, 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 + NWORK = 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( NWORK ), LWORK-NWORK+1, + $ IERR ) + NWORK = IE + M +* +* Perform bidiagonal SVD, computing singular values only +* (Workspace: need M+BDSPAC) +* + CALL DBDSDC( 'U', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1, + $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) +* + ELSE IF( WNTQO ) THEN +* +* Path 2t (N much larger than M, JOBZ='O') +* M right singular vectors to be overwritten on A and +* M left singular vectors to be computed in U +* + IVT = 1 +* +* IVT is M by M +* + IL = IVT + M*M + IF( LWORK.GE.M*N+M*M+3*M+BDSPAC ) THEN +* +* WORK(IL) is M by N +* + LDWRKL = M + CHUNK = N + ELSE + LDWRKL = M + CHUNK = ( LWORK-M*M ) / M + END IF + ITAU = IL + LDWRKL*M + NWORK = 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( NWORK ), + $ LWORK-NWORK+1, IERR ) +* +* Copy L to WORK(IL), zeroing about above it +* + CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL ) + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, + $ WORK( IL+LDWRKL ), LDWRKL ) +* +* 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( NWORK ), LWORK-NWORK+1, IERR ) + IE = ITAU + ITAUQ = IE + M + ITAUP = ITAUQ + M + NWORK = ITAUP + M +* +* Bidiagonalize L in WORK(IL) +* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) +* + CALL DGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) +* +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in U, and computing right singular +* vectors of bidiagonal matrix in WORK(IVT) +* (Workspace: need M+M*M+BDSPAC) +* + CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, + $ WORK( IVT ), M, DUM, IDUM, WORK( NWORK ), + $ IWORK, INFO ) +* +* Overwrite U by left singular vectors of L and WORK(IVT) +* by right singular vectors of L +* (Workspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB) +* + CALL DORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL, + $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) + CALL DORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL, + $ WORK( ITAUP ), WORK( IVT ), M, + $ WORK( NWORK ), LWORK-NWORK+1, IERR ) +* +* Multiply right singular vectors of L in WORK(IVT) by Q +* in A, storing result in WORK(IL) and copying to A +* (Workspace: need 2*M*M, prefer M*M+M*N) +* + DO 30 I = 1, N, CHUNK + BLK = MIN( N-I+1, CHUNK ) + CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ), M, + $ A( 1, I ), LDA, ZERO, WORK( IL ), LDWRKL ) + CALL DLACPY( 'F', M, BLK, WORK( IL ), LDWRKL, + $ A( 1, I ), LDA ) + 30 CONTINUE +* + ELSE IF( WNTQS ) THEN +* +* Path 3t (N much larger than M, JOBZ='S') +* M right singular vectors to be computed in VT and +* M left singular vectors to be computed in U +* + IL = 1 +* +* WORK(IL) is M by M +* + LDWRKL = M + ITAU = IL + LDWRKL*M + NWORK = 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( NWORK ), + $ LWORK-NWORK+1, IERR ) +* +* Copy L to WORK(IL), zeroing out above it +* + CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL ) + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, + $ WORK( IL+LDWRKL ), LDWRKL ) +* +* 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( NWORK ), LWORK-NWORK+1, IERR ) + IE = ITAU + ITAUQ = IE + M + ITAUP = ITAUQ + M + NWORK = 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( IL ), LDWRKL, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) +* +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in U and computing right singular +* vectors of bidiagonal matrix in VT +* (Workspace: need M+BDSPAC) +* + CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, VT, + $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, + $ INFO ) +* +* Overwrite U by left singular vectors of L and VT +* by right singular vectors of L +* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB) +* + CALL DORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL, + $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) + CALL DORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL, + $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) +* +* Multiply right singular vectors of L in WORK(IL) by +* Q in A, storing result in VT +* (Workspace: need M*M) +* + CALL DLACPY( 'F', M, M, VT, LDVT, WORK( IL ), LDWRKL ) + CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IL ), LDWRKL, + $ A, LDA, ZERO, VT, LDVT ) +* + ELSE IF( WNTQA ) THEN +* +* Path 4t (N much larger than M, JOBZ='A') +* N right singular vectors to be computed in VT and +* M left singular vectors to be computed in U +* + IVT = 1 +* +* WORK(IVT) is M by M +* + LDWKVT = M + ITAU = IVT + LDWKVT*M + NWORK = 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( NWORK ), + $ LWORK-NWORK+1, IERR ) + CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) +* +* Generate Q in VT +* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* + CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), + $ WORK( NWORK ), LWORK-NWORK+1, IERR ) +* +* Produce L in A, zeroing out other entries +* + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA ) + IE = ITAU + ITAUQ = IE + M + ITAUP = ITAUQ + M + NWORK = ITAUP + M +* +* Bidiagonalize L in A +* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) +* + CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, + $ IERR ) +* +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in U and computing right singular +* vectors of bidiagonal matrix in WORK(IVT) +* (Workspace: need M+M*M+BDSPAC) +* + CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, + $ WORK( IVT ), LDWKVT, DUM, IDUM, + $ WORK( NWORK ), IWORK, INFO ) +* +* Overwrite U by left singular vectors of L and WORK(IVT) +* by right singular vectors of L +* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB) +* + CALL DORMBR( 'Q', 'L', 'N', M, M, M, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) + CALL DORMBR( 'P', 'R', 'T', M, M, M, A, LDA, + $ WORK( ITAUP ), WORK( IVT ), LDWKVT, + $ WORK( NWORK ), LWORK-NWORK+1, IERR ) +* +* Multiply right singular vectors of L in WORK(IVT) by +* Q in VT, storing result in A +* (Workspace: need M*M) +* + CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IVT ), LDWKVT, + $ VT, LDVT, ZERO, A, LDA ) +* +* Copy right singular vectors of A from A to VT +* + CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT ) +* + END IF +* + ELSE +* +* N .LT. MNTHR +* +* Path 5t (N greater than M, but not much larger) +* Reduce to bidiagonal form without LQ decomposition +* + IE = 1 + ITAUQ = IE + M + ITAUP = ITAUQ + M + NWORK = ITAUP + M +* +* Bidiagonalize A +* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) +* + CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, + $ IERR ) + IF( WNTQN ) THEN +* +* Perform bidiagonal SVD, only computing singular values +* (Workspace: need M+BDSPAC) +* + CALL DBDSDC( 'L', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1, + $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) + ELSE IF( WNTQO ) THEN + LDWKVT = M + IVT = NWORK + IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN +* +* WORK( IVT ) is M by N +* + CALL DLASET( 'F', M, N, ZERO, ZERO, WORK( IVT ), + $ LDWKVT ) + NWORK = IVT + LDWKVT*N + ELSE +* +* WORK( IVT ) is M by M +* + NWORK = IVT + LDWKVT*M + IL = NWORK +* +* WORK(IL) is M by CHUNK +* + CHUNK = ( LWORK-M*M-3*M ) / M + END IF +* +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in U and computing right singular +* vectors of bidiagonal matrix in WORK(IVT) +* (Workspace: need M*M+BDSPAC) +* + CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, + $ WORK( IVT ), LDWKVT, DUM, IDUM, + $ WORK( NWORK ), IWORK, INFO ) +* +* Overwrite U by left singular vectors of A +* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* + CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) +* + IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN +* +* Overwrite WORK(IVT) by left singular vectors of A +* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* + CALL DORMBR( 'P', 'R', 'T', M, N, M, A, LDA, + $ WORK( ITAUP ), WORK( IVT ), LDWKVT, + $ WORK( NWORK ), LWORK-NWORK+1, IERR ) +* +* Copy right singular vectors of A from WORK(IVT) to A +* + CALL DLACPY( 'F', M, N, WORK( IVT ), LDWKVT, A, LDA ) + ELSE +* +* Generate P**T in A +* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* + CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), + $ WORK( NWORK ), LWORK-NWORK+1, IERR ) +* +* Multiply Q in A by right singular vectors of +* bidiagonal matrix in WORK(IVT), storing result in +* WORK(IL) and copying to A +* (Workspace: need 2*M*M, prefer M*M+M*N) +* + DO 40 I = 1, N, CHUNK + BLK = MIN( N-I+1, CHUNK ) + CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ), + $ LDWKVT, A( 1, I ), LDA, ZERO, + $ WORK( IL ), M ) + CALL DLACPY( 'F', M, BLK, WORK( IL ), M, A( 1, I ), + $ LDA ) + 40 CONTINUE + END IF + ELSE IF( WNTQS ) THEN +* +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in U and computing right singular +* vectors of bidiagonal matrix in VT +* (Workspace: need M+BDSPAC) +* + CALL DLASET( 'F', M, N, ZERO, ZERO, VT, LDVT ) + CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT, + $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, + $ INFO ) +* +* Overwrite U by left singular vectors of A and VT +* by right singular vectors of A +* (Workspace: need 3*M, prefer 2*M+M*NB) +* + CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) + CALL DORMBR( 'P', 'R', 'T', M, N, M, A, LDA, + $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) + ELSE IF( WNTQA ) THEN +* +* Perform bidiagonal SVD, computing left singular vectors +* of bidiagonal matrix in U and computing right singular +* vectors of bidiagonal matrix in VT +* (Workspace: need M+BDSPAC) +* + CALL DLASET( 'F', N, N, ZERO, ZERO, VT, LDVT ) + CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT, + $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, + $ INFO ) +* +* Set the right corner of VT to identity matrix +* + CALL DLASET( 'F', N-M, N-M, ZERO, ONE, VT( M+1, M+1 ), + $ LDVT ) +* +* Overwrite U by left singular vectors of A and VT +* by right singular vectors of A +* (Workspace: need 2*M+N, prefer 2*M+N*NB) +* + CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) + CALL DORMBR( 'P', 'R', 'T', N, N, M, A, LDA, + $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), + $ LWORK-NWORK+1, IERR ) + END IF +* + 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( ANRM.LT.SMLNUM ) + $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, + $ IERR ) + END IF +* +* Return optimal workspace in WORK(1) +* + WORK( 1 ) = DBLE( MAXWRK ) +* + RETURN +* +* End of DGESDD +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dgesdd} (let* ((zero 0.0) (one 1.0)) (declare (type (double-float 0.0 0.0) zero) @@ -44126,6 +59345,67 @@ ARGUMENTS \end{chunk} +\begin{verbatim} + SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* -- LAPACK driver routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* March 31, 1993 +* +* .. 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 + +\end{verbatim} + \begin{chunk}{LAPACK dgesv} (defun dgesv (n nrhs a lda ipiv b ldb$ info) (declare (type (simple-array fixnum (*)) ipiv) @@ -44249,6 +59529,102 @@ ARGUMENTS \end{chunk} +\begin{verbatim} + SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* June 30, 1992 +* +* .. 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 .. + INTEGER J, JP +* .. +* .. External Functions .. + INTEGER IDAMAX + EXTERNAL 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 +* + 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 ) + $ CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) +* + 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 + +\end{verbatim} + \begin{chunk}{LAPACK dgetf2} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -44422,6 +59798,127 @@ ARGUMENTS \end{chunk} +\begin{verbatim} + SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* March 31, 1993 +* +* .. 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 + +\end{verbatim} + \begin{chunk}{LAPACK dgetrf} (let* ((one 1.0)) (declare (type (double-float 1.0 1.0) one)) @@ -44628,6 +60125,114 @@ ARGUMENTS \end{chunk} +\begin{verbatim} + SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* -- LAPACK routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* March 31, 1993 +* +* .. 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' * X = B. +* +* Solve U'*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, + $ ONE, A, LDA, B, LDB ) +* +* Solve L'*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 + +\end{verbatim} + \begin{chunk}{LAPACK dgetrs} (let* ((one 1.0)) (declare (type (double-float 1.0 1.0) one)) @@ -44709,6 +60314,11 @@ NAME 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. + SYNOPSIS SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO ) @@ -44733,120 +60343,462 @@ PURPOSE ARGUMENTS - JOB (input) CHARACTER*1 - = 'E': compute eigenvalues only; - = 'S': compute eigenvalues and the Schur form T. - - COMPZ (input) 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 orthog- - onal matrix Q on entry, and the product Q*Z is returned. - - N (input) INTEGER - The order of the matrix H. N .GE. 0. - - ILO (input) INTEGER - IHI (input) INTEGER It is assumed that H is already upper tri- - angular 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 - DGEHRD when the matrix output by DGEBAL is reduced to Hessenberg - form. Otherwise ILO and IHI should be set to 1 and N respec- - tively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. If N = 0, then - ILO = 1 and IHI = 0. - - H (input/output) 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. - - LDH (input) INTEGER - The leading dimension of the array H. LDH .GE. max(1,N). - - WR (output) DOUBLE PRECISION array, dimension (N) - WI (output) 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). - - Z (input/output) 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 orthogo- - nal 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 orthogo- - nal 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.) - - LDZ (input) INTEGER - The leading dimension of the array Z. if COMPZ = 'I' or COMPZ = - 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. - - WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) - On exit, if INFO = 0, WORK(1) returns an estimate of the optimal - value for LWORK. - - LWORK (input) 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 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 esti- - mate is returned in WORK(1). No error message related to LWORK - is issued by XERBLA. Neither H nor Z are accessed. - - INFO (output) INTEGER - = 0: successful exit - value - the eigenvalues. Elements 1:ilo-1 and i+1:n of WR and WI contain - those eigenvalues which have been successfully computed. (Fail- - ures are rare.) - - If INFO .GT. 0 and JOB = 'E', then on exit, the remaining uncon- - verged 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.) + JOB (input) CHARACTER*1 + = 'E': compute eigenvalues only; + = 'S': compute eigenvalues and the Schur form T. + + COMPZ (input) 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. + + N (input) INTEGER + The order of the matrix H. N >= 0. + + ILO (input) INTEGER + IHI (input) 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 SGEHRD + when the matrix output by DGEBAL is reduced to Hessenberg + form. Otherwise ILO and IHI should be set to 1 and N + respectively. + 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. + + H (input/output) DOUBLE PRECISION array, dimension (LDH,N) + On entry, the upper Hessenberg matrix H. + On exit, if JOB = 'S', 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) < 0. If JOB = 'E', + the contents of H are unspecified on exit. + + LDH (input) INTEGER + The leading dimension of the array H. LDH >= max(1,N). + + WR (output) DOUBLE PRECISION array, dimension (N) + WI (output) 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) > 0 and + WI(i+1) < 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). + + Z (input/output) 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, 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 Z contains Q*Z. + Normally Q is the orthogonal matrix generated by DORGHR after + the call to DGEHRD which formed the Hessenberg matrix H. + + LDZ (input) INTEGER + The leading dimension of the array Z. + LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise. + + WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) + On exit, if INFO = 0, WORK(1) returns the optimal LWORK. + + LWORK (input) INTEGER + The dimension of the array WORK. LWORK >= max(1,N). + + 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. + + INFO (output) INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value + > 0: if INFO = i, DHSEQR failed to compute all of the + eigenvalues in a total of 30*(IHI-ILO+1) iterations; + elements 1:ilo-1 and i+1:n of WR and WI contain those + eigenvalues which have been successfully computed. - 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.) +\end{chunk} - If INFO .GT. 0 and COMPZ = 'N', then Z is not accessed. +\begin{verbatim} + SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, + $ LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK 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 COMPZ, JOB + INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), + $ Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) + DOUBLE PRECISION CONST + PARAMETER ( CONST = 1.5D+0 ) + INTEGER NSMAX, LDS + PARAMETER ( NSMAX = 15, LDS = NSMAX ) +* .. +* .. Local Scalars .. + LOGICAL INITZ, LQUERY, WANTT, WANTZ + INTEGER I, I1, I2, IERR, II, ITEMP, ITN, ITS, J, K, L, + $ MAXB, NH, NR, NS, NV + DOUBLE PRECISION ABSW, OVFL, SMLNUM, TAU, TEMP, TST1, ULP, UNFL +* .. +* .. Local Arrays .. + DOUBLE PRECISION S( LDS, NSMAX ), V( NSMAX+1 ), VV( NSMAX+1 ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DLAMCH, DLANHS, DLAPY2 + EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DLANHS, DLAPY2 +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DLACPY, DLAHQR, DLARFG, DLARFX, + $ DLASET, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters +* + WANTT = LSAME( JOB, 'S' ) + INITZ = LSAME( COMPZ, 'I' ) + WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) +* + INFO = 0 + WORK( 1 ) = MAX( 1, N ) + LQUERY = ( LWORK.EQ.-1 ) + 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 + CALL XERBLA( 'DHSEQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Initialize Z, if necessary +* + IF( INITZ ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +* +* Store the 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 +* +* 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 +* +* Set rows and columns ILO to IHI to zero below the first +* subdiagonal. +* + DO 40 J = ILO, IHI - 2 + DO 30 I = J + 2, N + H( I, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + NH = IHI - ILO + 1 +* +* Determine the order of the multi-shift QR algorithm to be used. +* + NS = ILAENV( 4, 'DHSEQR', JOB // COMPZ, N, ILO, IHI, -1 ) + MAXB = ILAENV( 8, 'DHSEQR', JOB // COMPZ, N, ILO, IHI, -1 ) + IF( NS.LE.2 .OR. NS.GT.NH .OR. MAXB.GE.NH ) THEN +* +* Use the standard double-shift algorithm +* + CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, + $ IHI, Z, LDZ, INFO ) + RETURN + END IF + MAXB = MAX( 3, MAXB ) + NS = MIN( NS, MAXB, NSMAX ) +* +* Now 2 < NS <= MAXB < NH. +* +* Set machine-dependent constants for the stopping criterion. +* If norm(H) <= sqrt(OVFL), overflow should not occur. +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Precision' ) + SMLNUM = UNFL*( 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 +* +* ITN is the total number of multiple-shift QR iterations allowed. +* + ITN = 30*NH +* +* The main loop begins here. I is the loop index and decreases from +* IHI to ILO in steps of at most MAXB. 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 + 50 CONTINUE + L = ILO + IF( I.LT.ILO ) + $ GO TO 170 +* +* Perform multiple-shift QR iterations on rows and columns ILO to I +* until a submatrix of order at most MAXB splits off at the bottom +* because a subdiagonal element has become negligible. +* + DO 150 ITS = 0, ITN +* +* Look for a single small subdiagonal element. +* + DO 60 K = I, L + 1, -1 + TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) ) + IF( TST1.EQ.ZERO ) + $ TST1 = DLANHS( '1', I-L+1, H( L, L ), LDH, WORK ) + IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) ) + $ GO TO 70 + 60 CONTINUE + 70 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 <= MAXB has split off. +* + IF( L.GE.I-MAXB+1 ) + $ GO TO 160 +* +* 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.20 .OR. ITS.EQ.30 ) THEN +* +* Exceptional shifts. +* + DO 80 II = I - NS + 1, I + WR( II ) = CONST*( ABS( H( II, II-1 ) )+ + $ ABS( H( II, II ) ) ) + WI( II ) = ZERO + 80 CONTINUE + ELSE +* +* Use eigenvalues of trailing submatrix of order NS as shifts. +* + CALL DLACPY( 'Full', NS, NS, H( I-NS+1, I-NS+1 ), LDH, S, + $ LDS ) + CALL DLAHQR( .FALSE., .FALSE., NS, 1, NS, S, LDS, + $ WR( I-NS+1 ), WI( I-NS+1 ), 1, NS, Z, LDZ, + $ IERR ) + IF( IERR.GT.0 ) THEN +* +* If DLAHQR failed to compute all NS eigenvalues, use the +* unconverged diagonal elements as the remaining shifts. +* + DO 90 II = 1, IERR + WR( I-NS+II ) = S( II, II ) + WI( I-NS+II ) = ZERO + 90 CONTINUE + END IF + END IF +* +* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns)) +* where G is the Hessenberg submatrix H(L:I,L:I) and w is +* the vector of shifts (stored in WR and WI). The result is +* stored in the local array V. +* + V( 1 ) = ONE + DO 100 II = 2, NS + 1 + V( II ) = ZERO + 100 CONTINUE + NV = 1 + DO 120 J = I - NS + 1, I + IF( WI( J ).GE.ZERO ) THEN + IF( WI( J ).EQ.ZERO ) THEN +* +* real shift +* + CALL DCOPY( NV+1, V, 1, VV, 1 ) + CALL DGEMV( 'No transpose', NV+1, NV, ONE, H( L, L ), + $ LDH, VV, 1, -WR( J ), V, 1 ) + NV = NV + 1 + ELSE IF( WI( J ).GT.ZERO ) THEN +* +* complex conjugate pair of shifts +* + CALL DCOPY( NV+1, V, 1, VV, 1 ) + CALL DGEMV( 'No transpose', NV+1, NV, ONE, H( L, L ), + $ LDH, V, 1, -TWO*WR( J ), VV, 1 ) + ITEMP = IDAMAX( NV+1, VV, 1 ) + TEMP = ONE / MAX( ABS( VV( ITEMP ) ), SMLNUM ) + CALL DSCAL( NV+1, TEMP, VV, 1 ) + ABSW = DLAPY2( WR( J ), WI( J ) ) + TEMP = ( TEMP*ABSW )*ABSW + CALL DGEMV( 'No transpose', NV+2, NV+1, ONE, + $ H( L, L ), LDH, VV, 1, TEMP, V, 1 ) + NV = NV + 2 + END IF +* +* Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero, +* reset it to the unit vector. +* + ITEMP = IDAMAX( NV, V, 1 ) + TEMP = ABS( V( ITEMP ) ) + IF( TEMP.EQ.ZERO ) THEN + V( 1 ) = ONE + DO 110 II = 2, NV + V( II ) = ZERO + 110 CONTINUE + ELSE + TEMP = MAX( TEMP, SMLNUM ) + CALL DSCAL( NV, ONE / TEMP, V, 1 ) + END IF + END IF + 120 CONTINUE +* +* Multiple-shift QR step +* + DO 140 K = L, 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( NS+1, I-K+1 ) + IF( K.GT.L ) + $ CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 ) + CALL DLARFG( NR, V( 1 ), V( 2 ), 1, TAU ) + IF( K.GT.L ) THEN + H( K, K-1 ) = V( 1 ) + DO 130 II = K + 1, I + H( II, K-1 ) = ZERO + 130 CONTINUE + END IF + V( 1 ) = ONE +* +* Apply G from the left to transform the rows of the matrix in +* columns K to I2. +* + CALL DLARFX( 'Left', NR, I2-K+1, V, TAU, H( K, K ), LDH, + $ WORK ) +* +* Apply G from the right to transform the columns of the +* matrix in rows I1 to min(K+NR,I). +* + CALL DLARFX( 'Right', MIN( K+NR, I )-I1+1, NR, V, TAU, + $ H( I1, K ), LDH, WORK ) +* + IF( WANTZ ) THEN +* +* Accumulate transformations in the matrix Z +* + CALL DLARFX( 'Right', NH, NR, V, TAU, Z( ILO, K ), LDZ, + $ WORK ) + END IF + 140 CONTINUE +* + 150 CONTINUE +* +* Failure to converge in remaining number of iterations +* + INFO = I + RETURN +* + 160 CONTINUE +* +* A submatrix of order <= MAXB in rows and columns L to I has split +* off. Use the double-shift QR algorithm to handle it. +* + CALL DLAHQR( WANTT, WANTZ, N, L, I, H, LDH, WR, WI, ILO, IHI, Z, + $ LDZ, INFO ) + IF( INFO.GT.0 ) + $ RETURN +* +* Decrement number of remaining iterations, and return to start of +* the main loop with a new value of I. +* + ITN = ITN - ITS + I = L - 1 + GO TO 50 +* + 170 CONTINUE + WORK( 1 ) = MAX( 1, N ) + RETURN +* +* End of DHSEQR +* + END -\end{chunk} +\end{verbatim} \begin{chunk}{LAPACK dhseqr} (let* ((zero 0.0) (one 1.0) (two 2.0) (const 1.5) (nsmax 15) (lds nsmax)) @@ -45305,6 +61257,101 @@ ARGUMENTS \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{disnan LAPACK} +%\pagehead{disnan}{disnan} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{disnan.input} +)set break resume +)sys rm -f disnan.output +)spool disnan.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{disnan.help} +==================================================================== +dhseqr examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + +Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + LOGICAL FUNCTION DISNAN( DIN ) + + .. Scalar Arguments .. + DOUBLE PRECISION DIN + .. + + + Purpose: + ============= + + DISNAN returns .TRUE. if its argument is NaN, and .FALSE. + otherwise. To be replaced by the Fortran 2003 intrinsic in the + future. + + + Arguments: + ========== + + [in] DIN + DIN is DOUBLE PRECISION + Input to test for NaN. + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + +\end{chunk} + +\begin{verbatim} + +* ===================================================================== + 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 + +\end{verbatim} + +\begin{chunk}{LAPACK disnan} +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlabad LAPACK} %\pagehead{dlabad}{dlabad} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} @@ -45363,6 +61410,41 @@ ARGUMENTS \end{chunk} +\begin{verbatim} + SUBROUTINE DLABAD( SMALL, LARGE ) +* +* -- 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 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 + +\end{verbatim} + \begin{chunk}{LAPACK dlabad} (defun dlabad (small large) (declare (type (double-float) large small)) @@ -45523,6 +61605,182 @@ FURTHER DETAILS \end{chunk} +\begin{verbatim} + SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, + $ LDY ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* February 29, 1992 +* +* .. 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 + +\end{verbatim} + \begin{chunk}{LAPACK dlabrd} (let* ((zero 0.0) (one 1.0)) (declare (type (double-float 0.0 0.0) zero) @@ -46126,6 +62384,170 @@ FURTHER DETAILS \end{chunk} +\begin{verbatim} + SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* February 29, 1992 +* +* .. Scalar Arguments .. + INTEGER KASE, N + DOUBLE PRECISION EST +* .. +* .. Array Arguments .. + INTEGER ISGN( * ) + 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, ITER, J, JLAST, JUMP + 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 +* .. +* .. Save statement .. + SAVE +* .. +* .. Executable Statements .. +* + IF( KASE.EQ.0 ) THEN + DO 10 I = 1, N + X( I ) = ONE / DBLE( N ) + 10 CONTINUE + KASE = 1 + JUMP = 1 + RETURN + END IF +* + GO TO ( 20, 40, 70, 110, 140 )JUMP +* +* ................ ENTRY (JUMP = 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 + JUMP = 2 + RETURN +* +* ................ ENTRY (JUMP = 2) +* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. +* + 40 CONTINUE + J = IDAMAX( N, X, 1 ) + ITER = 2 +* +* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. +* + 50 CONTINUE + DO 60 I = 1, N + X( I ) = ZERO + 60 CONTINUE + X( J ) = ONE + KASE = 1 + JUMP = 3 + RETURN +* +* ................ ENTRY (JUMP = 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 + JUMP = 4 + RETURN +* +* ................ ENTRY (JUMP = 4) +* X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. +* + 110 CONTINUE + JLAST = J + J = IDAMAX( N, X, 1 ) + IF( ( X( JLAST ).NE.ABS( X( J ) ) ) .AND. ( ITER.LT.ITMAX ) ) THEN + ITER = ITER + 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 + JUMP = 5 + RETURN +* +* ................ ENTRY (JUMP = 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 DLACON +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlacon} (let* ((itmax 5) (zero 0.0) (one 1.0) (two 2.0)) (declare (type (fixnum 5 5) itmax) @@ -46346,6 +62768,63 @@ ARGUMENTS \end{chunk} +\begin{verbatim} + SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* February 29, 1992 +* +* .. 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 + +\end{verbatim} + \begin{chunk}{LAPACK dlacpy} (defun dlacpy (uplo m n a lda b ldb$) (declare (type (simple-array double-float (*)) b a) @@ -46436,31 +62915,72 @@ Man Page Details ==================================================================== NAME - DLADIV - complex division in real arithmetic a + i*b p + i*q = - --------- c + i*d The algorithm is due to Robert L + DLADIV performs complex division in real arithmetic -SYNOPSIS - SUBROUTINE DLADIV( A, B, C, D, P, Q ) + a + i*b + p + i*q = --------- + c + i*d - DOUBLE PRECISION A, B, C, D, P, Q + The algorithm is due to Robert L. Smith and can be found + in D. Knuth, The art of Computer Programming, Vol.2, p.195 -PURPOSE - DLADIV performs complex division in real arithmetic in D. Knuth, The - art of Computer Programming, Vol.2, p.195 + Arguments + ========= + A (input) DOUBLE PRECISION + B (input) DOUBLE PRECISION + C (input) DOUBLE PRECISION + D (input) DOUBLE PRECISION + The scalars a, b, c, and d in the above expression. -ARGUMENTS - A (input) DOUBLE PRECISION - B (input) DOUBLE PRECISION C (input) DOUBLE PRECI- - SION D (input) DOUBLE PRECISION The scalars a, b, c, and - d in the above expression. - - P (output) DOUBLE PRECISION - Q (output) DOUBLE PRECISION The scalars p and q in the - above expression. + P (output) DOUBLE PRECISION + Q (output) DOUBLE PRECISION + The scalars p and q in the above expression. \end{chunk} +\begin{verbatim} + SUBROUTINE DLADIV( A, B, C, D, P, Q ) +* +* -- 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, 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 + +\end{verbatim} + \begin{chunk}{LAPACK dladiv} (defun dladiv (a b c d p q) (declare (type (double-float) q p d c b a)) @@ -46505,66 +63025,311 @@ dlaed6 examples Man Page Details ==================================================================== -NAME - DLAED6 - the positive or negative root (closest to the origin) of z(1) - z(2) z(3) f(x) = rho + --------- + ---------- + --------- d(1)-x - d(2)-x d(3)-x It is assumed that if ORGATI = .true - -SYNOPSIS - SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) + Purpose + ======= - LOGICAL ORGATI + DLAED6 computes the positive or negative root (closest to the origin) + of + z(1) z(2) z(3) + f(x) = rho + --------- + ---------- + --------- + d(1)-x d(2)-x d(3)-x - INTEGER INFO, KNITER + It is assumed that - DOUBLE PRECISION FINIT, RHO, TAU + if ORGATI = .true. the root is between d(2) and d(3); + otherwise it is between d(1) and d(2) - DOUBLE PRECISION D( 3 ), Z( 3 ) + This routine will be called by DLAED4 when necessary. In most cases, + the root sought is the smallest in magnitude, though it might not be + in some extremely rare situations. -PURPOSE - DLAED6 computes the positive or negative root (closest to the origin) - of - z(1) z(2) z(3) f(x) = rho + --------- - + ---------- + --------- - d(1)-x d(2)-x d(3)-x - otherwise it is between d(1) and d(2) + Arguments + ========= - This routine will be called by DLAED4 when necessary. In most cases, - the root sought is the smallest in magnitude, though it might not be in - some extremely rare situations. + KNITER (input) INTEGER + Refer to DLAED4 for its significance. + ORGATI (input) LOGICAL + If ORGATI is true, the needed root is between d(2) and + d(3); otherwise it is between d(1) and d(2). See + DLAED4 for further details. -ARGUMENTS - KNITER (input) INTEGER - Refer to DLAED4 for its significance. + RHO (input) DOUBLE PRECISION + Refer to the equation f(x) above. - ORGATI (input) LOGICAL - If ORGATI is true, the needed root is between d(2) and - d(3); otherwise it is between d(1) and d(2). See DLAED4 - for further details. + D (input) DOUBLE PRECISION array, dimension (3) + D satisfies d(1) < d(2) < d(3). - RHO (input) DOUBLE PRECISION - Refer to the equation f(x) above. + Z (input) DOUBLE PRECISION array, dimension (3) + Each of the elements in z must be positive. - D (input) DOUBLE PRECISION array, dimension (3) - D satisfies d(1) < d(2) < d(3). + FINIT (input) DOUBLE PRECISION + The value of f at 0. It is more accurate than the one + evaluated inside this routine (if someone wants to do + so). - Z (input) DOUBLE PRECISION array, dimension (3) - Each of the elements in z must be positive. + TAU (output) DOUBLE PRECISION + The root of the equation f(x). - FINIT (input) DOUBLE PRECISION - The value of f at 0. It is more accurate than the one - evaluated inside this routine (if someone wants to do so). + INFO (output) INTEGER + = 0: successful exit + > 0: if INFO = 1, failure to converge - TAU (output) DOUBLE PRECISION - The root of the equation f(x). + Further Details + =============== - INFO (output) INTEGER - = 0: successful exit - > 0: if INFO = 1, failure to converge + Based on contributions by + Ren-Cang Li, Computer Science Division, University of California + at Berkeley, USA \end{chunk} +\begin{verbatim} + SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) +* +* -- LAPACK routine (version 3.0) -- +* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, +* Courant Institute, NAG Ltd., and Rice University +* June 30, 1999 +* +* .. Scalar Arguments .. + LOGICAL ORGATI + INTEGER INFO, KNITER + DOUBLE PRECISION FINIT, RHO, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( 3 ), Z( 3 ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER MAXIT + PARAMETER ( MAXIT = 20 ) + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Local Arrays .. + DOUBLE PRECISION DSCALE( 3 ), ZSCALE( 3 ) +* .. +* .. Local Scalars .. + LOGICAL FIRST, SCALE + INTEGER I, ITER, NITER + DOUBLE PRECISION A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F, + $ FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1, + $ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4 +* .. +* .. Save statement .. + SAVE FIRST, SMALL1, SMINV1, SMALL2, SMINV2, EPS +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* + INFO = 0 +* + NITER = 1 + TAU = ZERO + IF( KNITER.EQ.2 ) THEN + IF( ORGATI ) THEN + TEMP = ( D( 3 )-D( 2 ) ) / TWO + C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP ) + A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 ) + B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 ) + ELSE + TEMP = ( D( 1 )-D( 2 ) ) / TWO + C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP ) + A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 ) + B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 ) + END IF + TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) ) + A = A / TEMP + B = B / TEMP + C = C / TEMP + IF( C.EQ.ZERO ) THEN + TAU = B / A + ELSE IF( A.LE.ZERO ) THEN + TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + TEMP = RHO + Z( 1 ) / ( D( 1 )-TAU ) + + $ Z( 2 ) / ( D( 2 )-TAU ) + Z( 3 ) / ( D( 3 )-TAU ) + IF( ABS( FINIT ).LE.ABS( TEMP ) ) + $ TAU = ZERO + END IF +* +* On first call to routine, get machine parameters for +* possible scaling to avoid overflow +* + IF( FIRST ) THEN + EPS = DLAMCH( 'Epsilon' ) + BASE = DLAMCH( 'Base' ) + SMALL1 = BASE**( INT( LOG( DLAMCH( 'SafMin' ) ) / LOG( BASE ) / + $ THREE ) ) + SMINV1 = ONE / SMALL1 + SMALL2 = SMALL1*SMALL1 + SMINV2 = SMINV1*SMINV1 + FIRST = .FALSE. + END IF +* +* Determine if scaling of inputs necessary to avoid overflow +* when computing 1/TEMP**3 +* + IF( ORGATI ) THEN + TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) ) + ELSE + TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) ) + END IF + SCALE = .FALSE. + IF( TEMP.LE.SMALL1 ) THEN + SCALE = .TRUE. + IF( TEMP.LE.SMALL2 ) THEN +* +* Scale up by power of radix nearest 1/SAFMIN**(2/3) +* + SCLFAC = SMINV2 + SCLINV = SMALL2 + ELSE +* +* Scale up by power of radix nearest 1/SAFMIN**(1/3) +* + SCLFAC = SMINV1 + SCLINV = SMALL1 + END IF +* +* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1) +* + DO 10 I = 1, 3 + DSCALE( I ) = D( I )*SCLFAC + ZSCALE( I ) = Z( I )*SCLFAC + 10 CONTINUE + TAU = TAU*SCLFAC + ELSE +* +* Copy D and Z to DSCALE and ZSCALE +* + DO 20 I = 1, 3 + DSCALE( I ) = D( I ) + ZSCALE( I ) = Z( I ) + 20 CONTINUE + END IF +* + FC = ZERO + DF = ZERO + DDF = ZERO + DO 30 I = 1, 3 + TEMP = ONE / ( DSCALE( I )-TAU ) + TEMP1 = ZSCALE( I )*TEMP + TEMP2 = TEMP1*TEMP + TEMP3 = TEMP2*TEMP + FC = FC + TEMP1 / DSCALE( I ) + DF = DF + TEMP2 + DDF = DDF + TEMP3 + 30 CONTINUE + F = FINIT + TAU*FC +* + IF( ABS( F ).LE.ZERO ) + $ GO TO 60 +* +* Iteration begins +* +* It is not hard to see that +* +* 1) Iterations will go up monotonically +* if FINIT < 0; +* +* 2) Iterations will go down monotonically +* if FINIT > 0. +* + ITER = NITER + 1 +* + DO 50 NITER = ITER, MAXIT +* + IF( ORGATI ) THEN + TEMP1 = DSCALE( 2 ) - TAU + TEMP2 = DSCALE( 3 ) - TAU + ELSE + TEMP1 = DSCALE( 1 ) - TAU + TEMP2 = DSCALE( 2 ) - TAU + END IF + A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF + B = TEMP1*TEMP2*F + C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF + TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) ) + A = A / TEMP + B = B / TEMP + C = C / TEMP + IF( C.EQ.ZERO ) THEN + ETA = B / A + ELSE IF( A.LE.ZERO ) THEN + ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + IF( F*ETA.GE.ZERO ) THEN + ETA = -F / DF + END IF +* + TEMP = ETA + TAU + IF( ORGATI ) THEN + IF( ETA.GT.ZERO .AND. TEMP.GE.DSCALE( 3 ) ) + $ ETA = ( DSCALE( 3 )-TAU ) / TWO + IF( ETA.LT.ZERO .AND. TEMP.LE.DSCALE( 2 ) ) + $ ETA = ( DSCALE( 2 )-TAU ) / TWO + ELSE + IF( ETA.GT.ZERO .AND. TEMP.GE.DSCALE( 2 ) ) + $ ETA = ( DSCALE( 2 )-TAU ) / TWO + IF( ETA.LT.ZERO .AND. TEMP.LE.DSCALE( 1 ) ) + $ ETA = ( DSCALE( 1 )-TAU ) / TWO + END IF + TAU = TAU + ETA +* + FC = ZERO + ERRETM = ZERO + DF = ZERO + DDF = ZERO + DO 40 I = 1, 3 + TEMP = ONE / ( DSCALE( I )-TAU ) + TEMP1 = ZSCALE( I )*TEMP + TEMP2 = TEMP1*TEMP + TEMP3 = TEMP2*TEMP + TEMP4 = TEMP1 / DSCALE( I ) + FC = FC + TEMP4 + ERRETM = ERRETM + ABS( TEMP4 ) + DF = DF + TEMP2 + DDF = DDF + TEMP3 + 40 CONTINUE + F = FINIT + TAU*FC + ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) + + $ ABS( TAU )*DF + IF( ABS( F ).LE.EPS*ERRETM ) + $ GO TO 60 + 50 CONTINUE + INFO = 1 + 60 CONTINUE +* +* Undo scaling +* + IF( SCALE ) + $ TAU = TAU*SCLINV + RETURN +* +* End of DLAED6 +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlaed6} (let* ((maxit 20) (zero 0.0) @@ -46969,6 +63734,309 @@ ARGUMENTS \end{chunk} +\begin{verbatim} + SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, + $ INFO ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* February 29, 1992 +* +* .. 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 + +\end{verbatim} + \begin{chunk}{LAPACK dlaexc} (let* ((zero 0.0) (one 1.0) (ten 10.0) (ldd 4) (ldx 2)) (declare (type (double-float 0.0 0.0) zero) @@ -47481,93 +64549,447 @@ SYNOPSIS DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) -PURPOSE - 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. - - -ARGUMENTS - WANTT (input) LOGICAL - = .TRUE. : the full Schur form T is required; - = .FALSE.: only eigenvalues are required. - - WANTZ (input) LOGICAL - = .TRUE. : the matrix of Schur vectors Z is required; - = .FALSE.: Schur vectors are not required. - - N (input) INTEGER - The order of the matrix H. N >= 0. - - ILO (input) INTEGER - IHI (input) 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. - - H (input/output) 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 con- - tents of H are unspecified on exit. The output state of H if - INFO is nonzero is given below under the description of INFO. - - LDH (input) INTEGER - The leading dimension of the array H. LDH >= max(1,N). - - WR (output) DOUBLE PRECISION array, dimension (N) - WI (output) 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). - - ILOZ (input) INTEGER - IHIZ (input) INTEGER Specify the rows of Z to which trans- - formations must be applied if WANTZ is .TRUE.. 1 <= ILOZ <= - ILO; IHI <= IHIZ <= N. - - Z (input/output) 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 refer- - enced. - - LDZ (input) INTEGER - The leading dimension of the array Z. LDZ >= max(1,N). - - INFO (output) INTEGER - = 0: successful exit - eigenvalues ILO to IHI in a total of 30 iterations per eigen- - value; elements i+1:ihi of WR and WI contain those eigenvalues + Purpose + ======= + + 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. + + Arguments + ========= + + WANTT (input) LOGICAL + = .TRUE. : the full Schur form T is required; + = .FALSE.: only eigenvalues are required. + + WANTZ (input) LOGICAL + = .TRUE. : the matrix of Schur vectors Z is required; + = .FALSE.: Schur vectors are not required. + + N (input) INTEGER + The order of the matrix H. N >= 0. + + ILO (input) INTEGER + IHI (input) 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. + + H (input/output) DOUBLE PRECISION array, dimension (LDH,N) + On entry, the upper Hessenberg matrix H. + On exit, 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 WANTT is .FALSE., the contents of H are + unspecified on exit. + + LDH (input) INTEGER + The leading dimension of the array H. LDH >= max(1,N). + + WR (output) DOUBLE PRECISION array, dimension (N) + WI (output) 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). + + ILOZ (input) INTEGER + IHIZ (input) INTEGER + Specify the rows of Z to which transformations must be + applied if WANTZ is .TRUE.. + 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. + + Z (input/output) 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. + + LDZ (input) INTEGER + The leading dimension of the array Z. LDZ >= max(1,N). + + INFO (output) INTEGER + = 0: successful exit + > 0: DLAHQR failed to compute all the eigenvalues ILO to IHI + in a total of 30*(IHI-ILO+1) iterations; if INFO = i, + 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 remain- - ing unconverged eigenvalues are the eigenvalues of the upper - Hessenberg matrix rows and columns ILO thorugh INFO of the - final, output value of H. + Further Details + =============== - 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.) + 2-96 Based on modifications by + David Day, Sandia National Laboratory, USA \end{chunk} +\begin{verbatim} + SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, INFO ) +* +* -- 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 .. + LOGICAL WANTT, WANTZ + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D0 ) + DOUBLE PRECISION DAT1, DAT2 + PARAMETER ( DAT1 = 0.75D+0, DAT2 = -0.4375D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, I1, I2, ITN, ITS, J, K, L, M, NH, NR, NZ + DOUBLE PRECISION AVE, CS, DISC, H00, H10, H11, H12, H21, H22, + $ H33, H33S, H43H34, H44, H44S, OVFL, S, SMLNUM, + $ SN, SUM, T1, T2, T3, TST1, ULP, UNFL, V1, V2, + $ V3 +* .. +* .. Local Arrays .. + DOUBLE PRECISION V( 3 ), WORK( 1 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANHS + EXTERNAL DLAMCH, DLANHS +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLANV2, DLARFG, DROT +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SIGN, 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 +* + NH = IHI - ILO + 1 + NZ = IHIZ - ILOZ + 1 +* +* Set machine-dependent constants for the stopping criterion. +* If norm(H) <= sqrt(OVFL), overflow should not occur. +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Precision' ) + SMLNUM = UNFL*( 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 +* +* ITN is the total number of QR iterations allowed. +* + ITN = 30*NH +* +* 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 + 10 CONTINUE + L = ILO + IF( I.LT.ILO ) + $ GO TO 150 +* +* 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 130 ITS = 0, ITN +* +* Look for a single small subdiagonal element. +* + DO 20 K = I, L + 1, -1 + TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) ) + IF( TST1.EQ.ZERO ) + $ TST1 = DLANHS( '1', I-L+1, H( L, L ), LDH, WORK ) + IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) ) + $ GO TO 30 + 20 CONTINUE + 30 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 140 +* +* 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 .OR. ITS.EQ.20 ) THEN +* +* Exceptional shift. +* + S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) + H44 = DAT1*S + H( I, I ) + H33 = H44 + H43H34 = DAT2*S*S + ELSE +* +* Prepare to use Francis' double shift +* (i.e. 2nd degree generalized Rayleigh quotient) +* + H44 = H( I, I ) + H33 = H( I-1, I-1 ) + H43H34 = H( I, I-1 )*H( I-1, I ) + S = H( I-1, I-2 )*H( I-1, I-2 ) + DISC = ( H33-H44 )*HALF + DISC = DISC*DISC + H43H34 + IF( DISC.GT.ZERO ) THEN +* +* Real roots: use Wilkinson's shift twice +* + DISC = SQRT( DISC ) + AVE = HALF*( H33+H44 ) + IF( ABS( H33 )-ABS( H44 ).GT.ZERO ) THEN + H33 = H33*H44 - H43H34 + H44 = H33 / ( SIGN( DISC, AVE )+AVE ) + ELSE + H44 = SIGN( DISC, AVE ) + AVE + END IF + H33 = H44 + H43H34 = ZERO + END IF + END IF +* +* Look for two consecutive small subdiagonal elements. +* + DO 40 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. +* + H11 = H( M, M ) + H22 = H( M+1, M+1 ) + H21 = H( M+1, M ) + H12 = H( M, M+1 ) + H44S = H44 - H11 + H33S = H33 - H11 + V1 = ( H33S*H44S-H43H34 ) / H21 + H12 + V2 = H22 - H11 - H33S - H44S + V3 = H( M+2, M+1 ) + S = ABS( V1 ) + ABS( V2 ) + ABS( V3 ) + V1 = V1 / S + V2 = V2 / S + V3 = V3 / S + V( 1 ) = V1 + V( 2 ) = V2 + V( 3 ) = V3 + IF( M.EQ.L ) + $ GO TO 50 + H00 = H( M-1, M-1 ) + H10 = H( M, M-1 ) + TST1 = ABS( V1 )*( ABS( H00 )+ABS( H11 )+ABS( H22 ) ) + IF( ABS( H10 )*( ABS( V2 )+ABS( V3 ) ).LE.ULP*TST1 ) + $ GO TO 50 + 40 CONTINUE + 50 CONTINUE +* +* Double-shift QR step +* + DO 120 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 + H( K, K-1 ) = -H( K, K-1 ) + 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 60 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 + 60 CONTINUE +* +* Apply G from the right to transform the columns of the +* matrix in rows I1 to min(K+3,I). +* + DO 70 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 + 70 CONTINUE +* + IF( WANTZ ) THEN +* +* Accumulate transformations in the matrix Z +* + DO 80 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 + 80 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 90 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 + 90 CONTINUE +* +* Apply G from the right to transform the columns of the +* matrix in rows I1 to min(K+3,I). +* + DO 100 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 + 100 CONTINUE +* + IF( WANTZ ) THEN +* +* Accumulate transformations in the matrix Z +* + DO 110 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 + 110 CONTINUE + END IF + END IF + 120 CONTINUE +* + 130 CONTINUE +* +* Failure to converge in remaining number of iterations +* + INFO = I + RETURN +* + 140 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 +* +* Decrement number of remaining iterations, and return to start of +* the main loop with new value of I. +* + ITN = ITN - ITS + I = L - 1 + GO TO 10 +* + 150 CONTINUE + RETURN +* +* End of DLAHQR +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlahqr} (let* ((zero 0.0) (one 1.0) (half 0.5) (dat1 0.75) (dat2 (- 0.4375))) (declare (type (double-float 0.0 0.0) zero) @@ -48353,6 +65775,129 @@ FURTHER DETAILS \end{chunk} +\begin{verbatim} + SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) +* +* -- 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 .. + 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, DGEMV, DLARFG, DSCAL, 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(1:n,i) +* +* Compute i-th column of A - Y * V' +* + CALL DGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, + $ A( K+I-1, 1 ), LDA, ONE, A( 1, I ), 1 ) +* +* Apply I - V * T' * V' 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' * 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'*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'*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(1:n,i) +* + CALL DGEMV( 'No transpose', N, N-K-I+1, ONE, A( 1, I+1 ), LDA, + $ A( K+I, I ), 1, ZERO, Y( 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, I-1, -ONE, Y, LDY, T( 1, I ), 1, + $ ONE, Y( 1, I ), 1 ) + CALL DSCAL( N, TAU( I ), Y( 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 +* + RETURN +* +* End of DLAHRD +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlahrd} (let* ((zero 0.0) (one 1.0)) (declare (type (double-float 0.0 0.0) zero) @@ -48522,14 +66067,14 @@ FURTHER DETAILS \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dlaln2 LAPACK} -%\pagehead{dlaln2}{dlaln2} +\section{dlaisnan LAPACK} +%\pagehead{dlaisnan}{dlaisnan} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} -\begin{chunk}{dlaln2.input} +\begin{chunk}{dlaisnan.input} )set break resume -)sys rm -f dlaln2.output -)spool dlaln2.output +)sys rm -f dlaisnan.output +)spool dlaisnan.output )set message test on )set message auto off )clear all @@ -48537,141 +66082,669 @@ FURTHER DETAILS )spool )lisp (bye) \end{chunk} -\begin{chunk}{dlaln2.help} +\begin{chunk}{dlaisnan.help} ==================================================================== -dlaln2 examples +dlaisnan examples ==================================================================== ==================================================================== Man Page Details ==================================================================== -NAME - DLALN2 - a system of the form (ca A - w D ) X = s B or (ca A' - w D) X - = s B with possible scaling ("s") and perturbation of A + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ -SYNOPSIS - SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, LDB, - WR, WI, X, LDX, SCALE, XNORM, INFO ) + Definition: + =========== - LOGICAL LTRANS + LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) + + .. Scalar Arguments .. + DOUBLE PRECISION DIN1, DIN2 + .. + - INTEGER INFO, LDA, LDB, LDX, NA, NW + Purpose: + ============= - DOUBLE PRECISION CA, D1, D2, SCALE, SMIN, WI, WR, XNORM + This routine is not for general use. It exists solely to avoid + over-optimization in DISNAN. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * ) + 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. -PURPOSE - DLALN2 solves a system of the form (ca A - w D ) X = s B or (ca A' - w - D) X = s B with possible scaling ("s") and perturbation of A. (A' - 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 cho- - sen 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 over- - flow. - - If both singular values of (ca A - w D) are less than SMIN, SMIN*iden- - tity 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.) + 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. + Arguments: + ========== -ARGUMENTS - LTRANS (input) LOGICAL - =.TRUE.: A-transpose will be used. - =.FALSE.: A will be used (not transposed.) + [in] DIN1 + DIN1 is DOUBLE PRECISION - NA (input) INTEGER - The size of the matrix A. It may (only) be 1 or 2. + [in] DIN2 + DIN2 is DOUBLE PRECISION + Two numbers to compare for inequality. - NW (input) INTEGER - 1 if "w" is real, 2 if "w" is complex. It may only be 1 or 2. + Authors: + ======== + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. - SMIN (input) 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.) + November 2011 - CA (input) DOUBLE PRECISION - The coefficient c, which A is multiplied by. +\end{chunk} - A (input) DOUBLE PRECISION array, dimension (LDA,NA) - The NA x NA matrix A. +\begin{verbatim} +* ===================================================================== + 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 - LDA (input) INTEGER - The leading dimension of A. It must be at least NA. +\end{verbatim} - D1 (input) DOUBLE PRECISION - The 1,1 element in the diagonal matrix D. +\begin{chunk}{LAPACK dlaisnan} +\end{chunk} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlaln2 LAPACK} +%\pagehead{dlaln2}{dlaln2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - D2 (input) DOUBLE PRECISION - The 2,2 element in the diagonal matrix D. Not used if NW=1. +\begin{chunk}{dlaln2.input} +)set break resume +)sys rm -f dlaln2.output +)spool dlaln2.output +)set message test on +)set message auto off +)clear all - B (input) DOUBLE PRECISION array, dimension (LDB,NW) - The NA x NW matrix B (right-hand side). If NW=2 ("w" is com- - plex), column 1 contains the real part of B and column 2 con- - tains the imaginary part. +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{dlaln2.help} +==================================================================== +dlaln2 examples +==================================================================== - LDB (input) INTEGER - The leading dimension of B. It must be at least NA. +==================================================================== +Man Page Details +==================================================================== - WR (input) DOUBLE PRECISION - The real part of the scalar "w". +NAME + DLALN2 - a system of the form (ca A - w D ) X = s B or (ca A' - w D) X + = s B with possible scaling ("s") and perturbation of A - WI (input) DOUBLE PRECISION - The imaginary part of the scalar "w". Not used if NW=1. +SYNOPSIS + SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, LDB, + WR, WI, X, LDX, SCALE, XNORM, INFO ) - X (output) 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. + LOGICAL LTRANS - LDX (input) INTEGER - The leading dimension of X. It must be at least NA. + INTEGER INFO, LDA, LDB, LDX, NA, NW - SCALE (output) 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. + DOUBLE PRECISION CA, D1, D2, SCALE, SMIN, WI, WR, XNORM - XNORM (output) DOUBLE PRECISION - The infinity-norm of X, when X is regarded as an NA x NW real - matrix. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * ) - INFO (output) 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 num- - ber 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. + Purpose + ======= + + DLALN2 solves a system of the form (ca A - w D ) X = s B + or (ca A' - w D) X = s B with possible scaling ("s") and + perturbation of A. (A' 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.) + + Arguments + ========== + + LTRANS (input) LOGICAL + =.TRUE.: A-transpose will be used. + =.FALSE.: A will be used (not transposed.) + + NA (input) INTEGER + The size of the matrix A. It may (only) be 1 or 2. + + NW (input) INTEGER + 1 if "w" is real, 2 if "w" is complex. It may only be 1 + or 2. + + SMIN (input) 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.) + + CA (input) DOUBLE PRECISION + The coefficient c, which A is multiplied by. + + A (input) DOUBLE PRECISION array, dimension (LDA,NA) + The NA x NA matrix A. + + LDA (input) INTEGER + The leading dimension of A. It must be at least NA. + + D1 (input) DOUBLE PRECISION + The 1,1 element in the diagonal matrix D. + + D2 (input) DOUBLE PRECISION + The 2,2 element in the diagonal matrix D. Not used if NW=1. + + B (input) 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. + + LDB (input) INTEGER + The leading dimension of B. It must be at least NA. + + WR (input) DOUBLE PRECISION + The real part of the scalar "w". + + WI (input) DOUBLE PRECISION + The imaginary part of the scalar "w". Not used if NW=1. + + X (output) 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. + + LDX (input) INTEGER + The leading dimension of X. It must be at least NA. + + SCALE (output) 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. + + XNORM (output) DOUBLE PRECISION + The infinity-norm of X, when X is regarded as an NA x NW + real matrix. + + INFO (output) 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. \end{chunk} +\begin{verbatim} + 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.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. 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 .. +c +c *** F2CL cannot currently handle equivalences of arrays +c *** So we do this by hand. Since Fortran arrays are column-major +c *** order, we have the following: +c *** +c *** ci(1,1) civ(1) +c *** ci(2,1) civ(2) +c *** ci(1,2) civ(3) +c *** ci(2,2) civ(4) +c *** +c *** Similarly for CR. +c EQUIVALENCE ( CI( 1, 1 ), CIV( 1 ) ), +c $ ( 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' - w D ) +* +c *** F2CL original +c CR( 1, 1 ) = CA*A( 1, 1 ) - WR*D1 +c CR( 2, 2 ) = CA*A( 2, 2 ) - WR*D2 +c *** F2CL replacement + crv(1) = CA*A( 1, 1 ) - WR*D1 + crv(4) = CA*A( 2, 2 ) - WR*D2 + IF( LTRANS ) THEN +c CR( 1, 2 ) = CA*A( 2, 1 ) +c CR( 2, 1 ) = CA*A( 1, 2 ) + crv( 3 ) = CA*A( 2, 1 ) + crv( 2 ) = CA*A( 1, 2 ) + ELSE +c CR( 2, 1 ) = CA*A( 2, 1 ) +c CR( 1, 2 ) = CA*A( 1, 2 ) + crv( 2 ) = CA*A( 2, 1 ) + crv( 3 ) = 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 +* +c *** F2CL original +c CI( 1, 1 ) = -WI*D1 +c CI( 2, 1 ) = ZERO +c CI( 1, 2 ) = ZERO +c CI( 2, 2 ) = -WI*D2 + civ( 1 ) = -WI*D1 + civ( 2 ) = ZERO + civ( 3 ) = ZERO + civ( 4 ) = -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 + +\end{verbatim} + \begin{chunk}{LAPACK dlaln2} (let* ((zero 0.0) (one 1.0) (two 2.0)) (declare (type (double-float 0.0 0.0) zero) @@ -49407,36 +67480,139 @@ SYNOPSIS 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 addi- - tion, 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) + 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) \end{chunk} +\begin{verbatim} + 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 +* .. +* +* ===================================================================== +* +* .. 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 + +\end{verbatim} + \begin{chunk}{LAPACK dlamch} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -49595,6 +67771,159 @@ Man Page Details \end{chunk} +\begin{verbatim} +************************************************************************ +* + 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 +* .. +* +* ===================================================================== +* +* .. 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 +* + +\end{verbatim} + \begin{chunk}{LAPACK dlamc1} (let ((lieee1 nil) (lbeta 0) (lrnd nil) (f2cl-lib:lt 0) (first$ nil)) (declare (type fixnum f2cl-lib:lt lbeta) @@ -49814,6 +68143,217 @@ Man Page Details \end{chunk} +\begin{verbatim} +************************************************************************ +* + 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 +* .. +* +* ===================================================================== +* +* .. 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 +\end{verbatim} + \begin{chunk}{LAPACK dlamc2} (let ((lbeta 0) (lemax 0) @@ -50103,6 +68643,36 @@ Man Page Details \end{chunk} +\begin{verbatim} +************************************************************************ +* + 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 +* .. +* + +* ===================================================================== +* +* .. Executable Statements .. +* + DLAMC3 = A + B +* + RETURN +* +* End of DLAMC3 +* + END +* + +\end{verbatim} + \begin{chunk}{LAPACK dlamc3} (defun dlamc3 (a b) (declare (type (double-float) b a)) @@ -50168,6 +68738,75 @@ Man Page Details \end{chunk} +\begin{verbatim} +************************************************************************ +* + 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 +* .. +* +* ===================================================================== +* +* .. 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 +* + +\end{verbatim} + \begin{chunk}{LAPACK dlamc4} (defun dlamc4 (emin start base) (declare (type (double-float) start) (type fixnum base emin)) @@ -50303,6 +68942,140 @@ Man Page Details \end{chunk} +\begin{verbatim} +************************************************************************ +* + 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 +* .. +* +* ===================================================================== +* +* .. 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 +* +* + +\end{verbatim} + \begin{chunk}{LAPACK dlamc5} (let* ((zero 0.0) (one 1.0)) (declare (type (double-float 0.0 0.0) zero) @@ -50413,35 +69186,116 @@ SYNOPSIS DOUBLE PRECISION A( * ) -PURPOSE - DLAMRG will create a permutation list which will merge the elements of - A (which is composed of two independently sorted sets) into a single - set which is sorted in ascending order. + Purpose + ======= + DLAMRG will create a permutation list which will merge the elements + of A (which is composed of two independently sorted sets) into a + single set which is sorted in ascending order. -ARGUMENTS - N1 (input) INTEGER - N2 (input) INTEGER These arguements contain the respective - lengths of the two sorted lists to be merged. + Arguments + ========= + + N1 (input) INTEGER + N2 (input) INTEGER + These arguements contain the respective lengths of the two + sorted lists to be merged. - A (input) DOUBLE PRECISION array, dimension (N1+N2) - The first N1 elements of A contain a list of numbers which are - sorted in either ascending or descending order. Likewise for - the final N2 elements. + A (input) DOUBLE PRECISION array, dimension (N1+N2) + The first N1 elements of A contain a list of numbers which + are sorted in either ascending or descending order. Likewise + for the final N2 elements. - DTRD1 (input) INTEGER - DTRD2 (input) INTEGER These are the strides to be taken through - the array A. Allowable strides are 1 and -1. They indicate - whether a subset of A is sorted in ascending (DTRDx = 1) or - descending (DTRDx = -1) order. + DTRD1 (input) INTEGER + DTRD2 (input) INTEGER + These are the strides to be taken through the array A. + Allowable strides are 1 and -1. They indicate whether a + subset of A is sorted in ascending (DTRDx = 1) or descending + (DTRDx = -1) order. - INDEX (output) INTEGER array, dimension (N1+N2) - On exit this array will contain a permutation such that if B( I - ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be sorted in - ascending order. + INDX (output) INTEGER array, dimension (N1+N2) + On exit this array will contain a permutation such that + if B( I ) = A( INDX( I ) ) for I=1,N1+N2, then B will be + sorted in ascending order. \end{chunk} +\begin{verbatim} + SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDX ) +* +* -- LAPACK routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* September 30, 1994 +* +* .. Scalar Arguments .. + INTEGER DTRD1, DTRD2, N1, N2 +* .. +* .. Array Arguments .. + INTEGER INDX( * ) + DOUBLE PRECISION A( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IND1, IND2, N1SV, N2SV +* .. +* .. Executable Statements .. +* + N1SV = N1 + N2SV = N2 + IF( DTRD1.GT.0 ) THEN + IND1 = 1 + ELSE + IND1 = N1 + END IF + IF( DTRD2.GT.0 ) THEN + IND2 = 1 + N1 + ELSE + IND2 = N1 + N2 + END IF + I = 1 +* while ( (N1SV > 0) & (N2SV > 0) ) + 10 CONTINUE + IF( N1SV.GT.0 .AND. N2SV.GT.0 ) THEN + IF( A( IND1 ).LE.A( IND2 ) ) THEN + INDX( I ) = IND1 + I = I + 1 + IND1 = IND1 + DTRD1 + N1SV = N1SV - 1 + ELSE + INDX( I ) = IND2 + I = I + 1 + IND2 = IND2 + DTRD2 + N2SV = N2SV - 1 + END IF + GO TO 10 + END IF +* end while + IF( N1SV.EQ.0 ) THEN + DO 20 N1SV = 1, N2SV + INDX( I ) = IND2 + I = I + 1 + IND2 = IND2 + DTRD2 + 20 CONTINUE + ELSE +* N2SV .EQ. 0 + DO 30 N2SV = 1, N1SV + INDX( I ) = IND1 + I = I + 1 + IND1 = IND1 + DTRD1 + 30 CONTINUE + END IF +* + RETURN +* +* End of DLAMRG +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlamrg} (defun dlamrg (n1 n2 a dtrd1 dtrd2 indx) (declare (type (simple-array fixnum (*)) indx) @@ -50588,6 +69442,105 @@ ARGUMENTS \end{chunk} +\begin{verbatim} + DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) +* +* -- 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 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 + +\end{verbatim} + \begin{chunk}{LAPACK dlange} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -50775,6 +69728,105 @@ ARGUMENTS \end{chunk} +\begin{verbatim} + DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) +* +* -- 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 NORM + INTEGER LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION 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 = 1, MIN( N, J+1 ) + 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, MIN( N, J+1 ) + 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, N + WORK( I ) = ZERO + 50 CONTINUE + DO 70 J = 1, N + DO 60 I = 1, MIN( N, J+1 ) + WORK( I ) = WORK( I ) + ABS( A( 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 + CALL DLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) + 90 CONTINUE + VALUE = SCALE*SQRT( SUM ) + END IF +* + DLANHS = VALUE + RETURN +* +* End of DLANHS +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlanhs} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -50971,6 +70023,93 @@ ARGUMENTS \end{chunk} +\begin{verbatim} + DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* February 29, 1992 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION ANORM, SCALE, SUM +* .. +* .. External Functions .. + LOGICAL LSAME + 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( D( I ) ) ) + ANORM = MAX( ANORM, ABS( E( I ) ) ) + 10 CONTINUE + ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. + $ LSAME( NORM, 'I' ) ) THEN +* +* Find norm1(A). +* + IF( N.EQ.1 ) THEN + ANORM = ABS( D( 1 ) ) + ELSE + ANORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ), + $ ABS( E( N-1 ) )+ABS( D( N ) ) ) + DO 20 I = 2, N - 1 + ANORM = MAX( ANORM, ABS( D( I ) )+ABS( E( I ) )+ + $ ABS( E( I-1 ) ) ) + 20 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + IF( N.GT.1 ) THEN + CALL DLASSQ( N-1, E, 1, SCALE, SUM ) + SUM = 2*SUM + END IF + CALL DLASSQ( N, D, 1, SCALE, SUM ) + ANORM = SCALE*SQRT( SUM ) + END IF +* + DLANST = ANORM + RETURN +* +* End of DLANST +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlanst} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -51098,38 +70237,218 @@ SYNOPSIS DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN -PURPOSE - DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric - matrix in standard form: + Purpose + ======= - [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] - [ C D ] [ SN CS ] [ CC DD ] [-SN CS ] + DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric + matrix in standard form: - 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 conju- - gate eigenvalues. + [ 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. -ARGUMENTS - A (input/output) DOUBLE PRECISION - B (input/output) DOUBLE PRECISION C (input/output) - DOUBLE PRECISION D (input/output) DOUBLE PRECISION On - entry, the elements of the input matrix. On exit, they are - overwritten by the elements of the standardised Schur form. + Arguments + ========= + + A (input/output) DOUBLE PRECISION + B (input/output) DOUBLE PRECISION + C (input/output) DOUBLE PRECISION + D (input/output) DOUBLE PRECISION + On entry, the elements of the input matrix. + On exit, they are overwritten by the elements of the + standardised Schur form. + + RT1R (output) DOUBLE PRECISION + RT1I (output) DOUBLE PRECISION + RT2R (output) DOUBLE PRECISION + RT2I (output) DOUBLE PRECISION + The real and imaginary parts of the eigenvalues. If the + eigenvalues are a complex conjugate pair, RT1I > 0. + + CS (output) DOUBLE PRECISION + SN (output) DOUBLE PRECISION + Parameters of the rotation matrix. - RT1R (output) DOUBLE PRECISION - RT1I (output) DOUBLE PRECISION RT2R (output) DOUBLE PRE- - CISION RT2I (output) DOUBLE PRECISION The real and imaginary - parts of the eigenvalues. If the eigenvalues are a complex con- - jugate pair, RT1I > 0. + Further Details + =============== - CS (output) DOUBLE PRECISION - SN (output) DOUBLE PRECISION Parameters of the rotation - matrix. + 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). \end{chunk} +\begin{verbatim} + SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) +* +* -- LAPACK driver 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 .. + 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 + +\end{verbatim} + \begin{chunk}{LAPACK dlanv2} (let* ((zero 0.0) (half 0.5) (one 1.0) (multpl 4.0)) (declare (type (double-float 0.0 0.0) zero) @@ -51275,18 +70594,66 @@ SYNOPSIS DOUBLE PRECISION X, Y -PURPOSE - DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary - overflow. + Purpose + ======= + DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary + overflow. -ARGUMENTS - X (input) DOUBLE PRECISION - Y (input) DOUBLE PRECISION X and Y specify the values x - and y. + Arguments + ========= + + X (input) DOUBLE PRECISION + Y (input) DOUBLE PRECISION + X and Y specify the values x and y. \end{chunk} +\begin{verbatim} + DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) +* +* -- 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 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 + +\end{verbatim} + \begin{chunk}{LAPACK dlapy2} (let* ((zero 0.0) (one 1.0)) (declare (type (double-float 0.0 0.0) zero) @@ -51308,6 +70675,124 @@ ARGUMENTS \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlapy3 LAPACK} +%\pagehead{dlapy3}{dlapy3} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{dlapy3.input} +)set break resume +)sys rm -f dlapy3.output +)spool dlapy3.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{dlapy3.help} +==================================================================== +dlapy3 examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) + + .. Scalar Arguments .. + DOUBLE PRECISION X, Y, Z + .. + + + Purpose: + ============= + + DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause + unnecessary overflow. + + Arguments: + ========== + + [in] X + X is DOUBLE PRECISION + + [in] Y + Y is DOUBLE PRECISION + + [in] Z + Z is DOUBLE PRECISION + X, Y and Z specify the values x, y and z. + + Authors: + ======== + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + DOUBLE PRECISION X, Y, Z +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION W, XABS, YABS, ZABS +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* + XABS = ABS( X ) + YABS = ABS( Y ) + ZABS = ABS( Z ) + W = MAX( XABS, YABS, ZABS ) + IF( W.EQ.ZERO ) THEN +* W can be zero for max(0,nan,0) +* adding all three entries together will make sure +* NaN will not disappear. + DLAPY3 = XABS + YABS + ZABS + ELSE + DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+ + $ ( ZABS / W )**2 ) + END IF + RETURN +* +* End of DLAPY3 +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK dlapy3} +\end{chunk} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlaqtr LAPACK} %\pagehead{dlaqtr}{dlaqtr} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} @@ -51348,82 +70833,678 @@ SYNOPSIS DOUBLE PRECISION B( * ), T( LDT, * ), WORK( * ), X( * ) -PURPOSE - DLAQTR solves the real quasi-triangular system + Purpose + ======= - or the complex quasi-triangular systems + DLAQTR solves the real quasi-triangular system - op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE. + op(T)*p = scale*c, if LREAL = .TRUE. - in real arithmetic, where T is upper quasi-triangular. - If LREAL = .FALSE., then the first diagonal block of T must be 1 by 1, - B is the specially structured matrix + or the complex quasi-triangular systems - B = [ b(1) b(2) ... b(n) ] - [ w ] - [ w ] - [ . ] - [ w ] + op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE. - op(A) = A or A', A' denotes the conjugate transpose of - matrix A. + in real arithmetic, where T is upper quasi-triangular. + If LREAL = .FALSE., then the first diagonal block of T must be + 1 by 1, B is the specially structured matrix - On input, X = [ c ]. On output, X = [ p ]. - [ d ] [ q ] + B = [ b(1) b(2) ... b(n) ] + [ w ] + [ w ] + [ . ] + [ w ] - This subroutine is designed for the condition number estimation in rou- - tine DTRSNA. + op(A) = A or A', A' denotes the conjugate transpose of + matrix A. + On input, X = [ c ]. On output, X = [ p ]. + [ d ] [ q ] -ARGUMENTS - LTRAN (input) LOGICAL - On entry, LTRAN specifies the option of conjugate transpose: = - .FALSE., op(T+i*B) = T+i*B, = .TRUE., op(T+i*B) = - (T+i*B)'. + This subroutine is designed for the condition number estimation + in routine DTRSNA. - LREAL (input) LOGICAL - On entry, LREAL specifies the input matrix structure: = - .FALSE., the input is complex = .TRUE., the input is - real + Arguments + ========= - N (input) INTEGER - On entry, N specifies the order of T+i*B. N >= 0. + LTRAN (input) LOGICAL + On entry, LTRAN specifies the option of conjugate transpose: + = .FALSE., op(T+i*B) = T+i*B, + = .TRUE., op(T+i*B) = (T+i*B)'. - T (input) DOUBLE PRECISION array, dimension (LDT,N) - On entry, T contains a matrix in Schur canonical form. If - LREAL = .FALSE., then the first diagonal block of T mu be 1 by - 1. + LREAL (input) LOGICAL + On entry, LREAL specifies the input matrix structure: + = .FALSE., the input is complex + = .TRUE., the input is real - LDT (input) INTEGER - The leading dimension of the matrix T. LDT >= max(1,N). + N (input) INTEGER + On entry, N specifies the order of T+i*B. N >= 0. - B (input) DOUBLE PRECISION array, dimension (N) - On entry, B contains the elements to form the matrix B as - described above. If LREAL = .TRUE., B is not referenced. + T (input) DOUBLE PRECISION array, dimension (LDT,N) + On entry, T contains a matrix in Schur canonical form. + If LREAL = .FALSE., then the first diagonal block of T mu + be 1 by 1. - W (input) DOUBLE PRECISION - On entry, W is the diagonal element of the matrix B. If LREAL - = .TRUE., W is not referenced. + LDT (input) INTEGER + The leading dimension of the matrix T. LDT >= max(1,N). - SCALE (output) DOUBLE PRECISION - On exit, SCALE is the scale factor. + B (input) DOUBLE PRECISION array, dimension (N) + On entry, B contains the elements to form the matrix + B as described above. + If LREAL = .TRUE., B is not referenced. - X (input/output) DOUBLE PRECISION array, dimension (2*N) - On entry, X contains the right hand side of the system. On - exit, X is overwritten by the solution. + W (input) DOUBLE PRECISION + On entry, W is the diagonal element of the matrix B. + If LREAL = .TRUE., W is not referenced. - WORK (workspace) DOUBLE PRECISION array, dimension (N) + SCALE (output) DOUBLE PRECISION + On exit, SCALE is the scale factor. - INFO (output) INTEGER - On exit, INFO is set to 0: successful exit. - 1: the some diagonal 1 by 1 block has been perturbed by a small - number SMIN to keep nonsingularity. 2: the some diagonal 2 by - 2 block has been perturbed by a small number in DLALN2 to keep - nonsingularity. NOTE: In the interests of speed, this routine - does not check the inputs for errors. + X (input/output) DOUBLE PRECISION array, dimension (2*N) + On entry, X contains the right hand side of the system. + On exit, X is overwritten by the solution. + + WORK (workspace) DOUBLE PRECISION array, dimension (N) + + INFO (output) INTEGER + On exit, INFO is set to + 0: successful exit. + 1: the some diagonal 1 by 1 block has been perturbed by + a small number SMIN to keep nonsingularity. + 2: the some diagonal 2 by 2 block has been perturbed by + a small number in DLALN2 to keep nonsingularity. + NOTE: In the interests of speed, this routine does not + check the inputs for errors. \end{chunk} +\begin{verbatim} + SUBROUTINE DLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, + $ INFO ) +* +* -- 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 .. + LOGICAL LREAL, LTRAN + INTEGER INFO, LDT, N + DOUBLE PRECISION SCALE, W +* .. +* .. Array Arguments .. + DOUBLE PRECISION B( * ), T( LDT, * ), WORK( * ), X( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN + INTEGER I, IERR, J, J1, J2, JNEXT, K, N1, N2 + DOUBLE PRECISION BIGNUM, EPS, REC, SCALOC, SI, SMIN, SMINW, + $ SMLNUM, SR, TJJ, TMP, XJ, XMAX, XNORM, Z +* .. +* .. Local Arrays .. + DOUBLE PRECISION D( 2, 2 ), V( 2, 2 ) +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DASUM, DDOT, DLAMCH, DLANGE + EXTERNAL IDAMAX, DASUM, DDOT, DLAMCH, DLANGE +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DLADIV, DLALN2, DSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Do not test the input parameters for errors +* + NOTRAN = .NOT.LTRAN + INFO = 0 +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Set constants to control overflow +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + BIGNUM = ONE / SMLNUM +* + XNORM = DLANGE( 'M', N, N, T, LDT, D ) + IF( .NOT.LREAL ) + $ XNORM = MAX( XNORM, ABS( W ), DLANGE( 'M', N, 1, B, N, D ) ) + SMIN = MAX( SMLNUM, EPS*XNORM ) +* +* Compute 1-norm of each column of strictly upper triangular +* part of T to control overflow in triangular solver. +* + WORK( 1 ) = ZERO + DO 10 J = 2, N + WORK( J ) = DASUM( J-1, T( 1, J ), 1 ) + 10 CONTINUE +* + IF( .NOT.LREAL ) THEN + DO 20 I = 2, N + WORK( I ) = WORK( I ) + ABS( B( I ) ) + 20 CONTINUE + END IF +* + N2 = 2*N + N1 = N + IF( .NOT.LREAL ) + $ N1 = N2 + K = IDAMAX( N1, X, 1 ) + XMAX = ABS( X( K ) ) + SCALE = ONE +* + IF( XMAX.GT.BIGNUM ) THEN + SCALE = BIGNUM / XMAX + CALL DSCAL( N1, SCALE, X, 1 ) + XMAX = BIGNUM + END IF +* + IF( LREAL ) THEN +* + IF( NOTRAN ) THEN +* +* Solve T*p = scale*c +* + JNEXT = N + DO 30 J = N, 1, -1 + IF( J.GT.JNEXT ) + $ GO TO 30 + J1 = J + J2 = J + JNEXT = J - 1 + IF( J.GT.1 ) THEN + IF( T( J, J-1 ).NE.ZERO ) THEN + J1 = J - 1 + JNEXT = J - 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* Meet 1 by 1 diagonal block +* +* Scale to avoid overflow when computing +* x(j) = b(j)/T(j,j) +* + XJ = ABS( X( J1 ) ) + TJJ = ABS( T( J1, J1 ) ) + TMP = T( J1, J1 ) + IF( TJJ.LT.SMIN ) THEN + TMP = SMIN + TJJ = SMIN + INFO = 1 + END IF +* + IF( XJ.EQ.ZERO ) + $ GO TO 30 +* + IF( TJJ.LT.ONE ) THEN + IF( XJ.GT.BIGNUM*TJJ ) THEN + REC = ONE / XJ + CALL DSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF + X( J1 ) = X( J1 ) / TMP + XJ = ABS( X( J1 ) ) +* +* Scale x if necessary to avoid overflow when adding a +* multiple of column j1 of T. +* + IF( XJ.GT.ONE ) THEN + REC = ONE / XJ + IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN + CALL DSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + END IF + END IF + IF( J1.GT.1 ) THEN + CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 ) + K = IDAMAX( J1-1, X, 1 ) + XMAX = ABS( X( K ) ) + END IF +* + ELSE +* +* Meet 2 by 2 diagonal block +* +* Call 2 by 2 linear system solve, to take +* care of possible overflow by scaling factor. +* + D( 1, 1 ) = X( J1 ) + D( 2, 1 ) = X( J2 ) + CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, T( J1, J1 ), + $ LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2, + $ SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 2 +* + IF( SCALOC.NE.ONE ) THEN + CALL DSCAL( N, SCALOC, X, 1 ) + SCALE = SCALE*SCALOC + END IF + X( J1 ) = V( 1, 1 ) + X( J2 ) = V( 2, 1 ) +* +* Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2)) +* to avoid overflow in updating right-hand side. +* + XJ = MAX( ABS( V( 1, 1 ) ), ABS( V( 2, 1 ) ) ) + IF( XJ.GT.ONE ) THEN + REC = ONE / XJ + IF( MAX( WORK( J1 ), WORK( J2 ) ).GT. + $ ( BIGNUM-XMAX )*REC ) THEN + CALL DSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + END IF + END IF +* +* Update right-hand side +* + IF( J1.GT.1 ) THEN + CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 ) + CALL DAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 ) + K = IDAMAX( J1-1, X, 1 ) + XMAX = ABS( X( K ) ) + END IF +* + END IF +* + 30 CONTINUE +* + ELSE +* +* Solve T'*p = scale*c +* + JNEXT = 1 + DO 40 J = 1, N + IF( J.LT.JNEXT ) + $ GO TO 40 + J1 = J + J2 = J + JNEXT = J + 1 + IF( J.LT.N ) THEN + IF( T( J+1, J ).NE.ZERO ) THEN + J2 = J + 1 + JNEXT = J + 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1 by 1 diagonal block +* +* Scale if necessary to avoid overflow in forming the +* right-hand side element by inner product. +* + XJ = ABS( X( J1 ) ) + IF( XMAX.GT.ONE ) THEN + REC = ONE / XMAX + IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN + CALL DSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF +* + X( J1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, 1 ) +* + XJ = ABS( X( J1 ) ) + TJJ = ABS( T( J1, J1 ) ) + TMP = T( J1, J1 ) + IF( TJJ.LT.SMIN ) THEN + TMP = SMIN + TJJ = SMIN + INFO = 1 + END IF +* + IF( TJJ.LT.ONE ) THEN + IF( XJ.GT.BIGNUM*TJJ ) THEN + REC = ONE / XJ + CALL DSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF + X( J1 ) = X( J1 ) / TMP + XMAX = MAX( XMAX, ABS( X( J1 ) ) ) +* + ELSE +* +* 2 by 2 diagonal block +* +* Scale if necessary to avoid overflow in forming the +* right-hand side elements by inner product. +* + XJ = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ) ) + IF( XMAX.GT.ONE ) THEN + REC = ONE / XMAX + IF( MAX( WORK( J2 ), WORK( J1 ) ).GT.( BIGNUM-XJ )* + $ REC ) THEN + CALL DSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF +* + D( 1, 1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, + $ 1 ) + D( 2, 1 ) = X( J2 ) - DDOT( J1-1, T( 1, J2 ), 1, X, + $ 1 ) +* + CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J1, J1 ), + $ LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2, + $ SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 2 +* + IF( SCALOC.NE.ONE ) THEN + CALL DSCAL( N, SCALOC, X, 1 ) + SCALE = SCALE*SCALOC + END IF + X( J1 ) = V( 1, 1 ) + X( J2 ) = V( 2, 1 ) + XMAX = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ), XMAX ) +* + END IF + 40 CONTINUE + END IF +* + ELSE +* + SMINW = MAX( EPS*ABS( W ), SMIN ) + IF( NOTRAN ) THEN +* +* Solve (T + iB)*(p+iq) = c+id +* + JNEXT = N + DO 70 J = N, 1, -1 + IF( J.GT.JNEXT ) + $ GO TO 70 + J1 = J + J2 = J + JNEXT = J - 1 + IF( J.GT.1 ) THEN + IF( T( J, J-1 ).NE.ZERO ) THEN + J1 = J - 1 + JNEXT = J - 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1 by 1 diagonal block +* +* Scale if necessary to avoid overflow in division +* + Z = W + IF( J1.EQ.1 ) + $ Z = B( 1 ) + XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) ) + TJJ = ABS( T( J1, J1 ) ) + ABS( Z ) + TMP = T( J1, J1 ) + IF( TJJ.LT.SMINW ) THEN + TMP = SMINW + TJJ = SMINW + INFO = 1 + END IF +* + IF( XJ.EQ.ZERO ) + $ GO TO 70 +* + IF( TJJ.LT.ONE ) THEN + IF( XJ.GT.BIGNUM*TJJ ) THEN + REC = ONE / XJ + CALL DSCAL( N2, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF + CALL DLADIV( X( J1 ), X( N+J1 ), TMP, Z, SR, SI ) + X( J1 ) = SR + X( N+J1 ) = SI + XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) ) +* +* Scale x if necessary to avoid overflow when adding a +* multiple of column j1 of T. +* + IF( XJ.GT.ONE ) THEN + REC = ONE / XJ + IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN + CALL DSCAL( N2, REC, X, 1 ) + SCALE = SCALE*REC + END IF + END IF +* + IF( J1.GT.1 ) THEN + CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 ) + CALL DAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1, + $ X( N+1 ), 1 ) +* + X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 ) + X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 ) +* + XMAX = ZERO + DO 50 K = 1, J1 - 1 + XMAX = MAX( XMAX, ABS( X( K ) )+ + $ ABS( X( K+N ) ) ) + 50 CONTINUE + END IF +* + ELSE +* +* Meet 2 by 2 diagonal block +* + D( 1, 1 ) = X( J1 ) + D( 2, 1 ) = X( J2 ) + D( 1, 2 ) = X( N+J1 ) + D( 2, 2 ) = X( N+J2 ) + CALL DLALN2( .FALSE., 2, 2, SMINW, ONE, T( J1, J1 ), + $ LDT, ONE, ONE, D, 2, ZERO, -W, V, 2, + $ SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 2 +* + IF( SCALOC.NE.ONE ) THEN + CALL DSCAL( 2*N, SCALOC, X, 1 ) + SCALE = SCALOC*SCALE + END IF + X( J1 ) = V( 1, 1 ) + X( J2 ) = V( 2, 1 ) + X( N+J1 ) = V( 1, 2 ) + X( N+J2 ) = V( 2, 2 ) +* +* Scale X(J1), .... to avoid overflow in +* updating right hand side. +* + XJ = MAX( ABS( V( 1, 1 ) )+ABS( V( 1, 2 ) ), + $ ABS( V( 2, 1 ) )+ABS( V( 2, 2 ) ) ) + IF( XJ.GT.ONE ) THEN + REC = ONE / XJ + IF( MAX( WORK( J1 ), WORK( J2 ) ).GT. + $ ( BIGNUM-XMAX )*REC ) THEN + CALL DSCAL( N2, REC, X, 1 ) + SCALE = SCALE*REC + END IF + END IF +* +* Update the right-hand side. +* + IF( J1.GT.1 ) THEN + CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 ) + CALL DAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 ) +* + CALL DAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1, + $ X( N+1 ), 1 ) + CALL DAXPY( J1-1, -X( N+J2 ), T( 1, J2 ), 1, + $ X( N+1 ), 1 ) +* + X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 ) + + $ B( J2 )*X( N+J2 ) + X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 ) - + $ B( J2 )*X( J2 ) +* + XMAX = ZERO + DO 60 K = 1, J1 - 1 + XMAX = MAX( ABS( X( K ) )+ABS( X( K+N ) ), + $ XMAX ) + 60 CONTINUE + END IF +* + END IF + 70 CONTINUE +* + ELSE +* +* Solve (T + iB)'*(p+iq) = c+id +* + JNEXT = 1 + DO 80 J = 1, N + IF( J.LT.JNEXT ) + $ GO TO 80 + J1 = J + J2 = J + JNEXT = J + 1 + IF( J.LT.N ) THEN + IF( T( J+1, J ).NE.ZERO ) THEN + J2 = J + 1 + JNEXT = J + 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1 by 1 diagonal block +* +* Scale if necessary to avoid overflow in forming the +* right-hand side element by inner product. +* + XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) ) + IF( XMAX.GT.ONE ) THEN + REC = ONE / XMAX + IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN + CALL DSCAL( N2, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF +* + X( J1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, 1 ) + X( N+J1 ) = X( N+J1 ) - DDOT( J1-1, T( 1, J1 ), 1, + $ X( N+1 ), 1 ) + IF( J1.GT.1 ) THEN + X( J1 ) = X( J1 ) - B( J1 )*X( N+1 ) + X( N+J1 ) = X( N+J1 ) + B( J1 )*X( 1 ) + END IF + XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) ) +* + Z = W + IF( J1.EQ.1 ) + $ Z = B( 1 ) +* +* Scale if necessary to avoid overflow in +* complex division +* + TJJ = ABS( T( J1, J1 ) ) + ABS( Z ) + TMP = T( J1, J1 ) + IF( TJJ.LT.SMINW ) THEN + TMP = SMINW + TJJ = SMINW + INFO = 1 + END IF +* + IF( TJJ.LT.ONE ) THEN + IF( XJ.GT.BIGNUM*TJJ ) THEN + REC = ONE / XJ + CALL DSCAL( N2, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF + CALL DLADIV( X( J1 ), X( N+J1 ), TMP, -Z, SR, SI ) + X( J1 ) = SR + X( J1+N ) = SI + XMAX = MAX( ABS( X( J1 ) )+ABS( X( J1+N ) ), XMAX ) +* + ELSE +* +* 2 by 2 diagonal block +* +* Scale if necessary to avoid overflow in forming the +* right-hand side element by inner product. +* + XJ = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ), + $ ABS( X( J2 ) )+ABS( X( N+J2 ) ) ) + IF( XMAX.GT.ONE ) THEN + REC = ONE / XMAX + IF( MAX( WORK( J1 ), WORK( J2 ) ).GT. + $ ( BIGNUM-XJ ) / XMAX ) THEN + CALL DSCAL( N2, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF +* + D( 1, 1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, + $ 1 ) + D( 2, 1 ) = X( J2 ) - DDOT( J1-1, T( 1, J2 ), 1, X, + $ 1 ) + D( 1, 2 ) = X( N+J1 ) - DDOT( J1-1, T( 1, J1 ), 1, + $ X( N+1 ), 1 ) + D( 2, 2 ) = X( N+J2 ) - DDOT( J1-1, T( 1, J2 ), 1, + $ X( N+1 ), 1 ) + D( 1, 1 ) = D( 1, 1 ) - B( J1 )*X( N+1 ) + D( 2, 1 ) = D( 2, 1 ) - B( J2 )*X( N+1 ) + D( 1, 2 ) = D( 1, 2 ) + B( J1 )*X( 1 ) + D( 2, 2 ) = D( 2, 2 ) + B( J2 )*X( 1 ) +* + CALL DLALN2( .TRUE., 2, 2, SMINW, ONE, T( J1, J1 ), + $ LDT, ONE, ONE, D, 2, ZERO, W, V, 2, + $ SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 2 +* + IF( SCALOC.NE.ONE ) THEN + CALL DSCAL( N2, SCALOC, X, 1 ) + SCALE = SCALOC*SCALE + END IF + X( J1 ) = V( 1, 1 ) + X( J2 ) = V( 2, 1 ) + X( N+J1 ) = V( 1, 2 ) + X( N+J2 ) = V( 2, 2 ) + XMAX = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ), + $ ABS( X( J2 ) )+ABS( X( N+J2 ) ), XMAX ) +* + END IF +* + 80 CONTINUE +* + END IF +* + END IF +* + RETURN +* +* End of DLAQTR +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlaqtr} (let* ((zero 0.0) (one 1.0)) (declare (type (double-float 0.0 0.0) zero) @@ -52601,73 +72682,600 @@ SYNOPSIS DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), WORK( LDWORK, * ) -PURPOSE - DLARFB applies a real block reflector H or its transpose H' to a real m - by n matrix C, from either the left or the right. + Purpose + ======= + DLARFB applies a real block reflector H or its transpose H' to a + real m by n matrix C, from either the left or the right. -ARGUMENTS - SIDE (input) CHARACTER*1 - = 'L': apply H or H' from the Left - = 'R': apply H or H' from the Right + Arguments + ========= - TRANS (input) CHARACTER*1 - = 'N': apply H (No transpose) - = 'T': apply H' (Transpose) + SIDE (input) CHARACTER*1 + = 'L': apply H or H' from the Left + = 'R': apply H or H' from the Right - DIRECT (input) CHARACTER*1 - Indicates how H is formed from a product of elementary reflec- - tors = 'F': H = H(1) H(2) . . . H(k) (Forward) - = 'B': H = H(k) . . . H(2) H(1) (Backward) + TRANS (input) CHARACTER*1 + = 'N': apply H (No transpose) + = 'T': apply H' (Transpose) - STOREV (input) CHARACTER*1 - Indicates how the vectors which define the elementary reflec- - tors are stored: - = 'C': Columnwise - = 'R': Rowwise + DIRECT (input) 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) - M (input) INTEGER - The number of rows of the matrix C. + STOREV (input) CHARACTER*1 + Indicates how the vectors which define the elementary + reflectors are stored: + = 'C': Columnwise + = 'R': Rowwise - N (input) INTEGER - The number of columns of the matrix C. + M (input) INTEGER + The number of rows of the matrix C. - K (input) INTEGER - The order of the matrix T (= the number of elementary reflec- - tors whose product defines the block reflector). + N (input) INTEGER + The number of columns of the matrix C. - V (input) 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 fur- - ther details. + K (input) INTEGER + The order of the matrix T (= the number of elementary + reflectors whose product defines the block reflector). - LDV (input) 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. + V (input) 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. - T (input) DOUBLE PRECISION array, dimension (LDT,K) - The triangular k by k matrix T in the representation of the - block reflector. + LDV (input) 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. - LDT (input) INTEGER - The leading dimension of the array T. LDT >= K. + T (input) DOUBLE PRECISION array, dimension (LDT,K) + The triangular k by k matrix T in the representation of the + block reflector. - C (input/output) DOUBLE PRECISION array, dimension (LDC,N) - On entry, the m by n matrix C. On exit, C is overwritten by - H*C or H'*C or C*H or C*H'. + LDT (input) INTEGER + The leading dimension of the array T. LDT >= K. - LDC (input) INTEGER - The leading dimension of the array C. LDA >= max(1,M). + C (input/output) DOUBLE PRECISION array, dimension (LDC,N) + On entry, the m by n matrix C. + On exit, C is overwritten by H*C or H'*C or C*H or C*H'. + + LDC (input) INTEGER + The leading dimension of the array C. LDA >= max(1,M). - WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) + WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) - LDWORK (input) INTEGER - The leading dimension of the array WORK. If SIDE = 'L', LDWORK - >= max(1,N); if SIDE = 'R', LDWORK >= max(1,M). + LDWORK (input) INTEGER + The leading dimension of the array WORK. + If SIDE = 'L', LDWORK >= max(1,N); + if SIDE = 'R', LDWORK >= max(1,M). \end{chunk} +\begin{verbatim} + SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, + $ T, LDT, C, LDC, WORK, LDWORK ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* February 29, 1992 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, SIDE, STOREV, TRANS + INTEGER K, LDC, LDT, LDV, LDWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), + $ WORK( LDWORK, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + CHARACTER TRANST + INTEGER I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DTRMM +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( M.LE.0 .OR. N.LE.0 ) + $ RETURN +* + IF( LSAME( TRANS, 'N' ) ) THEN + TRANST = 'T' + ELSE + TRANST = 'N' + END IF +* + IF( LSAME( STOREV, 'C' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 ) (first K rows) +* ( V2 ) +* where V1 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H' * C where C = ( C1 ) +* ( C2 ) +* +* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) +* +* W := C1' +* + DO 10 J = 1, K + CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 10 CONTINUE +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C2'*V2 +* + CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, + $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T' or W * T +* + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W' +* + IF( M.GT.K ) THEN +* +* C2 := C2 - V2 * W' +* + CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, + $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1' +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, + $ ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W' +* + DO 30 J = 1, K + DO 20 I = 1, N + C( J, I ) = C( J, I ) - WORK( I, J ) + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H' where C = ( C1 C2 ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C1 +* + DO 40 J = 1, K + CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) + 40 CONTINUE +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C2 * V2 +* + CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T' +* + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V' +* + IF( N.GT.K ) THEN +* +* C2 := C2 - W * V2' +* + CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1' +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, + $ ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 60 J = 1, K + DO 50 I = 1, M + C( I, J ) = C( I, J ) - WORK( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF +* + ELSE +* +* Let V = ( V1 ) +* ( V2 ) (last K rows) +* where V2 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H' * C where C = ( C1 ) +* ( C2 ) +* +* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) +* +* W := C2' +* + DO 70 J = 1, K + CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + 70 CONTINUE +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C1'*V1 +* + CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T' or W * T +* + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W' +* + IF( M.GT.K ) THEN +* +* C1 := C1 - V1 * W' +* + CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, + $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) + END IF +* +* W := W * V2' +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) +* +* C2 := C2 - W' +* + DO 90 J = 1, K + DO 80 I = 1, N + C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H' where C = ( C1 C2 ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C2 +* + DO 100 J = 1, K + CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) + 100 CONTINUE +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C1 * V1 +* + CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T' +* + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V' +* + IF( N.GT.K ) THEN +* +* C1 := C1 - W * V1' +* + CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) + END IF +* +* W := W * V2' +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, + $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) +* +* C2 := C2 - W +* + DO 120 J = 1, K + DO 110 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) + 110 CONTINUE + 120 CONTINUE + END IF + END IF +* + ELSE IF( LSAME( STOREV, 'R' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 V2 ) (V1: first K columns) +* where V1 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H' * C where C = ( C1 ) +* ( C2 ) +* +* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) +* +* W := C1' +* + DO 130 J = 1, K + CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 130 CONTINUE +* +* W := W * V1' +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C2'*V2' +* + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, + $ WORK, LDWORK ) + END IF +* +* W := W * T' or W * T +* + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V' * W' +* + IF( M.GT.K ) THEN +* +* C2 := C2 - V2' * W' +* + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, + $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W' +* + DO 150 J = 1, K + DO 140 I = 1, N + C( J, I ) = C( J, I ) - WORK( I, J ) + 140 CONTINUE + 150 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H' where C = ( C1 C2 ) +* +* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) +* +* W := C1 +* + DO 160 J = 1, K + CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) + 160 CONTINUE +* +* W := W * V1' +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C2 * V2' +* + CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T' +* + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( N.GT.K ) THEN +* +* C2 := C2 - W * V2 +* + CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 180 J = 1, K + DO 170 I = 1, M + C( I, J ) = C( I, J ) - WORK( I, J ) + 170 CONTINUE + 180 CONTINUE +* + END IF +* + ELSE +* +* Let V = ( V1 V2 ) (V2: last K columns) +* where V2 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H' * C where C = ( C1 ) +* ( C2 ) +* +* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) +* +* W := C2' +* + DO 190 J = 1, K + CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + 190 CONTINUE +* +* W := W * V2' +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, + $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C1'*V1' +* + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T' or W * T +* + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V' * W' +* + IF( M.GT.K ) THEN +* +* C1 := C1 - V1' * W' +* + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, + $ V, LDV, WORK, LDWORK, ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) +* +* C2 := C2 - W' +* + DO 210 J = 1, K + DO 200 I = 1, N + C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) + 200 CONTINUE + 210 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H' where C = ( C1 C2 ) +* +* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) +* +* W := C2 +* + DO 220 J = 1, K + CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) + 220 CONTINUE +* +* W := W * V2' +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, + $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C1 * V1' +* + CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T' +* + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( N.GT.K ) THEN +* +* C1 := C1 - W * V1 +* + CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 240 J = 1, K + DO 230 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) + 230 CONTINUE + 240 CONTINUE +* + END IF +* + END IF + END IF +* + RETURN +* +* End of DLARFB +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlarfb} (let* ((one 1.0)) (declare (type (double-float 1.0 1.0) one)) @@ -53304,45 +73912,150 @@ SYNOPSIS DOUBLE PRECISION X( * ) -PURPOSE - DLARFG generates a real elementary reflector H of order n, such that - ( x ) ( 0 ) + Purpose + ======= - where alpha and beta are scalars, and x is an (n-1)-element real vec- - tor. H is represented in the form + DLARFG generates a real elementary reflector H of order n, such + that - H = I - tau * ( 1 ) * ( 1 v' ) , - ( v ) + H * ( alpha ) = ( beta ), H' * H = I. + ( x ) ( 0 ) - where tau is a real scalar and v is a real (n-1)-element - vector. + where alpha and beta are scalars, and x is an (n-1)-element real + vector. H is represented in the form - If the elements of x are all zero, then tau = 0 and H is taken to be - the unit matrix. + H = I - tau * ( 1 ) * ( 1 v' ) , + ( v ) - Otherwise 1 <= tau <= 2. + 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. -ARGUMENTS - N (input) INTEGER - The order of the elementary reflector. + Otherwise 1 <= tau <= 2. + + Arguments + ========= - ALPHA (input/output) DOUBLE PRECISION - On entry, the value alpha. On exit, it is overwritten with the - value beta. + N (input) INTEGER + The order of the elementary reflector. - X (input/output) DOUBLE PRECISION array, dimension - (1+(N-2)*abs(INCX)) On entry, the vector x. On exit, it is - overwritten with the vector v. + ALPHA (input/output) DOUBLE PRECISION + On entry, the value alpha. + On exit, it is overwritten with the value beta. - INCX (input) INTEGER - The increment between elements of X. INCX > 0. + X (input/output) DOUBLE PRECISION array, dimension + (1+(N-2)*abs(INCX)) + On entry, the vector x. + On exit, it is overwritten with the vector v. - TAU (output) DOUBLE PRECISION - The value tau. + INCX (input) INTEGER + The increment between elements of X. INCX > 0. + + TAU (output) DOUBLE PRECISION + The value tau. \end{chunk} +\begin{verbatim} + SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* September 30, 1994 +* +* .. 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' ) + IF( ABS( BETA ).LT.SAFMIN ) THEN +* +* XNORM, BETA may be inaccurate; scale X and recompute them +* + RSAFMN = ONE / SAFMIN + KNT = 0 + 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 ) + TAU = ( BETA-ALPHA ) / BETA + CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) +* +* If ALPHA is subnormal, it may lose relative accuracy +* + ALPHA = BETA + DO 20 J = 1, KNT + ALPHA = ALPHA*SAFMIN + 20 CONTINUE + ELSE + TAU = ( BETA-ALPHA ) / BETA + CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) + ALPHA = BETA + END IF + END IF +* + RETURN +* +* End of DLARFG +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlarfg} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -53434,51 +74147,128 @@ SYNOPSIS DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) -PURPOSE - 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 + Purpose + ======= - H = I - tau * v * v' + 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 - where tau is a real scalar and v is a real vector. + H = I - tau * v * v' - If tau = 0, then H is taken to be the unit matrix. + where tau is a real scalar and v is a real vector. + If tau = 0, then H is taken to be the unit matrix. -ARGUMENTS - SIDE (input) CHARACTER*1 - = 'L': form H * C - = 'R': form C * H + Arguments + ========= - M (input) INTEGER - The number of rows of the matrix C. + SIDE (input) CHARACTER*1 + = 'L': form H * C + = 'R': form C * H - N (input) INTEGER - The number of columns of the matrix C. + M (input) INTEGER + The number of rows of the matrix C. - V (input) 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. + N (input) INTEGER + The number of columns of the matrix C. - INCV (input) INTEGER - The increment between elements of v. INCV <> 0. + V (input) 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. - TAU (input) DOUBLE PRECISION - The value tau in the representation of H. + INCV (input) INTEGER + The increment between elements of v. INCV <> 0. - C (input/output) 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'. + TAU (input) DOUBLE PRECISION + The value tau in the representation of H. - LDC (input) INTEGER - The leading dimension of the array C. LDC >= max(1,M). + C (input/output) 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'. - WORK (workspace) DOUBLE PRECISION array, dimension - (N) if SIDE = 'L' or (M) if SIDE = 'R' + LDC (input) INTEGER + The leading dimension of the array C. LDC >= max(1,M). + + WORK (workspace) DOUBLE PRECISION array, dimension + (N) if SIDE = 'L' + or (M) if SIDE = 'R' \end{chunk} +\begin{verbatim} + SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* February 29, 1992 +* +* .. 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 ) +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DGER +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C +* + IF( TAU.NE.ZERO ) THEN +* +* w := C' * v +* + CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO, + $ WORK, 1 ) +* +* C := C - v * w' +* + CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC ) + END IF + ELSE +* +* Form C * H +* + IF( TAU.NE.ZERO ) THEN +* +* w := C * v +* + CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV, + $ ZERO, WORK, 1 ) +* +* C := C - w * v' +* + CALL DGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC ) + END IF + END IF + RETURN +* +* End of DLARF +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlarf} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -53547,89 +74337,230 @@ SYNOPSIS DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) -PURPOSE - 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. + Purpose + ======= - If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; + 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 = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. + If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper 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 + If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. - H = I - V * T * V' + If STOREV = 'C', the vector which defines the elementary reflector + H(i) is stored in the i-th column of the array V, and - 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 * V' - H = I - V' * T * V + 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 * V -ARGUMENTS - DIRECT (input) CHARACTER*1 - Specifies the order in which the elementary reflectors are mul- - tiplied to form the block reflector: - = 'F': H = H(1) H(2) . . . H(k) (Forward) - = 'B': H = H(k) . . . H(2) H(1) (Backward) + Arguments + ========= - STOREV (input) CHARACTER*1 - Specifies how the vectors which define the elementary reflec- - tors are stored (see also Further Details): - = 'R': rowwise + DIRECT (input) 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) - N (input) INTEGER - The order of the block reflector H. N >= 0. + STOREV (input) CHARACTER*1 + Specifies how the vectors which define the elementary + reflectors are stored (see also Further Details): + = 'C': columnwise + = 'R': rowwise - K (input) INTEGER - The order of the triangular factor T (= the number of elemen- - tary reflectors). K >= 1. + N (input) INTEGER + The order of the block reflector H. N >= 0. - V (input/output) DOUBLE PRECISION array, dimension - (LDV,K) if STOREV = 'C' (LDV,N) if STOREV = 'R' The matrix V. - See further details. + K (input) INTEGER + The order of the triangular factor T (= the number of + elementary reflectors). K >= 1. - LDV (input) INTEGER - The leading dimension of the array V. If STOREV = 'C', LDV >= - max(1,N); if STOREV = 'R', LDV >= K. + V (input/output) DOUBLE PRECISION array, dimension + (LDV,K) if STOREV = 'C' + (LDV,N) if STOREV = 'R' + The matrix V. See further details. - TAU (input) DOUBLE PRECISION array, dimension (K) - TAU(i) must contain the scalar factor of the elementary reflec- - tor H(i). + LDV (input) INTEGER + The leading dimension of the array V. + If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. - T (output) 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. + TAU (input) DOUBLE PRECISION array, dimension (K) + TAU(i) must contain the scalar factor of the elementary + reflector H(i). - LDT (input) INTEGER - The leading dimension of the array T. LDT >= K. + T (output) 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. -FURTHER DETAILS - 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. + LDT (input) INTEGER + The leading dimension of the array T. LDT >= K. + + Further Details + =============== + + 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': + 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 ) + 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': + 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 ) + 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 ) \end{chunk} +\begin{verbatim} + SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* February 29, 1992 +* +* .. 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 + DOUBLE PRECISION VII +* .. +* .. 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 + DO 20 I = 1, K + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 10 J = 1, I + T( J, I ) = ZERO + 10 CONTINUE + ELSE +* +* general case +* + VII = V( I, I ) + V( I, I ) = ONE + IF( LSAME( STOREV, 'C' ) ) THEN +* +* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) +* + CALL DGEMV( 'Transpose', N-I+1, I-1, -TAU( I ), + $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, + $ T( 1, I ), 1 ) + ELSE +* +* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' +* + CALL DGEMV( 'No transpose', I-1, N-I+1, -TAU( I ), + $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, + $ T( 1, I ), 1 ) + END IF + V( I, I ) = VII +* +* 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 ) + END IF + 20 CONTINUE + ELSE + DO 40 I = K, 1, -1 + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 30 J = I, K + T( J, I ) = ZERO + 30 CONTINUE + ELSE +* +* general case +* + IF( I.LT.K ) THEN + IF( LSAME( STOREV, 'C' ) ) THEN + VII = V( N-K+I, I ) + V( N-K+I, I ) = ONE +* +* T(i+1:k,i) := +* - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) +* + CALL DGEMV( 'Transpose', N-K+I, K-I, -TAU( I ), + $ V( 1, I+1 ), LDV, V( 1, I ), 1, ZERO, + $ T( I+1, I ), 1 ) + V( N-K+I, I ) = VII + ELSE + VII = V( I, N-K+I ) + V( I, N-K+I ) = ONE +* +* T(i+1:k,i) := +* - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' +* + CALL DGEMV( 'No transpose', K-I, N-K+I, -TAU( I ), + $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO, + $ T( I+1, I ), 1 ) + V( I, N-K+I ) = VII + 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 ) + END IF + T( I, I ) = TAU( I ) + END IF + 40 CONTINUE + END IF + RETURN +* +* End of DLARFT +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlarft} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -53901,49 +74832,651 @@ SYNOPSIS DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) -PURPOSE - 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 + Purpose + ======= - H = I - tau * v * v' + 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 - where tau is a real scalar and v is a real vector. + H = I - tau * v * v' - If tau = 0, then H is taken to be the unit matrix + where tau is a real scalar and v is a real vector. - This version uses inline code if H has order < 11. + If tau = 0, then H is taken to be the unit matrix + This version uses inline code if H has order < 11. -ARGUMENTS - SIDE (input) CHARACTER*1 - = 'L': form H * C - = 'R': form C * H + Arguments + ========= - M (input) INTEGER - The number of rows of the matrix C. + SIDE (input) CHARACTER*1 + = 'L': form H * C + = 'R': form C * H - N (input) INTEGER - The number of columns of the matrix C. + M (input) INTEGER + The number of rows of the matrix C. - V (input) DOUBLE PRECISION array, dimension (M) if SIDE = 'L' - or (N) if SIDE = 'R' The vector v in the representation of H. + N (input) INTEGER + The number of columns of the matrix C. - TAU (input) DOUBLE PRECISION - The value tau in the representation of H. + V (input) DOUBLE PRECISION array, dimension (M) if SIDE = 'L' + or (N) if SIDE = 'R' + The vector v in the representation of H. - C (input/output) 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'. + TAU (input) DOUBLE PRECISION + The value tau in the representation of H. - LDC (input) INTEGER - The leading dimension of the array C. LDA >= (1,M). + C (input/output) 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'. - WORK (workspace) DOUBLE PRECISION array, dimension - (N) if SIDE = 'L' or (M) if SIDE = 'R' WORK is not referenced - if H has order < 11. + LDC (input) INTEGER + The leading dimension of the array C. LDA >= (1,M). + + WORK (workspace) DOUBLE PRECISION array, dimension + (N) if SIDE = 'L' + or (M) if SIDE = 'R' + WORK is not referenced if H has order < 11. \end{chunk} +\begin{verbatim} + SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* February 29, 1992 +* +* .. 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 DGEMV, DGER +* .. +* .. 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 +* +* w := C'*v +* + CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, 1, ZERO, WORK, + $ 1 ) +* +* C := C - tau * v * w' +* + CALL DGER( M, N, -TAU, V, 1, WORK, 1, C, LDC ) + 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 +* +* w := C * v +* + CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, 1, ZERO, + $ WORK, 1 ) +* +* C := C - tau * w * v' +* + CALL DGER( M, N, -TAU, WORK, 1, V, 1, C, LDC ) + 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 + +\end{verbatim} + \begin{chunk}{LAPACK dlarfx} (let* ((zero 0.0) (one 1.0)) (declare (type (double-float 0.0 0.0) zero) @@ -56022,39 +77555,155 @@ SYNOPSIS DOUBLE PRECISION CS, F, G, R, SN -PURPOSE - DLARTG generate a plane rotation so that - [ -SN CS ] [ G ] [ 0 ] + Purpose + ======= - 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). + DLARTG generate a plane rotation so that - If F exceeds G in magnitude, CS will be positive. + [ 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). -ARGUMENTS - F (input) DOUBLE PRECISION - The first component of vector to be rotated. + If F exceeds G in magnitude, CS will be positive. - G (input) DOUBLE PRECISION - The second component of vector to be rotated. + Arguments + ========= + + F (input) DOUBLE PRECISION + The first component of vector to be rotated. + + G (input) DOUBLE PRECISION + The second component of vector to be rotated. - CS (output) DOUBLE PRECISION - The cosine of the rotation. + CS (output) DOUBLE PRECISION + The cosine of the rotation. - SN (output) DOUBLE PRECISION - The sine of the rotation. + SN (output) DOUBLE PRECISION + The sine of the rotation. - R (output) DOUBLE PRECISION - The nonzero component of the rotated vector. + R (output) DOUBLE PRECISION + The nonzero component of the rotated vector. \end{chunk} +\begin{verbatim} + SUBROUTINE DLARTG( F, G, CS, SN, R ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* September 30, 1994 +* +* .. 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 + FIRST = .FALSE. + SAFMIN = DLAMCH( 'S' ) + EPS = DLAMCH( 'E' ) + SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / + $ LOG( DLAMCH( 'B' ) ) / TWO ) + SAFMX2 = ONE / SAFMN2 + 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 + +\end{verbatim} + \begin{chunk}{LAPACK dlartg} (let* ((zero 0.0) (one 1.0) (two 2.0)) (declare (type (double-float 0.0 0.0) zero) @@ -56214,6 +77863,86 @@ FURTHER DETAILS \end{chunk} +\begin{verbatim} + SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* September 30, 1994 +* +* .. 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 + +\end{verbatim} + \begin{chunk}{LAPACK dlas2} (let* ((zero 0.0) (one 1.0) (two 2.0)) (declare (type (double-float 0.0 0.0) zero) @@ -56310,60 +78039,279 @@ SYNOPSIS DOUBLE PRECISION A( LDA, * ) -PURPOSE - 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. - + Purpose + ======= + + 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. + + Arguments + ========= + + TYPE (input) 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. + + KL (input) INTEGER + The lower bandwidth of A. Referenced only if TYPE = 'B', + 'Q' or 'Z'. + + KU (input) INTEGER + The upper bandwidth of A. Referenced only if TYPE = 'B', + 'Q' or 'Z'. + + CFROM (input) DOUBLE PRECISION + CTO (input) 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. + + M (input) INTEGER + The number of rows of the matrix A. M >= 0. + + N (input) INTEGER + The number of columns of the matrix A. N >= 0. + + A (input/output) DOUBLE PRECISION array, dimension (LDA,M) + The matrix to be multiplied by CTO/CFROM. See TYPE for the + storage type. + + LDA (input) INTEGER + The leading dimension of the array A. LDA >= max(1,M). + + INFO (output) INTEGER + 0 - successful exit + <0 - if INFO = -i, the i-th argument had an illegal value. -ARGUMENTS - TYPE (input) 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. - - KL (input) INTEGER - The lower bandwidth of A. Referenced only if TYPE = 'B', 'Q' - or 'Z'. - - KU (input) INTEGER - The upper bandwidth of A. Referenced only if TYPE = 'B', 'Q' - or 'Z'. - - CFROM (input) DOUBLE PRECISION - CTO (input) 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. - - M (input) INTEGER - The number of rows of the matrix A. M >= 0. - - N (input) INTEGER - The number of columns of the matrix A. N >= 0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - The matrix to be multiplied by CTO/CFROM. See TYPE for the - storage type. - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,M). +\end{chunk} - INFO (output) INTEGER - 0 - successful exit <0 - if INFO = -i, the i-th argument had - an illegal value. +\begin{verbatim} + SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* February 29, 1992 +* +* .. 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 + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +* .. +* .. 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 ) THEN + INFO = -4 + 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 + CTO1 = CTOC / BIGNUM + 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 +* + 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 -\end{chunk} +\end{verbatim} \begin{chunk}{LAPACK dlascl} (let* ((zero 0.0) (one 1.0)) @@ -56667,63 +78615,243 @@ SYNOPSIS DOUBLE PRECISION D( * ), E( * ), U( LDU, * ), VT( LDVT, * ), WORK( * ) -PURPOSE - Using a divide and conquer approach, DLASD0 computes the singular value - decomposition (SVD) of a real upper bidiagonal N-by-M matrix B with - diagonal D and offdiagonal E, where M = N + SQRE. The algorithm com- - putes orthogonal matrices U and VT such that B = U * S * VT. The singu- - lar values S are overwritten on D. + Purpose + ======= - A related subroutine, DLASDA, computes only the singular values, and - optionally, the singular vectors in compact form. + Using a divide and conquer approach, DLASD0 computes the singular + value decomposition (SVD) of a real upper bidiagonal N-by-M + matrix B with diagonal D and offdiagonal E, where M = N + SQRE. + The algorithm computes orthogonal matrices U and VT such that + B = U * S * VT. The singular values S are overwritten on D. + A related subroutine, DLASDA, computes only the singular values, + and optionally, the singular vectors in compact form. -ARGUMENTS - N (input) INTEGER - On entry, the row dimension of the upper bidiagonal matrix. - This is also the dimension of the main diagonal array D. + Arguments + ========= - SQRE (input) INTEGER - Specifies the column dimension of the bidiagonal matrix. = 0: - The bidiagonal matrix has column dimension M = N; - = 1: The bidiagonal matrix has column dimension M = N+1; + N (input) INTEGER + On entry, the row dimension of the upper bidiagonal matrix. + This is also the dimension of the main diagonal array D. - D (input/output) DOUBLE PRECISION array, dimension (N) - On entry D contains the main diagonal of the bidiagonal matrix. - On exit D, if INFO = 0, contains its singular values. + SQRE (input) INTEGER + Specifies the column dimension of the bidiagonal matrix. + = 0: The bidiagonal matrix has column dimension M = N; + = 1: The bidiagonal matrix has column dimension M = N+1; - E (input) DOUBLE PRECISION array, dimension (M-1) - Contains the subdiagonal entries of the bidiagonal matrix. On - exit, E has been destroyed. + D (input/output) DOUBLE PRECISION array, dimension (N) + On entry D contains the main diagonal of the bidiagonal + matrix. + On exit D, if INFO = 0, contains its singular values. - U (output) DOUBLE PRECISION array, dimension at least (LDQ, N) - On exit, U contains the left singular vectors. + E (input) DOUBLE PRECISION array, dimension (M-1) + Contains the subdiagonal entries of the bidiagonal matrix. + On exit, E has been destroyed. - LDU (input) INTEGER - On entry, leading dimension of U. + U (output) DOUBLE PRECISION array, dimension at least (LDQ, N) + On exit, U contains the left singular vectors. - VT (output) DOUBLE PRECISION array, dimension at least (LDVT, M) - On exit, VT' contains the right singular vectors. + LDU (input) INTEGER + On entry, leading dimension of U. - LDVT (input) INTEGER - On entry, leading dimension of VT. + VT (output) DOUBLE PRECISION array, dimension at least (LDVT, M) + On exit, VT' contains the right singular vectors. - SMLSIZ (input) INTEGER On entry, maximum size of the subproblems - at the bottom of the computation tree. + LDVT (input) INTEGER + On entry, leading dimension of VT. - IWORK (workspace) INTEGER work array. - Dimension must be at least (8 * N) + SMLSIZ (input) INTEGER + On entry, maximum size of the subproblems at the + bottom of the computation tree. - WORK (workspace) DOUBLE PRECISION work array. - Dimension must be at least (3 * M**2 + 2 * M) + IWORK INTEGER work array. + Dimension must be at least (8 * N) - INFO (output) INTEGER - = 0: successful exit. - < 0: if INFO = -i, the i-th argument had an illegal value. - > 0: if INFO = 1, an singular value did not converge + WORK DOUBLE PRECISION work array. + Dimension must be at least (3 * M**2 + 2 * M) + + INFO (output) INTEGER + = 0: successful exit. + < 0: if INFO = -i, the i-th argument had an illegal value. + > 0: if INFO = 1, an singular value did not converge + + Further Details + =============== + + Based on contributions by + Ming Gu and Huan Ren, Computer Science Division, University of + California at Berkeley, USA \end{chunk} +\begin{verbatim} + SUBROUTINE DLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, + $ WORK, INFO ) +* +* -- 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 .. + INTEGER INFO, LDU, LDVT, N, SMLSIZ, SQRE +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), U( LDU, * ), VT( LDVT, * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK, + $ J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR, + $ NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI + DOUBLE PRECISION ALPHA, BETA +* .. +* .. External Subroutines .. + EXTERNAL DLASD1, DLASDQ, DLASDT, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -2 + END IF +* + M = N + SQRE +* + IF( LDU.LT.N ) THEN + INFO = -6 + ELSE IF( LDVT.LT.M ) THEN + INFO = -8 + ELSE IF( SMLSIZ.LT.3 ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD0', -INFO ) + RETURN + END IF +* +* If the input matrix is too small, call DLASDQ to find the SVD. +* + IF( N.LE.SMLSIZ ) THEN + CALL DLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDVT, U, LDU, U, + $ LDU, WORK, INFO ) + RETURN + END IF +* +* Set up the computation tree. +* + INODE = 1 + NDIML = INODE + N + NDIMR = NDIML + N + IDXQ = NDIMR + N + IWK = IDXQ + N + CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ), + $ IWORK( NDIMR ), SMLSIZ ) +* +* For the nodes on bottom level of the tree, solve +* their subproblems by DLASDQ. +* + NDB1 = ( ND+1 ) / 2 + NCC = 0 + DO 30 I = NDB1, ND +* +* IC : center row of each node +* NL : number of rows of left subproblem +* NR : number of rows of right subproblem +* NLF: starting row of the left subproblem +* NRF: starting row of the right subproblem +* + I1 = I - 1 + IC = IWORK( INODE+I1 ) + NL = IWORK( NDIML+I1 ) + NLP1 = NL + 1 + NR = IWORK( NDIMR+I1 ) + NRP1 = NR + 1 + NLF = IC - NL + NRF = IC + 1 + SQREI = 1 + CALL DLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ), E( NLF ), + $ VT( NLF, NLF ), LDVT, U( NLF, NLF ), LDU, + $ U( NLF, NLF ), LDU, WORK, INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + ITEMP = IDXQ + NLF - 2 + DO 10 J = 1, NL + IWORK( ITEMP+J ) = J + 10 CONTINUE + IF( I.EQ.ND ) THEN + SQREI = SQRE + ELSE + SQREI = 1 + END IF + NRP1 = NR + SQREI + CALL DLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ), E( NRF ), + $ VT( NRF, NRF ), LDVT, U( NRF, NRF ), LDU, + $ U( NRF, NRF ), LDU, WORK, INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + ITEMP = IDXQ + IC + DO 20 J = 1, NR + IWORK( ITEMP+J-1 ) = J + 20 CONTINUE + 30 CONTINUE +* +* Now conquer each subproblem bottom-up. +* + DO 50 LVL = NLVL, 1, -1 +* +* Find the first node LF and last node LL on the +* current level LVL. +* + IF( LVL.EQ.1 ) THEN + LF = 1 + LL = 1 + ELSE + LF = 2**( LVL-1 ) + LL = 2*LF - 1 + END IF + DO 40 I = LF, LL + IM1 = I - 1 + IC = IWORK( INODE+IM1 ) + NL = IWORK( NDIML+IM1 ) + NR = IWORK( NDIMR+IM1 ) + NLF = IC - NL + IF( ( SQRE.EQ.0 ) .AND. ( I.EQ.LL ) ) THEN + SQREI = SQRE + ELSE + SQREI = 1 + END IF + IDXQC = IDXQ + NLF - 1 + ALPHA = D( IC ) + BETA = E( IC ) + CALL DLASD1( NL, NR, SQREI, D( NLF ), ALPHA, BETA, + $ U( NLF, NLF ), LDU, VT( NLF, NLF ), LDVT, + $ IWORK( IDXQC ), IWORK( IWK ), WORK, INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + 40 CONTINUE + 50 CONTINUE +* + RETURN +* +* End of DLASD0 +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlasd0} (defun dlasd0 (n sqre d e u ldu vt ldvt smlsiz iwork work info) (declare (type (simple-array fixnum (*)) iwork) @@ -56996,109 +79124,245 @@ SYNOPSIS DOUBLE PRECISION D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * ) -PURPOSE - DLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B, where N - = NL + NR + 1 and M = N + SQRE. DLASD1 is called from DLASD0. + Purpose + ======= - A related subroutine DLASD7 handles the case in which the singular val- - ues (and the singular vectors in factored form) are desired. + DLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B, + where N = NL + NR + 1 and M = N + SQRE. DLASD1 is called from DLASD0. - DLASD1 computes the SVD as follows: + A related subroutine DLASD7 handles the case in which the singular + values (and the singular vectors in factored form) are desired. - ( D1(in) 0 0 0 ) - B = U(in) * ( Z1' a Z2' b ) * VT(in) - ( 0 0 D2(in) 0 ) + DLASD1 computes the SVD as follows: - = U(out) * ( D(out) 0) * VT(out) + ( D1(in) 0 0 0 ) + B = U(in) * ( Z1' a Z2' b ) * VT(in) + ( 0 0 D2(in) 0 ) - where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M - with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros else- - where; and the entry b is empty if SQRE = 0. + = U(out) * ( D(out) 0) * VT(out) - The left singular vectors of the original matrix are stored in U, and - the transpose of the right singular vectors are stored in VT, and the - singular values are in D. The algorithm consists of three stages: + where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M + with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros + elsewhere; and the entry b is empty if SQRE = 0. - The first stage consists of deflating the size of the problem - when there are multiple singular values or when there are zeros in - the Z vector. For each such occurence the dimension of the - secular equation problem is reduced by one. This stage is - performed by the routine DLASD2. + The left singular vectors of the original matrix are stored in U, and + the transpose of the right singular vectors are stored in VT, and the + singular values are in D. The algorithm consists of three stages: - The second stage consists of calculating the updated - singular values. This is done by finding the square roots of the - roots of the secular equation via the routine DLASD4 (as called - by DLASD3). This routine also calculates the singular vectors of - the current problem. + The first stage consists of deflating the size of the problem + when there are multiple singular values or when there are zeros in + the Z vector. For each such occurence the dimension of the + secular equation problem is reduced by one. This stage is + performed by the routine DLASD2. - The final stage consists of computing the updated singular vectors - directly using the updated singular values. The singular vectors - for the current problem are multiplied with the singular vectors - from the overall problem. + The second stage consists of calculating the updated + singular values. This is done by finding the square roots of the + roots of the secular equation via the routine DLASD4 (as called + by DLASD3). This routine also calculates the singular vectors of + the current problem. + The final stage consists of computing the updated singular vectors + directly using the updated singular values. The singular vectors + for the current problem are multiplied with the singular vectors + from the overall problem. -ARGUMENTS - NL (input) INTEGER - The row dimension of the upper block. NL >= 1. + Arguments + ========= + + NL (input) INTEGER + The row dimension of the upper block. NL >= 1. + + NR (input) INTEGER + The row dimension of the lower block. NR >= 1. + + SQRE (input) INTEGER + = 0: the lower block is an NR-by-NR square matrix. + = 1: the lower block is an NR-by-(NR+1) rectangular matrix. - NR (input) INTEGER - The row dimension of the lower block. NR >= 1. + The bidiagonal matrix has row dimension N = NL + NR + 1, + and column dimension M = N + SQRE. - SQRE (input) INTEGER - = 0: the lower block is an NR-by-NR square matrix. - = 1: the lower block is an NR-by-(NR+1) rectangular matrix. + D (input/output) DOUBLE PRECISION array, + dimension (N = NL+NR+1). + On entry D(1:NL,1:NL) contains the singular values of the + upper block; and D(NL+2:N) contains the singular values of + the lower block. On exit D(1:N) contains the singular values + of the modified matrix. - The bidiagonal matrix has row dimension N = NL + NR + 1, and - column dimension M = N + SQRE. + ALPHA (input) DOUBLE PRECISION + Contains the diagonal element associated with the added row. - D (input/output) DOUBLE PRECISION array, - dimension (N = NL+NR+1). On entry D(1:NL,1:NL) contains the - singular values of the - upper block; and D(NL+2:N) contains the singular values of - the lower block. On exit D(1:N) contains the singular values of - the modified matrix. + BETA (input) DOUBLE PRECISION + Contains the off-diagonal element associated with the added + row. - ALPHA (input/output) DOUBLE PRECISION - Contains the diagonal element associated with the added row. + U (input/output) DOUBLE PRECISION array, dimension(LDU,N) + On entry U(1:NL, 1:NL) contains the left singular vectors of + the upper block; U(NL+2:N, NL+2:N) contains the left singular + vectors of the lower block. On exit U contains the left + singular vectors of the bidiagonal matrix. - BETA (input/output) DOUBLE PRECISION - Contains the off-diagonal element associated with the added row. + LDU (input) INTEGER + The leading dimension of the array U. LDU >= max( 1, N ). - U (input/output) DOUBLE PRECISION array, dimension(LDU,N) - On entry U(1:NL, 1:NL) contains the left singular vectors of - the upper block; U(NL+2:N, NL+2:N) contains the left singular - vectors of the lower block. On exit U contains the left singular - vectors of the bidiagonal matrix. + VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M) + where M = N + SQRE. + On entry VT(1:NL+1, 1:NL+1)' contains the right singular + vectors of the upper block; VT(NL+2:M, NL+2:M)' contains + the right singular vectors of the lower block. On exit + VT' contains the right singular vectors of the + bidiagonal matrix. - LDU (input) INTEGER - The leading dimension of the array U. LDU >= max( 1, N ). + LDVT (input) INTEGER + The leading dimension of the array VT. LDVT >= max( 1, M ). - VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M) - where M = N + SQRE. On entry VT(1:NL+1, 1:NL+1)' contains the - right singular - vectors of the upper block; VT(NL+2:M, NL+2:M)' contains the - right singular vectors of the lower block. On exit VT' contains - the right singular vectors of the bidiagonal matrix. + IDXQ (output) INTEGER array, dimension(N) + This contains the permutation which will reintegrate the + subproblem just solved back into sorted order, i.e. + D( IDXQ( I = 1, N ) ) will be in ascending order. - LDVT (input) INTEGER - The leading dimension of the array VT. LDVT >= max( 1, M ). + IWORK (workspace) INTEGER array, dimension( 4 * N ) - IDXQ (output) INTEGER array, dimension(N) - This contains the permutation which will reintegrate the subprob- - lem just solved back into sorted order, i.e. D( IDXQ( I = 1, N ) - ) will be in ascending order. + WORK (workspace) DOUBLE PRECISION array, dimension( 3*M**2 + 2*M ) - IWORK (workspace) INTEGER array, dimension( 4 * N ) + INFO (output) INTEGER + = 0: successful exit. + < 0: if INFO = -i, the i-th argument had an illegal value. + > 0: if INFO = 1, an singular value did not converge - WORK (workspace) DOUBLE PRECISION array, dimension( 3*M**2 + 2*M ) + Further Details + =============== - INFO (output) INTEGER - = 0: successful exit. - < 0: if INFO = -i, the i-th argument had an illegal value. - > 0: if INFO = 1, an singular value did not converge + Based on contributions by + Ming Gu and Huan Ren, Computer Science Division, University of + California at Berkeley, USA \end{chunk} +\begin{verbatim} + SUBROUTINE DLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, + $ IDXQ, IWORK, WORK, INFO ) +* +* -- 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 .. + INTEGER INFO, LDU, LDVT, NL, NR, SQRE + DOUBLE PRECISION ALPHA, BETA +* .. +* .. Array Arguments .. + INTEGER IDXQ( * ), IWORK( * ) + DOUBLE PRECISION D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. +* + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER COLTYP, I, IDX, IDXC, IDXP, IQ, ISIGMA, IU2, + $ IVT2, IZ, K, LDQ, LDU2, LDVT2, M, N, N1, N2 + DOUBLE PRECISION ORGNRM +* .. +* .. External Subroutines .. + EXTERNAL DLAMRG, DLASCL, DLASD2, DLASD3, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( NL.LT.1 ) THEN + INFO = -1 + ELSE IF( NR.LT.1 ) THEN + INFO = -2 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD1', -INFO ) + RETURN + END IF +* + N = NL + NR + 1 + M = N + SQRE +* +* The following values are for bookkeeping purposes only. They are +* integer pointers which indicate the portion of the workspace +* used by a particular array in DLASD2 and DLASD3. +* + LDU2 = N + LDVT2 = M +* + IZ = 1 + ISIGMA = IZ + M + IU2 = ISIGMA + N + IVT2 = IU2 + LDU2*N + IQ = IVT2 + LDVT2*M +* + IDX = 1 + IDXC = IDX + N + COLTYP = IDXC + N + IDXP = COLTYP + N +* +* Scale. +* + ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) ) + D( NL+1 ) = ZERO + DO 10 I = 1, N + IF( ABS( D( I ) ).GT.ORGNRM ) THEN + ORGNRM = ABS( D( I ) ) + END IF + 10 CONTINUE + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO ) + ALPHA = ALPHA / ORGNRM + BETA = BETA / ORGNRM +* +* Deflate singular values. +* + CALL DLASD2( NL, NR, SQRE, K, D, WORK( IZ ), ALPHA, BETA, U, LDU, + $ VT, LDVT, WORK( ISIGMA ), WORK( IU2 ), LDU2, + $ WORK( IVT2 ), LDVT2, IWORK( IDXP ), IWORK( IDX ), + $ IWORK( IDXC ), IDXQ, IWORK( COLTYP ), INFO ) +* +* Solve Secular Equation and update singular vectors. +* + LDQ = K + CALL DLASD3( NL, NR, SQRE, K, D, WORK( IQ ), LDQ, WORK( ISIGMA ), + $ U, LDU, WORK( IU2 ), LDU2, VT, LDVT, WORK( IVT2 ), + $ LDVT2, IWORK( IDXC ), IWORK( COLTYP ), WORK( IZ ), + $ INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF +* +* Unscale. +* + CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) +* +* Prepare the IDXQ sorting permutation. +* + N1 = K + N2 = N - K + CALL DLAMRG( N1, N2, D, 1, -1, IDXQ ) +* + RETURN +* +* End of DLASD1 +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlasd1} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -57280,140 +79544,524 @@ SYNOPSIS DOUBLE PRECISION D( * ), DSIGMA( * ), U( LDU, * ), U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), Z( * ) -PURPOSE - DLASD2 merges the two sets of singular values together into a single - sorted set. Then it tries to deflate the size of the problem. There - are two ways in which deflation can occur: when two or more singular - values are close together or if there is a tiny entry in the Z vector. - For each such occurrence the order of the related secular equation - problem is reduced by one. - - DLASD2 is called from DLASD1. + Purpose + ======= + + DLASD2 merges the two sets of singular values together into a single + sorted set. Then it tries to deflate the size of the problem. + There are two ways in which deflation can occur: when two or more + singular values are close together or if there is a tiny entry in the + Z vector. For each such occurrence the order of the related secular + equation problem is reduced by one. + + DLASD2 is called from DLASD1. + + Arguments + ========= + + NL (input) INTEGER + The row dimension of the upper block. NL >= 1. + + NR (input) INTEGER + The row dimension of the lower block. NR >= 1. + + SQRE (input) INTEGER + = 0: the lower block is an NR-by-NR square matrix. + = 1: the lower block is an NR-by-(NR+1) rectangular matrix. + + The bidiagonal matrix has N = NL + NR + 1 rows and + M = N + SQRE >= N columns. + + K (output) INTEGER + Contains the dimension of the non-deflated matrix, + This is the order of the related secular equation. 1 <= K <=N. + + D (input/output) DOUBLE PRECISION array, dimension(N) + On entry D contains the singular values of the two submatrices + to be combined. On exit D contains the trailing (N-K) updated + singular values (those which were deflated) sorted into + increasing order. + + ALPHA (input) DOUBLE PRECISION + Contains the diagonal element associated with the added row. + + BETA (input) DOUBLE PRECISION + Contains the off-diagonal element associated with the added + row. + + U (input/output) DOUBLE PRECISION array, dimension(LDU,N) + On entry U contains the left singular vectors of two + submatrices in the two square blocks with corners at (1,1), + (NL, NL), and (NL+2, NL+2), (N,N). + On exit U contains the trailing (N-K) updated left singular + vectors (those which were deflated) in its last N-K columns. + + LDU (input) INTEGER + The leading dimension of the array U. LDU >= N. + + Z (output) DOUBLE PRECISION array, dimension(N) + On exit Z contains the updating row vector in the secular + equation. + + DSIGMA (output) DOUBLE PRECISION array, dimension (N) + Contains a copy of the diagonal elements (K-1 singular values + and one zero) in the secular equation. + + U2 (output) DOUBLE PRECISION array, dimension(LDU2,N) + Contains a copy of the first K-1 left singular vectors which + will be used by DLASD3 in a matrix multiply (DGEMM) to solve + for the new left singular vectors. U2 is arranged into four + blocks. The first block contains a column with 1 at NL+1 and + zero everywhere else; the second block contains non-zero + entries only at and above NL; the third contains non-zero + entries only below NL+1; and the fourth is dense. + + LDU2 (input) INTEGER + The leading dimension of the array U2. LDU2 >= N. + + VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M) + On entry VT' contains the right singular vectors of two + submatrices in the two square blocks with corners at (1,1), + (NL+1, NL+1), and (NL+2, NL+2), (M,M). + On exit VT' contains the trailing (N-K) updated right singular + vectors (those which were deflated) in its last N-K columns. + In case SQRE =1, the last row of VT spans the right null + space. + + LDVT (input) INTEGER + The leading dimension of the array VT. LDVT >= M. + + VT2 (output) DOUBLE PRECISION array, dimension(LDVT2,N) + VT2' contains a copy of the first K right singular vectors + which will be used by DLASD3 in a matrix multiply (DGEMM) to + solve for the new right singular vectors. VT2 is arranged into + three blocks. The first block contains a row that corresponds + to the special 0 diagonal element in SIGMA; the second block + contains non-zeros only at and before NL +1; the third block + contains non-zeros only at and after NL +2. + + LDVT2 (input) INTEGER + The leading dimension of the array VT2. LDVT2 >= M. + + IDXP (workspace) INTEGER array, dimension(N) + This will contain the permutation used to place deflated + values of D at the end of the array. On output IDXP(2:K) + points to the nondeflated D-values and IDXP(K+1:N) + points to the deflated singular values. + + IDX (workspace) INTEGER array, dimension(N) + This will contain the permutation used to sort the contents of + D into ascending order. + + IDXC (output) INTEGER array, dimension(N) + This will contain the permutation used to arrange the columns + of the deflated U matrix into three groups: the first group + contains non-zero entries only at and above NL, the second + contains non-zero entries only below NL+2, and the third is + dense. + + COLTYP (workspace/output) INTEGER array, dimension(N) + As workspace, this will contain a label which will indicate + which of the following types a column in the U2 matrix or a + row in the VT2 matrix is: + 1 : non-zero in the upper half only + 2 : non-zero in the lower half only + 3 : dense + 4 : deflated + + On exit, it is an array of dimension 4, with COLTYP(I) being + the dimension of the I-th type columns. + + IDXQ (input) INTEGER array, dimension(N) + This contains the permutation which separately sorts the two + sub-problems in D into ascending order. Note that entries in + the first hlaf of this permutation must first be moved one + position backward; and entries in the second half + must first have NL+1 added to their values. + + INFO (output) INTEGER + = 0: successful exit. + < 0: if INFO = -i, the i-th argument had an illegal value. + + Further Details + =============== + + Based on contributions by + Ming Gu and Huan Ren, Computer Science Division, University of + California at Berkeley, USA +\end{chunk} -ARGUMENTS - NL (input) INTEGER - The row dimension of the upper block. NL >= 1. - - NR (input) INTEGER - The row dimension of the lower block. NR >= 1. - - SQRE (input) INTEGER - = 0: the lower block is an NR-by-NR square matrix. - = 1: the lower block is an NR-by-(NR+1) rectangular matrix. - - The bidiagonal matrix has N = NL + NR + 1 rows and M = N + SQRE - >= N columns. - - K (output) INTEGER - Contains the dimension of the non-deflated matrix, This is the - order of the related secular equation. 1 <= K <=N. - - D (input/output) DOUBLE PRECISION array, dimension(N) - On entry D contains the singular values of the two submatrices - to be combined. On exit D contains the trailing (N-K) updated - singular values (those which were deflated) sorted into increas- - ing order. - - Z (output) DOUBLE PRECISION array, dimension(N) - On exit Z contains the updating row vector in the secular equa- - tion. - - ALPHA (input) DOUBLE PRECISION - Contains the diagonal element associated with the added row. - - BETA (input) DOUBLE PRECISION - Contains the off-diagonal element associated with the added row. - - U (input/output) DOUBLE PRECISION array, dimension(LDU,N) - On entry U contains the left singular vectors of two submatrices - in the two square blocks with corners at (1,1), (NL, NL), and - (NL+2, NL+2), (N,N). On exit U contains the trailing (N-K) - updated left singular vectors (those which were deflated) in its - last N-K columns. - - LDU (input) INTEGER - The leading dimension of the array U. LDU >= N. - - VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M) - On entry VT' contains the right singular vectors of two subma- - trices in the two square blocks with corners at (1,1), (NL+1, - NL+1), and (NL+2, NL+2), (M,M). On exit VT' contains the trail- - ing (N-K) updated right singular vectors (those which were - deflated) in its last N-K columns. In case SQRE =1, the last - row of VT spans the right null space. - - LDVT (input) INTEGER - The leading dimension of the array VT. LDVT >= M. - - DSIGMA (output) DOUBLE PRECISION array, dimension (N) Contains a - copy of the diagonal elements (K-1 singular values and one zero) - in the secular equation. - - U2 (output) DOUBLE PRECISION array, dimension(LDU2,N) - Contains a copy of the first K-1 left singular vectors which - will be used by DLASD3 in a matrix multiply (DGEMM) to solve for - the new left singular vectors. U2 is arranged into four blocks. - The first block contains a column with 1 at NL+1 and zero every- - where else; the second block contains non-zero entries only at - and above NL; the third contains non-zero entries only below - NL+1; and the fourth is dense. - - LDU2 (input) INTEGER - The leading dimension of the array U2. LDU2 >= N. - - VT2 (output) DOUBLE PRECISION array, dimension(LDVT2,N) - VT2' contains a copy of the first K right singular vectors which - will be used by DLASD3 in a matrix multiply (DGEMM) to solve for - the new right singular vectors. VT2 is arranged into three - blocks. The first block contains a row that corresponds to the - special 0 diagonal element in SIGMA; the second block contains - non-zeros only at and before NL +1; the third block contains - non-zeros only at and after NL +2. - - LDVT2 (input) INTEGER - The leading dimension of the array VT2. LDVT2 >= M. - - IDXP (workspace) INTEGER array dimension(N) - This will contain the permutation used to place deflated values - of D at the end of the array. On output IDXP(2:K) - points to the nondeflated D-values and IDXP(K+1:N) points to the - deflated singular values. - - IDX (workspace) INTEGER array dimension(N) - This will contain the permutation used to sort the contents of D - into ascending order. - - IDXC (output) INTEGER array dimension(N) - This will contain the permutation used to arrange the columns of - the deflated U matrix into three groups: the first group con- - tains non-zero entries only at and above NL, the second contains - non-zero entries only below NL+2, and the third is dense. - - IDXQ (input/output) INTEGER array dimension(N) - This contains the permutation which separately sorts the two - sub-problems in D into ascending order. Note that entries in - the first hlaf of this permutation must first be moved one posi- - tion backward; and entries in the second half must first have - NL+1 added to their values. - - COLTYP (workspace/output) INTEGER array dimension(N) As - workspace, this will contain a label which will indicate which - of the following types a column in the U2 matrix or a row in the - VT2 matrix is: - 1 : non-zero in the upper half only - 2 : non-zero in the lower half only - 3 : dense - 4 : deflated - - On exit, it is an array of dimension 4, with COLTYP(I) being the - dimension of the I-th type columns. - - INFO (output) INTEGER - = 0: successful exit. - < 0: if INFO = -i, the i-th argument had an illegal value. +\begin{verbatim} + SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, + $ LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, + $ IDXC, IDXQ, COLTYP, INFO ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, +* Courant Institute, NAG Ltd., and Rice University +* October 31, 1999 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE + DOUBLE PRECISION ALPHA, BETA +* .. +* .. Array Arguments .. + INTEGER COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ), + $ IDXQ( * ) + DOUBLE PRECISION D( * ), DSIGMA( * ), U( LDU, * ), + $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), + $ Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, EIGHT + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ EIGHT = 8.0D+0 ) +* .. +* .. Local Arrays .. + INTEGER CTOT( 4 ), PSM( 4 ) +* .. +* .. Local Scalars .. + INTEGER CT, I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, + $ N, NLP1, NLP2 + DOUBLE PRECISION C, EPS, HLFTOL, S, TAU, TOL, Z1 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2 +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DLAMRG, DLASET, DROT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( NL.LT.1 ) THEN + INFO = -1 + ELSE IF( NR.LT.1 ) THEN + INFO = -2 + ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN + INFO = -3 + END IF +* + N = NL + NR + 1 + M = N + SQRE +* + IF( LDU.LT.N ) THEN + INFO = -10 + ELSE IF( LDVT.LT.M ) THEN + INFO = -12 + ELSE IF( LDU2.LT.N ) THEN + INFO = -15 + ELSE IF( LDVT2.LT.M ) THEN + INFO = -17 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD2', -INFO ) + RETURN + END IF +* + NLP1 = NL + 1 + NLP2 = NL + 2 +* +* Generate the first part of the vector Z; and move the singular +* values in the first part of D one position backward. +* + Z1 = ALPHA*VT( NLP1, NLP1 ) + Z( 1 ) = Z1 + DO 10 I = NL, 1, -1 + Z( I+1 ) = ALPHA*VT( I, NLP1 ) + D( I+1 ) = D( I ) + IDXQ( I+1 ) = IDXQ( I ) + 1 + 10 CONTINUE +* +* Generate the second part of the vector Z. +* + DO 20 I = NLP2, M + Z( I ) = BETA*VT( I, NLP2 ) + 20 CONTINUE +* +* Initialize some reference arrays. +* + DO 30 I = 2, NLP1 + COLTYP( I ) = 1 + 30 CONTINUE + DO 40 I = NLP2, N + COLTYP( I ) = 2 + 40 CONTINUE +* +* Sort the singular values into increasing order +* + DO 50 I = NLP2, N + IDXQ( I ) = IDXQ( I ) + NLP1 + 50 CONTINUE +* +* DSIGMA, IDXC, IDXC, and the first column of U2 +* are used as storage space. +* + DO 60 I = 2, N + DSIGMA( I ) = D( IDXQ( I ) ) + U2( I, 1 ) = Z( IDXQ( I ) ) + IDXC( I ) = COLTYP( IDXQ( I ) ) + 60 CONTINUE +* + CALL DLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) ) +* + DO 70 I = 2, N + IDXI = 1 + IDX( I ) + D( I ) = DSIGMA( IDXI ) + Z( I ) = U2( IDXI, 1 ) + COLTYP( I ) = IDXC( IDXI ) + 70 CONTINUE +* +* Calculate the allowable deflation tolerance +* + EPS = DLAMCH( 'Epsilon' ) + TOL = MAX( ABS( ALPHA ), ABS( BETA ) ) + TOL = EIGHT*EPS*MAX( ABS( D( N ) ), TOL ) +* +* There are 2 kinds of deflation -- first a value in the z-vector +* is small, second two (or more) singular values are very close +* together (their difference is small). +* +* If the value in the z-vector is small, we simply permute the +* array so that the corresponding singular value is moved to the +* end. +* +* If two values in the D-vector are close, we perform a two-sided +* rotation designed to make one of the corresponding z-vector +* entries zero, and then permute the array so that the deflated +* singular value is moved to the end. +* +* If there are multiple singular values then the problem deflates. +* Here the number of equal singular values are found. As each equal +* singular value is found, an elementary reflector is computed to +* rotate the corresponding singular subspace so that the +* corresponding components of Z are zero in this new basis. +* + K = 1 + K2 = N + 1 + DO 80 J = 2, N + IF( ABS( Z( J ) ).LE.TOL ) THEN +* +* Deflate due to small z component. +* + K2 = K2 - 1 + IDXP( K2 ) = J + COLTYP( J ) = 4 + IF( J.EQ.N ) + $ GO TO 120 + ELSE + JPREV = J + GO TO 90 + END IF + 80 CONTINUE + 90 CONTINUE + J = JPREV + 100 CONTINUE + J = J + 1 + IF( J.GT.N ) + $ GO TO 110 + IF( ABS( Z( J ) ).LE.TOL ) THEN +* +* Deflate due to small z component. +* + K2 = K2 - 1 + IDXP( K2 ) = J + COLTYP( J ) = 4 + ELSE +* +* Check if singular values are close enough to allow deflation. +* + IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN +* +* Deflation is possible. +* + S = Z( JPREV ) + C = Z( J ) +* +* Find sqrt(a**2+b**2) without overflow or +* destructive underflow. +* + TAU = DLAPY2( C, S ) + C = C / TAU + S = -S / TAU + Z( J ) = TAU + Z( JPREV ) = ZERO +* +* Apply back the Givens rotation to the left and right +* singular vector matrices. +* + IDXJP = IDXQ( IDX( JPREV )+1 ) + IDXJ = IDXQ( IDX( J )+1 ) + IF( IDXJP.LE.NLP1 ) THEN + IDXJP = IDXJP - 1 + END IF + IF( IDXJ.LE.NLP1 ) THEN + IDXJ = IDXJ - 1 + END IF + CALL DROT( N, U( 1, IDXJP ), 1, U( 1, IDXJ ), 1, C, S ) + CALL DROT( M, VT( IDXJP, 1 ), LDVT, VT( IDXJ, 1 ), LDVT, C, + $ S ) + IF( COLTYP( J ).NE.COLTYP( JPREV ) ) THEN + COLTYP( J ) = 3 + END IF + COLTYP( JPREV ) = 4 + K2 = K2 - 1 + IDXP( K2 ) = JPREV + JPREV = J + ELSE + K = K + 1 + U2( K, 1 ) = Z( JPREV ) + DSIGMA( K ) = D( JPREV ) + IDXP( K ) = JPREV + JPREV = J + END IF + END IF + GO TO 100 + 110 CONTINUE +* +* Record the last singular value. +* + K = K + 1 + U2( K, 1 ) = Z( JPREV ) + DSIGMA( K ) = D( JPREV ) + IDXP( K ) = JPREV +* + 120 CONTINUE +* +* Count up the total number of the various types of columns, then +* form a permutation which positions the four column types into +* four groups of uniform structure (although one or more of these +* groups may be empty). +* + DO 130 J = 1, 4 + CTOT( J ) = 0 + 130 CONTINUE + DO 140 J = 2, N + CT = COLTYP( J ) + CTOT( CT ) = CTOT( CT ) + 1 + 140 CONTINUE +* +* PSM(*) = Position in SubMatrix (of types 1 through 4) +* + PSM( 1 ) = 2 + PSM( 2 ) = 2 + CTOT( 1 ) + PSM( 3 ) = PSM( 2 ) + CTOT( 2 ) + PSM( 4 ) = PSM( 3 ) + CTOT( 3 ) +* +* Fill out the IDXC array so that the permutation which it induces +* will place all type-1 columns first, all type-2 columns next, +* then all type-3's, and finally all type-4's, starting from the +* second column. This applies similarly to the rows of VT. +* + DO 150 J = 2, N + JP = IDXP( J ) + CT = COLTYP( JP ) + IDXC( PSM( CT ) ) = J + PSM( CT ) = PSM( CT ) + 1 + 150 CONTINUE +* +* Sort the singular values and corresponding singular vectors into +* DSIGMA, U2, and VT2 respectively. The singular values/vectors +* which were not deflated go into the first K slots of DSIGMA, U2, +* and VT2 respectively, while those which were deflated go into the +* last N - K slots, except that the first column/row will be treated +* separately. +* + DO 160 J = 2, N + JP = IDXP( J ) + DSIGMA( J ) = D( JP ) + IDXJ = IDXQ( IDX( IDXP( IDXC( J ) ) )+1 ) + IF( IDXJ.LE.NLP1 ) THEN + IDXJ = IDXJ - 1 + END IF + CALL DCOPY( N, U( 1, IDXJ ), 1, U2( 1, J ), 1 ) + CALL DCOPY( M, VT( IDXJ, 1 ), LDVT, VT2( J, 1 ), LDVT2 ) + 160 CONTINUE +* +* Determine DSIGMA(1), DSIGMA(2) and Z(1) +* + DSIGMA( 1 ) = ZERO + HLFTOL = TOL / TWO + IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL ) + $ DSIGMA( 2 ) = HLFTOL + IF( M.GT.N ) THEN + Z( 1 ) = DLAPY2( Z1, Z( M ) ) + IF( Z( 1 ).LE.TOL ) THEN + C = ONE + S = ZERO + Z( 1 ) = TOL + ELSE + C = Z1 / Z( 1 ) + S = Z( M ) / Z( 1 ) + END IF + ELSE + IF( ABS( Z1 ).LE.TOL ) THEN + Z( 1 ) = TOL + ELSE + Z( 1 ) = Z1 + END IF + END IF +* +* Move the rest of the updating row to Z. +* + CALL DCOPY( K-1, U2( 2, 1 ), 1, Z( 2 ), 1 ) +* +* Determine the first column of U2, the first row of VT2 and the +* last row of VT. +* + CALL DLASET( 'A', N, 1, ZERO, ZERO, U2, LDU2 ) + U2( NLP1, 1 ) = ONE + IF( M.GT.N ) THEN + DO 170 I = 1, NLP1 + VT( M, I ) = -S*VT( NLP1, I ) + VT2( 1, I ) = C*VT( NLP1, I ) + 170 CONTINUE + DO 180 I = NLP2, M + VT2( 1, I ) = S*VT( M, I ) + VT( M, I ) = C*VT( M, I ) + 180 CONTINUE + ELSE + CALL DCOPY( M, VT( NLP1, 1 ), LDVT, VT2( 1, 1 ), LDVT2 ) + END IF + IF( M.GT.N ) THEN + CALL DCOPY( M, VT( M, 1 ), LDVT, VT2( M, 1 ), LDVT2 ) + END IF +* +* The deflated singular values and their corresponding vectors go +* into the back of D, U, and V respectively. +* + IF( N.GT.K ) THEN + CALL DCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 ) + CALL DLACPY( 'A', N, N-K, U2( 1, K+1 ), LDU2, U( 1, K+1 ), + $ LDU ) + CALL DLACPY( 'A', N-K, M, VT2( K+1, 1 ), LDVT2, VT( K+1, 1 ), + $ LDVT ) + END IF +* +* Copy CTOT into COLTYP for referencing in DLASD3. +* + DO 190 J = 1, 4 + COLTYP( J ) = CTOT( J ) + 190 CONTINUE +* + RETURN +* +* End of DLASD2 +* + END -\end{chunk} +\end{verbatim} \begin{chunk}{LAPACK dlasd2} (let* ((zero 0.0) (one 1.0) (two 2.0) (eight 8.0)) @@ -57936,106 +80584,371 @@ SYNOPSIS * ), U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), Z( * ) -PURPOSE - DLASD3 finds all the square roots of the roots of the secular equation, - as defined by the values in D and Z. It makes the appropriate calls to - DLASD4 and then updates the singular vectors by matrix multiplication. + Purpose + ======= - This code makes very mild assumptions about floating point arithmetic. - It will work on machines with a guard digit in add/subtract, or on - those binary machines without guard digits which subtract like the Cray - XMP, Cray YMP, Cray C 90, or Cray 2. It could conceivably fail on hex- - adecimal or decimal machines without guard digits, but we know of none. + DLASD3 finds all the square roots of the roots of the secular + equation, as defined by the values in D and Z. It makes the + appropriate calls to DLASD4 and then updates the singular + vectors by matrix multiplication. - DLASD3 is called from DLASD1. + This code makes very mild assumptions about floating point + arithmetic. It will work on machines with a guard digit in + add/subtract, or on those binary machines without guard digits + which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. + It could conceivably fail on hexadecimal or decimal machines + without guard digits, but we know of none. + DLASD3 is called from DLASD1. -ARGUMENTS - NL (input) INTEGER - The row dimension of the upper block. NL >= 1. + Arguments + ========= + + NL (input) INTEGER + The row dimension of the upper block. NL >= 1. - NR (input) INTEGER - The row dimension of the lower block. NR >= 1. + NR (input) INTEGER + The row dimension of the lower block. NR >= 1. - SQRE (input) INTEGER - = 0: the lower block is an NR-by-NR square matrix. - = 1: the lower block is an NR-by-(NR+1) rectangular matrix. + SQRE (input) INTEGER + = 0: the lower block is an NR-by-NR square matrix. + = 1: the lower block is an NR-by-(NR+1) rectangular matrix. - The bidiagonal matrix has N = NL + NR + 1 rows and M = N + SQRE - >= N columns. + The bidiagonal matrix has N = NL + NR + 1 rows and + M = N + SQRE >= N columns. - K (input) INTEGER - The size of the secular equation, 1 =< K = < N. + K (input) INTEGER + The size of the secular equation, 1 =< K = < N. - D (output) DOUBLE PRECISION array, dimension(K) - On exit the square roots of the roots of the secular equation, - in ascending order. + D (output) DOUBLE PRECISION array, dimension(K) + On exit the square roots of the roots of the secular equation, + in ascending order. - Q (workspace) DOUBLE PRECISION array, - dimension at least (LDQ,K). + Q (workspace) DOUBLE PRECISION array, + dimension at least (LDQ,K). - LDQ (input) INTEGER - The leading dimension of the array Q. LDQ >= K. + LDQ (input) INTEGER + The leading dimension of the array Q. LDQ >= K. - DSIGMA (input) DOUBLE PRECISION array, dimension(K) The first K - elements of this array contain the old roots of the deflated - updating problem. These are the poles of the secular equation. + DSIGMA (input) DOUBLE PRECISION array, dimension(K) + The first K elements of this array contain the old roots + of the deflated updating problem. These are the poles + of the secular equation. - U (output) DOUBLE PRECISION array, dimension (LDU, N) - The last N - K columns of this matrix contain the deflated left - singular vectors. + U (input) DOUBLE PRECISION array, dimension (LDU, N) + The last N - K columns of this matrix contain the deflated + left singular vectors. - LDU (input) INTEGER - The leading dimension of the array U. LDU >= N. + LDU (input) INTEGER + The leading dimension of the array U. LDU >= N. - U2 (input/output) DOUBLE PRECISION array, dimension (LDU2, N) - The first K columns of this matrix contain the non-deflated left - singular vectors for the split problem. + U2 (input) DOUBLE PRECISION array, dimension (LDU2, N) + The first K columns of this matrix contain the non-deflated + left singular vectors for the split problem. - LDU2 (input) INTEGER - The leading dimension of the array U2. LDU2 >= N. + LDU2 (input) INTEGER + The leading dimension of the array U2. LDU2 >= N. - VT (output) DOUBLE PRECISION array, dimension (LDVT, M) - The last M - K columns of VT' contain the deflated right singu- - lar vectors. + VT (input) DOUBLE PRECISION array, dimension (LDVT, M) + The last M - K columns of VT' contain the deflated + right singular vectors. - LDVT (input) INTEGER - The leading dimension of the array VT. LDVT >= N. + LDVT (input) INTEGER + The leading dimension of the array VT. LDVT >= N. - VT2 (input/output) DOUBLE PRECISION array, dimension (LDVT2, N) - The first K columns of VT2' contain the non-deflated right sin- - gular vectors for the split problem. + VT2 (input) DOUBLE PRECISION array, dimension (LDVT2, N) + The first K columns of VT2' contain the non-deflated + right singular vectors for the split problem. - LDVT2 (input) INTEGER - The leading dimension of the array VT2. LDVT2 >= N. + LDVT2 (input) INTEGER + The leading dimension of the array VT2. LDVT2 >= N. - IDXC (input) INTEGER array, dimension ( N ) - The permutation used to arrange the columns of U (and rows of - VT) into three groups: the first group contains non-zero - entries only at and above (or before) NL +1; the second contains - non-zero entries only at and below (or after) NL+2; and the - third is dense. The first column of U and the row of VT are - treated separately, however. + IDXC (input) INTEGER array, dimension ( N ) + The permutation used to arrange the columns of U (and rows of + VT) into three groups: the first group contains non-zero + entries only at and above (or before) NL +1; the second + contains non-zero entries only at and below (or after) NL+2; + and the third is dense. The first column of U and the row of + VT are treated separately, however. - The rows of the singular vectors found by DLASD4 must be like- - wise permuted before the matrix multiplies can take place. + The rows of the singular vectors found by DLASD4 + must be likewise permuted before the matrix multiplies can + take place. - CTOT (input) INTEGER array, dimension ( 4 ) - A count of the total number of the various types of columns in U - (or rows in VT), as described in IDXC. The fourth column type is - any column which has been deflated. + CTOT (input) INTEGER array, dimension ( 4 ) + A count of the total number of the various types of columns + in U (or rows in VT), as described in IDXC. The fourth column + type is any column which has been deflated. - Z (input) DOUBLE PRECISION array, dimension (K) - The first K elements of this array contain the components of the - deflation-adjusted updating row vector. + Z (input) DOUBLE PRECISION array, dimension (K) + The first K elements of this array contain the components + of the deflation-adjusted updating row vector. - INFO (output) INTEGER - = 0: successful exit. - < 0: if INFO = -i, the i-th argument had an illegal value. - > 0: if INFO = 1, an singular value did not converge + INFO (output) INTEGER + = 0: successful exit. + < 0: if INFO = -i, the i-th argument had an illegal value. + > 0: if INFO = 1, an singular value did not converge + + Further Details + =============== + + Based on contributions by + Ming Gu and Huan Ren, Computer Science Division, University of + California at Berkeley, USA \end{chunk} +\begin{verbatim} + SUBROUTINE DLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, + $ LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, + $ INFO ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, +* Courant Institute, NAG Ltd., and Rice University +* October 31, 1999 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR, + $ SQRE +* .. +* .. Array Arguments .. + INTEGER CTOT( * ), IDXC( * ) + DOUBLE PRECISION D( * ), DSIGMA( * ), Q( LDQ, * ), U( LDU, * ), + $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), + $ Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO, NEGONE + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, + $ NEGONE = -1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER CTEMP, I, J, JC, KTEMP, M, N, NLP1, NLP2, NRP1 + DOUBLE PRECISION RHO, TEMP +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3, DNRM2 + EXTERNAL DLAMC3, DNRM2 +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLACPY, DLASCL, DLASD4, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SIGN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( NL.LT.1 ) THEN + INFO = -1 + ELSE IF( NR.LT.1 ) THEN + INFO = -2 + ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN + INFO = -3 + END IF +* + N = NL + NR + 1 + M = N + SQRE + NLP1 = NL + 1 + NLP2 = NL + 2 +* + IF( ( K.LT.1 ) .OR. ( K.GT.N ) ) THEN + INFO = -4 + ELSE IF( LDQ.LT.K ) THEN + INFO = -7 + ELSE IF( LDU.LT.N ) THEN + INFO = -10 + ELSE IF( LDU2.LT.N ) THEN + INFO = -12 + ELSE IF( LDVT.LT.M ) THEN + INFO = -14 + ELSE IF( LDVT2.LT.M ) THEN + INFO = -16 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( K.EQ.1 ) THEN + D( 1 ) = ABS( Z( 1 ) ) + CALL DCOPY( M, VT2( 1, 1 ), LDVT2, VT( 1, 1 ), LDVT ) + IF( Z( 1 ).GT.ZERO ) THEN + CALL DCOPY( N, U2( 1, 1 ), 1, U( 1, 1 ), 1 ) + ELSE + DO 10 I = 1, N + U( I, 1 ) = -U2( I, 1 ) + 10 CONTINUE + END IF + RETURN + END IF +* +* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can +* be computed with high relative accuracy (barring over/underflow). +* This is a problem on machines without a guard digit in +* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). +* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), +* which on any of these machines zeros out the bottommost +* bit of DSIGMA(I) if it is 1; this makes the subsequent +* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation +* occurs. On binary machines with a guard digit (almost all +* machines) it does not change DSIGMA(I) at all. On hexadecimal +* and decimal machines with a guard digit, it slightly +* changes the bottommost bits of DSIGMA(I). It does not account +* for hexadecimal or decimal machines without guard digits +* (we know of none). We use a subroutine call to compute +* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating +* this code. +* + DO 20 I = 1, K + DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I ) + 20 CONTINUE +* +* Keep a copy of Z. +* + CALL DCOPY( K, Z, 1, Q, 1 ) +* +* Normalize Z. +* + RHO = DNRM2( K, Z, 1 ) + CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO ) + RHO = RHO*RHO +* +* Find the new singular values. +* + DO 30 J = 1, K + CALL DLASD4( K, J, DSIGMA, Z, U( 1, J ), RHO, D( J ), + $ VT( 1, J ), INFO ) +* +* If the zero finder fails, the computation is terminated. +* + IF( INFO.NE.0 ) THEN + RETURN + END IF + 30 CONTINUE +* +* Compute updated Z. +* + DO 60 I = 1, K + Z( I ) = U( I, K )*VT( I, K ) + DO 40 J = 1, I - 1 + Z( I ) = Z( I )*( U( I, J )*VT( I, J ) / + $ ( DSIGMA( I )-DSIGMA( J ) ) / + $ ( DSIGMA( I )+DSIGMA( J ) ) ) + 40 CONTINUE + DO 50 J = I, K - 1 + Z( I ) = Z( I )*( U( I, J )*VT( I, J ) / + $ ( DSIGMA( I )-DSIGMA( J+1 ) ) / + $ ( DSIGMA( I )+DSIGMA( J+1 ) ) ) + 50 CONTINUE + Z( I ) = SIGN( SQRT( ABS( Z( I ) ) ), Q( I, 1 ) ) + 60 CONTINUE +* +* Compute left singular vectors of the modified diagonal matrix, +* and store related information for the right singular vectors. +* + DO 90 I = 1, K + VT( 1, I ) = Z( 1 ) / U( 1, I ) / VT( 1, I ) + U( 1, I ) = NEGONE + DO 70 J = 2, K + VT( J, I ) = Z( J ) / U( J, I ) / VT( J, I ) + U( J, I ) = DSIGMA( J )*VT( J, I ) + 70 CONTINUE + TEMP = DNRM2( K, U( 1, I ), 1 ) + Q( 1, I ) = U( 1, I ) / TEMP + DO 80 J = 2, K + JC = IDXC( J ) + Q( J, I ) = U( JC, I ) / TEMP + 80 CONTINUE + 90 CONTINUE +* +* Update the left singular vector matrix. +* + IF( K.EQ.2 ) THEN + CALL DGEMM( 'N', 'N', N, K, K, ONE, U2, LDU2, Q, LDQ, ZERO, U, + $ LDU ) + GO TO 100 + END IF + IF( CTOT( 1 ).GT.0 ) THEN + CALL DGEMM( 'N', 'N', NL, K, CTOT( 1 ), ONE, U2( 1, 2 ), LDU2, + $ Q( 2, 1 ), LDQ, ZERO, U( 1, 1 ), LDU ) + IF( CTOT( 3 ).GT.0 ) THEN + KTEMP = 2 + CTOT( 1 ) + CTOT( 2 ) + CALL DGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ), + $ LDU2, Q( KTEMP, 1 ), LDQ, ONE, U( 1, 1 ), LDU ) + END IF + ELSE IF( CTOT( 3 ).GT.0 ) THEN + KTEMP = 2 + CTOT( 1 ) + CTOT( 2 ) + CALL DGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ), + $ LDU2, Q( KTEMP, 1 ), LDQ, ZERO, U( 1, 1 ), LDU ) + ELSE + CALL DLACPY( 'F', NL, K, U2, LDU2, U, LDU ) + END IF + CALL DCOPY( K, Q( 1, 1 ), LDQ, U( NLP1, 1 ), LDU ) + KTEMP = 2 + CTOT( 1 ) + CTEMP = CTOT( 2 ) + CTOT( 3 ) + CALL DGEMM( 'N', 'N', NR, K, CTEMP, ONE, U2( NLP2, KTEMP ), LDU2, + $ Q( KTEMP, 1 ), LDQ, ZERO, U( NLP2, 1 ), LDU ) +* +* Generate the right singular vectors. +* + 100 CONTINUE + DO 120 I = 1, K + TEMP = DNRM2( K, VT( 1, I ), 1 ) + Q( I, 1 ) = VT( 1, I ) / TEMP + DO 110 J = 2, K + JC = IDXC( J ) + Q( I, J ) = VT( JC, I ) / TEMP + 110 CONTINUE + 120 CONTINUE +* +* Update the right singular vector matrix. +* + IF( K.EQ.2 ) THEN + CALL DGEMM( 'N', 'N', K, M, K, ONE, Q, LDQ, VT2, LDVT2, ZERO, + $ VT, LDVT ) + RETURN + END IF + KTEMP = 1 + CTOT( 1 ) + CALL DGEMM( 'N', 'N', K, NLP1, KTEMP, ONE, Q( 1, 1 ), LDQ, + $ VT2( 1, 1 ), LDVT2, ZERO, VT( 1, 1 ), LDVT ) + KTEMP = 2 + CTOT( 1 ) + CTOT( 2 ) + IF( KTEMP.LE.LDVT2 ) + $ CALL DGEMM( 'N', 'N', K, NLP1, CTOT( 3 ), ONE, Q( 1, KTEMP ), + $ LDQ, VT2( KTEMP, 1 ), LDVT2, ONE, VT( 1, 1 ), + $ LDVT ) +* + KTEMP = CTOT( 1 ) + 1 + NRP1 = NR + SQRE + IF( KTEMP.GT.1 ) THEN + DO 130 I = 1, K + Q( I, KTEMP ) = Q( I, 1 ) + 130 CONTINUE + DO 140 I = NLP2, M + VT2( KTEMP, I ) = VT2( 1, I ) + 140 CONTINUE + END IF + CTEMP = 1 + CTOT( 2 ) + CTOT( 3 ) + CALL DGEMM( 'N', 'N', K, NRP1, CTEMP, ONE, Q( 1, KTEMP ), LDQ, + $ VT2( KTEMP, NLP2 ), LDVT2, ZERO, VT( 1, NLP2 ), LDVT ) +* + RETURN +* +* End of DLASD3 +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlasd3} (let* ((one 1.0) (zero 0.0) (negone (- 1.0))) (declare (type (double-float 1.0 1.0) one) @@ -58576,68 +81489,903 @@ SYNOPSIS DOUBLE PRECISION D( * ), DELTA( * ), WORK( * ), Z( * ) -PURPOSE - This subroutine computes the square root of the I-th updated eigenvalue - of a positive symmetric rank-one modification to a positive diagonal - matrix whose entries are given as the squares of the corresponding - entries in the array d, and that no loss in generality. The rank-one - modified system is thus + Purpose + ======= - diag( D ) * diag( D ) + RHO * Z * Z_transpose. + This subroutine computes the square root of the I-th updated + eigenvalue of a positive symmetric rank-one modification to + a positive diagonal matrix whose entries are given as the squares + of the corresponding entries in the array d, and that - where we assume the Euclidean norm of Z is 1. + 0 <= D(i) < D(j) for i < j - The method consists of approximating the rational functions in the sec- - ular equation by simpler interpolating rational functions. + and that RHO > 0. This is arranged by the calling routine, and is + no loss in generality. The rank-one modified system is thus + diag( D ) * diag( D ) + RHO * Z * Z_transpose. -ARGUMENTS - N (input) INTEGER - The length of all arrays. + where we assume the Euclidean norm of Z is 1. - I (input) INTEGER - The index of the eigenvalue to be computed. 1 <= I <= N. + The method consists of approximating the rational functions in the + secular equation by simpler interpolating rational functions. - D (input) DOUBLE PRECISION array, dimension ( N ) - The original eigenvalues. It is assumed that they are in order, - 0 <= D(I) < D(J) for I < J. + Arguments + ========= - Z (input) DOUBLE PRECISION array, dimension ( N ) - The components of the updating vector. + N (input) INTEGER + The length of all arrays. - DELTA (output) DOUBLE PRECISION array, dimension ( N ) - If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th compo- - nent. If N = 1, then DELTA(1) = 1. The vector DELTA contains - the information necessary to construct the (singular) eigenvec- - tors. + I (input) INTEGER + The index of the eigenvalue to be computed. 1 <= I <= N. - RHO (input) DOUBLE PRECISION - The scalar in the symmetric updating formula. + D (input) DOUBLE PRECISION array, dimension ( N ) + The original eigenvalues. It is assumed that they are in + order, 0 <= D(I) < D(J) for I < J. - SIGMA (output) DOUBLE PRECISION - The computed sigma_I, the I-th updated eigenvalue. + Z (input) DOUBLE PRECISION array, dimension ( N ) + The components of the updating vector. - WORK (workspace) DOUBLE PRECISION array, dimension ( N ) - If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th compo- - nent. If N = 1, then WORK( 1 ) = 1. + DELTA (output) DOUBLE PRECISION array, dimension ( N ) + If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th + component. If N = 1, then DELTA(1) = 1. The vector DELTA + contains the information necessary to construct the + (singular) eigenvectors. - INFO (output) INTEGER - = 0: successful exit - > 0: if INFO = 1, the updating process failed. + RHO (input) DOUBLE PRECISION + The scalar in the symmetric updating formula. -PARAMETERS - Logical variable ORGATI (origin-at-i?) is used for distinguishing - whether D(i) or D(i+1) is treated as the origin. + SIGMA (output) DOUBLE PRECISION + The computed lambda_I, the I-th updated eigenvalue. + + WORK (workspace) DOUBLE PRECISION array, dimension ( N ) + If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th + component. If N = 1, then WORK( 1 ) = 1. + + INFO (output) INTEGER + = 0: successful exit + > 0: if INFO = 1, the updating process failed. + + Internal Parameters + =================== + + Logical variable ORGATI (origin-at-i?) is used for distinguishing + whether D(i) or D(i+1) is treated as the origin. - ORGATI = .true. origin at i ORGATI = .false. origin at i+1 + ORGATI = .true. origin at i + ORGATI = .false. origin at i+1 - Logical variable SWTCH3 (switch-for-3-poles?) is for noting if we are - working with THREE poles! + Logical variable SWTCH3 (switch-for-3-poles?) is for noting + if we are working with THREE poles! - MAXIT is the maximum number of iterations allowed for each eigenvalue. + MAXIT is the maximum number of iterations allowed for each + eigenvalue. + + Further Details + =============== + + Based on contributions by + Ren-Cang Li, Computer Science Division, University of California + at Berkeley, USA \end{chunk} +\begin{verbatim} + SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, +* Courant Institute, NAG Ltd., and Rice University +* October 31, 1999 +* +* .. Scalar Arguments .. + INTEGER I, INFO, N + DOUBLE PRECISION RHO, SIGMA +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), DELTA( * ), WORK( * ), Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER MAXIT + PARAMETER ( MAXIT = 20 ) + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ THREE = 3.0D+0, FOUR = 4.0D+0, EIGHT = 8.0D+0, + $ TEN = 10.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ORGATI, SWTCH, SWTCH3 + INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER + DOUBLE PRECISION A, B, C, DELSQ, DELSQ2, DPHI, DPSI, DTIIM, + $ DTIIP, DTIPSQ, DTISQ, DTNSQ, DTNSQ1, DW, EPS, + $ ERRETM, ETA, PHI, PREW, PSI, RHOINV, SG2LB, + $ SG2UB, TAU, TEMP, TEMP1, TEMP2, W +* .. +* .. Local Arrays .. + DOUBLE PRECISION DD( 3 ), ZZ( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DLAED6, DLASD5 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Since this routine is called in an inner loop, we do no argument +* checking. +* +* Quick return for N=1 and 2. +* + INFO = 0 + IF( N.EQ.1 ) THEN +* +* Presumably, I=1 upon entry +* + SIGMA = SQRT( D( 1 )*D( 1 )+RHO*Z( 1 )*Z( 1 ) ) + DELTA( 1 ) = ONE + WORK( 1 ) = ONE + RETURN + END IF + IF( N.EQ.2 ) THEN + CALL DLASD5( I, D, Z, DELTA, RHO, SIGMA, WORK ) + RETURN + END IF +* +* Compute machine epsilon +* + EPS = DLAMCH( 'Epsilon' ) + RHOINV = ONE / RHO +* +* The case I = N +* + IF( I.EQ.N ) THEN +* +* Initialize some basic variables +* + II = N - 1 + NITER = 1 +* +* Calculate initial guess +* + TEMP = RHO / TWO +* +* If ||Z||_2 is not one, then TEMP should be set to +* RHO * ||Z||_2^2 / TWO +* + TEMP1 = TEMP / ( D( N )+SQRT( D( N )*D( N )+TEMP ) ) + DO 10 J = 1, N + WORK( J ) = D( J ) + D( N ) + TEMP1 + DELTA( J ) = ( D( J )-D( N ) ) - TEMP1 + 10 CONTINUE +* + PSI = ZERO + DO 20 J = 1, N - 2 + PSI = PSI + Z( J )*Z( J ) / ( DELTA( J )*WORK( J ) ) + 20 CONTINUE +* + C = RHOINV + PSI + W = C + Z( II )*Z( II ) / ( DELTA( II )*WORK( II ) ) + + $ Z( N )*Z( N ) / ( DELTA( N )*WORK( N ) ) +* + IF( W.LE.ZERO ) THEN + TEMP1 = SQRT( D( N )*D( N )+RHO ) + TEMP = Z( N-1 )*Z( N-1 ) / ( ( D( N-1 )+TEMP1 )* + $ ( D( N )-D( N-1 )+RHO / ( D( N )+TEMP1 ) ) ) + + $ Z( N )*Z( N ) / RHO +* +* The following TAU is to approximate +* SIGMA_n^2 - D( N )*D( N ) +* + IF( C.LE.TEMP ) THEN + TAU = RHO + ELSE + DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) ) + A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) + B = Z( N )*Z( N )*DELSQ + IF( A.LT.ZERO ) THEN + TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) + ELSE + TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) + END IF + END IF +* +* It can be proved that +* D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU <= D(N)^2+RHO +* + ELSE + DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) ) + A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) + B = Z( N )*Z( N )*DELSQ +* +* The following TAU is to approximate +* SIGMA_n^2 - D( N )*D( N ) +* + IF( A.LT.ZERO ) THEN + TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) + ELSE + TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) + END IF +* +* It can be proved that +* D(N)^2 < D(N)^2+TAU < SIGMA(N)^2 < D(N)^2+RHO/2 +* + END IF +* +* The following ETA is to approximate SIGMA_n - D( N ) +* + ETA = TAU / ( D( N )+SQRT( D( N )*D( N )+TAU ) ) +* + SIGMA = D( N ) + ETA + DO 30 J = 1, N + DELTA( J ) = ( D( J )-D( I ) ) - ETA + WORK( J ) = D( J ) + D( I ) + ETA + 30 CONTINUE +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 40 J = 1, II + TEMP = Z( J ) / ( DELTA( J )*WORK( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 40 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + TEMP = Z( N ) / ( DELTA( N )*WORK( N ) ) + PHI = Z( N )*TEMP + DPHI = TEMP*TEMP + ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + + $ ABS( TAU )*( DPSI+DPHI ) +* + W = RHOINV + PHI + PSI +* +* Test for convergence +* + IF( ABS( W ).LE.EPS*ERRETM ) THEN + GO TO 240 + END IF +* +* Calculate the new step +* + NITER = NITER + 1 + DTNSQ1 = WORK( N-1 )*DELTA( N-1 ) + DTNSQ = WORK( N )*DELTA( N ) + C = W - DTNSQ1*DPSI - DTNSQ*DPHI + A = ( DTNSQ+DTNSQ1 )*W - DTNSQ*DTNSQ1*( DPSI+DPHI ) + B = DTNSQ*DTNSQ1*W + IF( C.LT.ZERO ) + $ C = ABS( C ) + IF( C.EQ.ZERO ) THEN + ETA = RHO - SIGMA*SIGMA + ELSE IF( A.GE.ZERO ) THEN + ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF +* +* Note, eta should be positive if w is negative, and +* eta should be negative otherwise. However, +* if for some reason caused by roundoff, eta*w > 0, +* we simply use one Newton step instead. This way +* will guarantee eta*w < 0. +* + IF( W*ETA.GT.ZERO ) + $ ETA = -W / ( DPSI+DPHI ) + TEMP = ETA - DTNSQ + IF( TEMP.GT.RHO ) + $ ETA = RHO + DTNSQ +* + TAU = TAU + ETA + ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) ) + DO 50 J = 1, N + DELTA( J ) = DELTA( J ) - ETA + WORK( J ) = WORK( J ) + ETA + 50 CONTINUE +* + SIGMA = SIGMA + ETA +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 60 J = 1, II + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 60 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + TEMP = Z( N ) / ( WORK( N )*DELTA( N ) ) + PHI = Z( N )*TEMP + DPHI = TEMP*TEMP + ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + + $ ABS( TAU )*( DPSI+DPHI ) +* + W = RHOINV + PHI + PSI +* +* Main loop to update the values of the array DELTA +* + ITER = NITER + 1 +* + DO 90 NITER = ITER, MAXIT +* +* Test for convergence +* + IF( ABS( W ).LE.EPS*ERRETM ) THEN + GO TO 240 + END IF +* +* Calculate the new step +* + DTNSQ1 = WORK( N-1 )*DELTA( N-1 ) + DTNSQ = WORK( N )*DELTA( N ) + C = W - DTNSQ1*DPSI - DTNSQ*DPHI + A = ( DTNSQ+DTNSQ1 )*W - DTNSQ1*DTNSQ*( DPSI+DPHI ) + B = DTNSQ1*DTNSQ*W + IF( A.GE.ZERO ) THEN + ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF +* +* Note, eta should be positive if w is negative, and +* eta should be negative otherwise. However, +* if for some reason caused by roundoff, eta*w > 0, +* we simply use one Newton step instead. This way +* will guarantee eta*w < 0. +* + IF( W*ETA.GT.ZERO ) + $ ETA = -W / ( DPSI+DPHI ) + TEMP = ETA - DTNSQ + IF( TEMP.LE.ZERO ) + $ ETA = ETA / TWO +* + TAU = TAU + ETA + ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) ) + DO 70 J = 1, N + DELTA( J ) = DELTA( J ) - ETA + WORK( J ) = WORK( J ) + ETA + 70 CONTINUE +* + SIGMA = SIGMA + ETA +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 80 J = 1, II + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 80 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + TEMP = Z( N ) / ( WORK( N )*DELTA( N ) ) + PHI = Z( N )*TEMP + DPHI = TEMP*TEMP + ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + + $ ABS( TAU )*( DPSI+DPHI ) +* + W = RHOINV + PHI + PSI + 90 CONTINUE +* +* Return with INFO = 1, NITER = MAXIT and not converged +* + INFO = 1 + GO TO 240 +* +* End for the case I = N +* + ELSE +* +* The case for I < N +* + NITER = 1 + IP1 = I + 1 +* +* Calculate initial guess +* + DELSQ = ( D( IP1 )-D( I ) )*( D( IP1 )+D( I ) ) + DELSQ2 = DELSQ / TWO + TEMP = DELSQ2 / ( D( I )+SQRT( D( I )*D( I )+DELSQ2 ) ) + DO 100 J = 1, N + WORK( J ) = D( J ) + D( I ) + TEMP + DELTA( J ) = ( D( J )-D( I ) ) - TEMP + 100 CONTINUE +* + PSI = ZERO + DO 110 J = 1, I - 1 + PSI = PSI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) ) + 110 CONTINUE +* + PHI = ZERO + DO 120 J = N, I + 2, -1 + PHI = PHI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) ) + 120 CONTINUE + C = RHOINV + PSI + PHI + W = C + Z( I )*Z( I ) / ( WORK( I )*DELTA( I ) ) + + $ Z( IP1 )*Z( IP1 ) / ( WORK( IP1 )*DELTA( IP1 ) ) +* + IF( W.GT.ZERO ) THEN +* +* d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2 +* +* We choose d(i) as origin. +* + ORGATI = .TRUE. + SG2LB = ZERO + SG2UB = DELSQ2 + A = C*DELSQ + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 ) + B = Z( I )*Z( I )*DELSQ + IF( A.GT.ZERO ) THEN + TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + ELSE + TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + END IF +* +* TAU now is an estimation of SIGMA^2 - D( I )^2. The +* following, however, is the corresponding estimation of +* SIGMA - D( I ). +* + ETA = TAU / ( D( I )+SQRT( D( I )*D( I )+TAU ) ) + ELSE +* +* (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2 +* +* We choose d(i+1) as origin. +* + ORGATI = .FALSE. + SG2LB = -DELSQ2 + SG2UB = ZERO + A = C*DELSQ - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 ) + B = Z( IP1 )*Z( IP1 )*DELSQ + IF( A.LT.ZERO ) THEN + TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) ) + ELSE + TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C ) + END IF +* +* TAU now is an estimation of SIGMA^2 - D( IP1 )^2. The +* following, however, is the corresponding estimation of +* SIGMA - D( IP1 ). +* + ETA = TAU / ( D( IP1 )+SQRT( ABS( D( IP1 )*D( IP1 )+ + $ TAU ) ) ) + END IF +* + IF( ORGATI ) THEN + II = I + SIGMA = D( I ) + ETA + DO 130 J = 1, N + WORK( J ) = D( J ) + D( I ) + ETA + DELTA( J ) = ( D( J )-D( I ) ) - ETA + 130 CONTINUE + ELSE + II = I + 1 + SIGMA = D( IP1 ) + ETA + DO 140 J = 1, N + WORK( J ) = D( J ) + D( IP1 ) + ETA + DELTA( J ) = ( D( J )-D( IP1 ) ) - ETA + 140 CONTINUE + END IF + IIM1 = II - 1 + IIP1 = II + 1 +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 150 J = 1, IIM1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 150 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + DPHI = ZERO + PHI = ZERO + DO 160 J = N, IIP1, -1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PHI = PHI + Z( J )*TEMP + DPHI = DPHI + TEMP*TEMP + ERRETM = ERRETM + PHI + 160 CONTINUE +* + W = RHOINV + PHI + PSI +* +* W is the value of the secular function with +* its ii-th element removed. +* + SWTCH3 = .FALSE. + IF( ORGATI ) THEN + IF( W.LT.ZERO ) + $ SWTCH3 = .TRUE. + ELSE + IF( W.GT.ZERO ) + $ SWTCH3 = .TRUE. + END IF + IF( II.EQ.1 .OR. II.EQ.N ) + $ SWTCH3 = .FALSE. +* + TEMP = Z( II ) / ( WORK( II )*DELTA( II ) ) + DW = DPSI + DPHI + TEMP*TEMP + TEMP = Z( II )*TEMP + W = W + TEMP + ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + + $ THREE*ABS( TEMP ) + ABS( TAU )*DW +* +* Test for convergence +* + IF( ABS( W ).LE.EPS*ERRETM ) THEN + GO TO 240 + END IF +* + IF( W.LE.ZERO ) THEN + SG2LB = MAX( SG2LB, TAU ) + ELSE + SG2UB = MIN( SG2UB, TAU ) + END IF +* +* Calculate the new step +* + NITER = NITER + 1 + IF( .NOT.SWTCH3 ) THEN + DTIPSQ = WORK( IP1 )*DELTA( IP1 ) + DTISQ = WORK( I )*DELTA( I ) + IF( ORGATI ) THEN + C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2 + ELSE + C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2 + END IF + A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW + B = DTIPSQ*DTISQ*W + IF( C.EQ.ZERO ) THEN + IF( A.EQ.ZERO ) THEN + IF( ORGATI ) THEN + A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*( DPSI+DPHI ) + ELSE + A = Z( IP1 )*Z( IP1 ) + DTISQ*DTISQ*( DPSI+DPHI ) + END IF + END IF + ETA = B / A + ELSE IF( A.LE.ZERO ) THEN + ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + ELSE +* +* Interpolation using THREE most relevant poles +* + DTIIM = WORK( IIM1 )*DELTA( IIM1 ) + DTIIP = WORK( IIP1 )*DELTA( IIP1 ) + TEMP = RHOINV + PSI + PHI + IF( ORGATI ) THEN + TEMP1 = Z( IIM1 ) / DTIIM + TEMP1 = TEMP1*TEMP1 + C = ( TEMP - DTIIP*( DPSI+DPHI ) ) - + $ ( D( IIM1 )-D( IIP1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1 + ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) + IF( DPSI.LT.TEMP1 ) THEN + ZZ( 3 ) = DTIIP*DTIIP*DPHI + ELSE + ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI ) + END IF + ELSE + TEMP1 = Z( IIP1 ) / DTIIP + TEMP1 = TEMP1*TEMP1 + C = ( TEMP - DTIIM*( DPSI+DPHI ) ) - + $ ( D( IIP1 )-D( IIM1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1 + IF( DPHI.LT.TEMP1 ) THEN + ZZ( 1 ) = DTIIM*DTIIM*DPSI + ELSE + ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) ) + END IF + ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) + END IF + ZZ( 2 ) = Z( II )*Z( II ) + DD( 1 ) = DTIIM + DD( 2 ) = DELTA( II )*WORK( II ) + DD( 3 ) = DTIIP + CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO ) + IF( INFO.NE.0 ) + $ GO TO 240 + END IF +* +* Note, eta should be positive if w is negative, and +* eta should be negative otherwise. However, +* if for some reason caused by roundoff, eta*w > 0, +* we simply use one Newton step instead. This way +* will guarantee eta*w < 0. +* + IF( W*ETA.GE.ZERO ) + $ ETA = -W / DW + IF( ORGATI ) THEN + TEMP1 = WORK( I )*DELTA( I ) + TEMP = ETA - TEMP1 + ELSE + TEMP1 = WORK( IP1 )*DELTA( IP1 ) + TEMP = ETA - TEMP1 + END IF + IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN + IF( W.LT.ZERO ) THEN + ETA = ( SG2UB-TAU ) / TWO + ELSE + ETA = ( SG2LB-TAU ) / TWO + END IF + END IF +* + TAU = TAU + ETA + ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) ) +* + PREW = W +* + SIGMA = SIGMA + ETA + DO 170 J = 1, N + WORK( J ) = WORK( J ) + ETA + DELTA( J ) = DELTA( J ) - ETA + 170 CONTINUE +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 180 J = 1, IIM1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 180 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + DPHI = ZERO + PHI = ZERO + DO 190 J = N, IIP1, -1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PHI = PHI + Z( J )*TEMP + DPHI = DPHI + TEMP*TEMP + ERRETM = ERRETM + PHI + 190 CONTINUE +* + TEMP = Z( II ) / ( WORK( II )*DELTA( II ) ) + DW = DPSI + DPHI + TEMP*TEMP + TEMP = Z( II )*TEMP + W = RHOINV + PHI + PSI + TEMP + ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + + $ THREE*ABS( TEMP ) + ABS( TAU )*DW +* + IF( W.LE.ZERO ) THEN + SG2LB = MAX( SG2LB, TAU ) + ELSE + SG2UB = MIN( SG2UB, TAU ) + END IF +* + SWTCH = .FALSE. + IF( ORGATI ) THEN + IF( -W.GT.ABS( PREW ) / TEN ) + $ SWTCH = .TRUE. + ELSE + IF( W.GT.ABS( PREW ) / TEN ) + $ SWTCH = .TRUE. + END IF +* +* Main loop to update the values of the array DELTA and WORK +* + ITER = NITER + 1 +* + DO 230 NITER = ITER, MAXIT +* +* Test for convergence +* + IF( ABS( W ).LE.EPS*ERRETM ) THEN + GO TO 240 + END IF +* +* Calculate the new step +* + IF( .NOT.SWTCH3 ) THEN + DTIPSQ = WORK( IP1 )*DELTA( IP1 ) + DTISQ = WORK( I )*DELTA( I ) + IF( .NOT.SWTCH ) THEN + IF( ORGATI ) THEN + C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2 + ELSE + C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2 + END IF + ELSE + TEMP = Z( II ) / ( WORK( II )*DELTA( II ) ) + IF( ORGATI ) THEN + DPSI = DPSI + TEMP*TEMP + ELSE + DPHI = DPHI + TEMP*TEMP + END IF + C = W - DTISQ*DPSI - DTIPSQ*DPHI + END IF + A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW + B = DTIPSQ*DTISQ*W + IF( C.EQ.ZERO ) THEN + IF( A.EQ.ZERO ) THEN + IF( .NOT.SWTCH ) THEN + IF( ORGATI ) THEN + A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ* + $ ( DPSI+DPHI ) + ELSE + A = Z( IP1 )*Z( IP1 ) + + $ DTISQ*DTISQ*( DPSI+DPHI ) + END IF + ELSE + A = DTISQ*DTISQ*DPSI + DTIPSQ*DTIPSQ*DPHI + END IF + END IF + ETA = B / A + ELSE IF( A.LE.ZERO ) THEN + ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + ELSE +* +* Interpolation using THREE most relevant poles +* + DTIIM = WORK( IIM1 )*DELTA( IIM1 ) + DTIIP = WORK( IIP1 )*DELTA( IIP1 ) + TEMP = RHOINV + PSI + PHI + IF( SWTCH ) THEN + C = TEMP - DTIIM*DPSI - DTIIP*DPHI + ZZ( 1 ) = DTIIM*DTIIM*DPSI + ZZ( 3 ) = DTIIP*DTIIP*DPHI + ELSE + IF( ORGATI ) THEN + TEMP1 = Z( IIM1 ) / DTIIM + TEMP1 = TEMP1*TEMP1 + TEMP2 = ( D( IIM1 )-D( IIP1 ) )* + $ ( D( IIM1 )+D( IIP1 ) )*TEMP1 + C = TEMP - DTIIP*( DPSI+DPHI ) - TEMP2 + ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) + IF( DPSI.LT.TEMP1 ) THEN + ZZ( 3 ) = DTIIP*DTIIP*DPHI + ELSE + ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI ) + END IF + ELSE + TEMP1 = Z( IIP1 ) / DTIIP + TEMP1 = TEMP1*TEMP1 + TEMP2 = ( D( IIP1 )-D( IIM1 ) )* + $ ( D( IIM1 )+D( IIP1 ) )*TEMP1 + C = TEMP - DTIIM*( DPSI+DPHI ) - TEMP2 + IF( DPHI.LT.TEMP1 ) THEN + ZZ( 1 ) = DTIIM*DTIIM*DPSI + ELSE + ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) ) + END IF + ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) + END IF + END IF + DD( 1 ) = DTIIM + DD( 2 ) = DELTA( II )*WORK( II ) + DD( 3 ) = DTIIP + CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO ) + IF( INFO.NE.0 ) + $ GO TO 240 + END IF +* +* Note, eta should be positive if w is negative, and +* eta should be negative otherwise. However, +* if for some reason caused by roundoff, eta*w > 0, +* we simply use one Newton step instead. This way +* will guarantee eta*w < 0. +* + IF( W*ETA.GE.ZERO ) + $ ETA = -W / DW + IF( ORGATI ) THEN + TEMP1 = WORK( I )*DELTA( I ) + TEMP = ETA - TEMP1 + ELSE + TEMP1 = WORK( IP1 )*DELTA( IP1 ) + TEMP = ETA - TEMP1 + END IF + IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN + IF( W.LT.ZERO ) THEN + ETA = ( SG2UB-TAU ) / TWO + ELSE + ETA = ( SG2LB-TAU ) / TWO + END IF + END IF +* + TAU = TAU + ETA + ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) ) +* + SIGMA = SIGMA + ETA + DO 200 J = 1, N + WORK( J ) = WORK( J ) + ETA + DELTA( J ) = DELTA( J ) - ETA + 200 CONTINUE +* + PREW = W +* +* Evaluate PSI and the derivative DPSI +* + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 210 J = 1, IIM1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 210 CONTINUE + ERRETM = ABS( ERRETM ) +* +* Evaluate PHI and the derivative DPHI +* + DPHI = ZERO + PHI = ZERO + DO 220 J = N, IIP1, -1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PHI = PHI + Z( J )*TEMP + DPHI = DPHI + TEMP*TEMP + ERRETM = ERRETM + PHI + 220 CONTINUE +* + TEMP = Z( II ) / ( WORK( II )*DELTA( II ) ) + DW = DPSI + DPHI + TEMP*TEMP + TEMP = Z( II )*TEMP + W = RHOINV + PHI + PSI + TEMP + ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + + $ THREE*ABS( TEMP ) + ABS( TAU )*DW + IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN ) + $ SWTCH = .NOT.SWTCH +* + IF( W.LE.ZERO ) THEN + SG2LB = MAX( SG2LB, TAU ) + ELSE + SG2UB = MIN( SG2UB, TAU ) + END IF +* + 230 CONTINUE +* +* Return with INFO = 1, NITER = MAXIT and not converged +* + INFO = 1 +* + END IF +* + 240 CONTINUE + RETURN +* +* End of DLASD4 +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlasd4} (let* ((maxit 20) (zero 0.0) @@ -60203,40 +83951,176 @@ SYNOPSIS DOUBLE PRECISION D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 ) -PURPOSE - This subroutine computes the square root of the I-th eigenvalue of a - positive symmetric rank-one modification of a 2-by-2 diagonal matrix + Purpose + ======= - We also assume RHO > 0 and that the Euclidean norm of the vector Z is - one. + This subroutine computes the square root of the I-th eigenvalue + of a positive symmetric rank-one modification of a 2-by-2 diagonal + matrix + diag( D ) * diag( D ) + RHO * Z * transpose(Z) . -ARGUMENTS - I (input) INTEGER - The index of the eigenvalue to be computed. I = 1 or I = 2. + The diagonal entries in the array D are assumed to satisfy + + 0 <= D(i) < D(j) for i < j . - D (input) DOUBLE PRECISION array, dimension ( 2 ) - The original eigenvalues. We assume 0 <= D(1) < D(2). + We also assume RHO > 0 and that the Euclidean norm of the vector + Z is one. - Z (input) DOUBLE PRECISION array, dimension ( 2 ) - The components of the updating vector. + Arguments + ========= - DELTA (output) DOUBLE PRECISION array, dimension ( 2 ) - Contains (D(j) - sigma_I) in its j-th component. The vector - DELTA contains the information necessary to construct the eigen- - vectors. + I (input) INTEGER + The index of the eigenvalue to be computed. I = 1 or I = 2. - RHO (input) DOUBLE PRECISION - The scalar in the symmetric updating formula. + D (input) DOUBLE PRECISION array, dimension ( 2 ) + The original eigenvalues. We assume 0 <= D(1) < D(2). - DSIGMA (output) DOUBLE PRECISION The computed sigma_I, the I-th - updated eigenvalue. + Z (input) DOUBLE PRECISION array, dimension ( 2 ) + The components of the updating vector. - WORK (workspace) DOUBLE PRECISION array, dimension ( 2 ) - WORK contains (D(j) + sigma_I) in its j-th component. + DELTA (output) DOUBLE PRECISION array, dimension ( 2 ) + Contains (D(j) - lambda_I) in its j-th component. + The vector DELTA contains the information necessary + to construct the eigenvectors. + + RHO (input) DOUBLE PRECISION + The scalar in the symmetric updating formula. + + DSIGMA (output) DOUBLE PRECISION + The computed lambda_I, the I-th updated eigenvalue. + + WORK (workspace) DOUBLE PRECISION array, dimension ( 2 ) + WORK contains (D(j) + sigma_I) in its j-th component. + + Further Details + =============== + + Based on contributions by + Ren-Cang Li, Computer Science Division, University of California + at Berkeley, USA \end{chunk} +\begin{verbatim} + SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, +* Courant Institute, NAG Ltd., and Rice University +* June 30, 1999 +* +* .. Scalar Arguments .. + INTEGER I + DOUBLE PRECISION DSIGMA, RHO +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ THREE = 3.0D+0, FOUR = 4.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION B, C, DEL, DELSQ, TAU, W +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +* .. +* .. Executable Statements .. +* + DEL = D( 2 ) - D( 1 ) + DELSQ = DEL*( D( 2 )+D( 1 ) ) + IF( I.EQ.1 ) THEN + W = ONE + FOUR*RHO*( Z( 2 )*Z( 2 ) / ( D( 1 )+THREE*D( 2 ) )- + $ Z( 1 )*Z( 1 ) / ( THREE*D( 1 )+D( 2 ) ) ) / DEL + IF( W.GT.ZERO ) THEN + B = DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) + C = RHO*Z( 1 )*Z( 1 )*DELSQ +* +* B > ZERO, always +* +* The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 ) +* + TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) ) +* +* The following TAU is DSIGMA - D( 1 ) +* + TAU = TAU / ( D( 1 )+SQRT( D( 1 )*D( 1 )+TAU ) ) + DSIGMA = D( 1 ) + TAU + DELTA( 1 ) = -TAU + DELTA( 2 ) = DEL - TAU + WORK( 1 ) = TWO*D( 1 ) + TAU + WORK( 2 ) = ( D( 1 )+TAU ) + D( 2 ) +* DELTA( 1 ) = -Z( 1 ) / TAU +* DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) + ELSE + B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) + C = RHO*Z( 2 )*Z( 2 )*DELSQ +* +* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) +* + IF( B.GT.ZERO ) THEN + TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) ) + ELSE + TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO + END IF +* +* The following TAU is DSIGMA - D( 2 ) +* + TAU = TAU / ( D( 2 )+SQRT( ABS( D( 2 )*D( 2 )+TAU ) ) ) + DSIGMA = D( 2 ) + TAU + DELTA( 1 ) = -( DEL+TAU ) + DELTA( 2 ) = -TAU + WORK( 1 ) = D( 1 ) + TAU + D( 2 ) + WORK( 2 ) = TWO*D( 2 ) + TAU +* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) +* DELTA( 2 ) = -Z( 2 ) / TAU + END IF +* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) +* DELTA( 1 ) = DELTA( 1 ) / TEMP +* DELTA( 2 ) = DELTA( 2 ) / TEMP + ELSE +* +* Now I=2 +* + B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) + C = RHO*Z( 2 )*Z( 2 )*DELSQ +* +* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) +* + IF( B.GT.ZERO ) THEN + TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO + ELSE + TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) ) + END IF +* +* The following TAU is DSIGMA - D( 2 ) +* + TAU = TAU / ( D( 2 )+SQRT( D( 2 )*D( 2 )+TAU ) ) + DSIGMA = D( 2 ) + TAU + DELTA( 1 ) = -( DEL+TAU ) + DELTA( 2 ) = -TAU + WORK( 1 ) = D( 1 ) + TAU + D( 2 ) + WORK( 2 ) = TWO*D( 2 ) + TAU +* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) +* DELTA( 2 ) = -Z( 2 ) / TAU +* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) +* DELTA( 1 ) = DELTA( 1 ) / TEMP +* DELTA( 2 ) = DELTA( 2 ) / TEMP + END IF + RETURN +* +* End of DLASD5 +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlasd5} (let* ((zero 0.0) (one 1.0) (two 2.0) (three 3.0) (four 4.0)) (declare (type (double-float 0.0 0.0) zero) @@ -60487,171 +84371,317 @@ SYNOPSIS LDGNUM, * ), POLES( LDGNUM, * ), VF( * ), VL( * ), WORK( * ), Z( * ) -PURPOSE - DLASD6 computes the SVD of an updated upper bidiagonal matrix B - obtained by merging two smaller ones by appending a row. This routine - is used only for the problem which requires all singular values and - optionally singular vector matrices in factored form. B is an N-by-M - matrix with N = NL + NR + 1 and M = N + SQRE. A related subroutine, - DLASD1, handles the case in which all singular values and singular vec- - tors of the bidiagonal matrix are desired. - - DLASD6 computes the SVD as follows: - - ( D1(in) 0 0 0 ) - B = U(in) * ( Z1' a Z2' b ) * VT(in) - ( 0 0 D2(in) 0 ) - - = U(out) * ( D(out) 0) * VT(out) + Purpose + ======= + + DLASD6 computes the SVD of an updated upper bidiagonal matrix B + obtained by merging two smaller ones by appending a row. This + routine is used only for the problem which requires all singular + values and optionally singular vector matrices in factored form. + B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE. + A related subroutine, DLASD1, handles the case in which all singular + values and singular vectors of the bidiagonal matrix are desired. + + DLASD6 computes the SVD as follows: + + ( D1(in) 0 0 0 ) + B = U(in) * ( Z1' a Z2' b ) * VT(in) + ( 0 0 D2(in) 0 ) + + = U(out) * ( D(out) 0) * VT(out) + + where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M + with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros + elsewhere; and the entry b is empty if SQRE = 0. + + The singular values of B can be computed using D1, D2, the first + components of all the right singular vectors of the lower block, and + the last components of all the right singular vectors of the upper + block. These components are stored and updated in VF and VL, + respectively, in DLASD6. Hence U and VT are not explicitly + referenced. + + The singular values are stored in D. The algorithm consists of two + stages: + + The first stage consists of deflating the size of the problem + when there are multiple singular values or if there is a zero + in the Z vector. For each such occurence the dimension of the + secular equation problem is reduced by one. This stage is + performed by the routine DLASD7. + + The second stage consists of calculating the updated + singular values. This is done by finding the roots of the + secular equation via the routine DLASD4 (as called by DLASD8). + This routine also updates VF and VL and computes the distances + between the updated singular values and the old singular + values. + + DLASD6 is called from DLASDA. + + Arguments + ========= + + ICOMPQ (input) INTEGER + Specifies whether singular vectors are to be computed in + factored form: + = 0: Compute singular values only. + = 1: Compute singular vectors in factored form as well. + + NL (input) INTEGER + The row dimension of the upper block. NL >= 1. + + NR (input) INTEGER + The row dimension of the lower block. NR >= 1. + + SQRE (input) INTEGER + = 0: the lower block is an NR-by-NR square matrix. + = 1: the lower block is an NR-by-(NR+1) rectangular matrix. + + The bidiagonal matrix has row dimension N = NL + NR + 1, + and column dimension M = N + SQRE. + + D (input/output) DOUBLE PRECISION array, dimension ( NL+NR+1 ). + On entry D(1:NL,1:NL) contains the singular values of the + upper block, and D(NL+2:N) contains the singular values + of the lower block. On exit D(1:N) contains the singular + values of the modified matrix. + + VF (input/output) DOUBLE PRECISION array, dimension ( M ) + On entry, VF(1:NL+1) contains the first components of all + right singular vectors of the upper block; and VF(NL+2:M) + contains the first components of all right singular vectors + of the lower block. On exit, VF contains the first components + of all right singular vectors of the bidiagonal matrix. + + VL (input/output) DOUBLE PRECISION array, dimension ( M ) + On entry, VL(1:NL+1) contains the last components of all + right singular vectors of the upper block; and VL(NL+2:M) + contains the last components of all right singular vectors of + the lower block. On exit, VL contains the last components of + all right singular vectors of the bidiagonal matrix. + + ALPHA (input) DOUBLE PRECISION + Contains the diagonal element associated with the added row. + + BETA (input) DOUBLE PRECISION + Contains the off-diagonal element associated with the added + row. + + IDXQ (output) INTEGER array, dimension ( N ) + This contains the permutation which will reintegrate the + subproblem just solved back into sorted order, i.e. + D( IDXQ( I = 1, N ) ) will be in ascending order. + + PERM (output) INTEGER array, dimension ( N ) + The permutations (from deflation and sorting) to be applied + to each block. Not referenced if ICOMPQ = 0. + + GIVPTR (output) INTEGER + The number of Givens rotations which took place in this + subproblem. Not referenced if ICOMPQ = 0. - where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M - with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros else- - where; and the entry b is empty if SQRE = 0. + GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 ) + Each pair of numbers indicates a pair of columns to take place + in a Givens rotation. Not referenced if ICOMPQ = 0. + + LDGCOL (input) INTEGER + leading dimension of GIVCOL, must be at least N. - The singular values of B can be computed using D1, D2, the first compo- - nents of all the right singular vectors of the lower block, and the - last components of all the right singular vectors of the upper block. - These components are stored and updated in VF and VL, respectively, in - DLASD6. Hence U and VT are not explicitly referenced. + GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) + Each number indicates the C or S value to be used in the + corresponding Givens rotation. Not referenced if ICOMPQ = 0. + + LDGNUM (input) INTEGER + The leading dimension of GIVNUM and POLES, must be at least N. + + POLES (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) + On exit, POLES(1,*) is an array containing the new singular + values obtained from solving the secular equation, and + POLES(2,*) is an array containing the poles in the secular + equation. Not referenced if ICOMPQ = 0. - The singular values are stored in D. The algorithm consists of two - stages: + DIFL (output) DOUBLE PRECISION array, dimension ( N ) + On exit, DIFL(I) is the distance between I-th updated + (undeflated) singular value and the I-th (undeflated) old + singular value. + + DIFR (output) DOUBLE PRECISION array, + dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and + dimension ( N ) if ICOMPQ = 0. + On exit, DIFR(I, 1) is the distance between I-th updated + (undeflated) singular value and the I+1-th (undeflated) old + singular value. - The first stage consists of deflating the size of the problem - when there are multiple singular values or if there is a zero - in the Z vector. For each such occurence the dimension of the - secular equation problem is reduced by one. This stage is - performed by the routine DLASD7. + If ICOMPQ = 1, DIFR(1:K,2) is an array containing the + normalizing factors for the right singular vector matrix. - The second stage consists of calculating the updated - singular values. This is done by finding the roots of the - secular equation via the routine DLASD4 (as called by DLASD8). - This routine also updates VF and VL and computes the distances - between the updated singular values and the old singular - values. - - DLASD6 is called from DLASDA. - - -ARGUMENTS - ICOMPQ (input) INTEGER Specifies whether singular vectors are to be - computed in factored form: - = 0: Compute singular values only. - = 1: Compute singular vectors in factored form as well. - - NL (input) INTEGER - The row dimension of the upper block. NL >= 1. - - NR (input) INTEGER - The row dimension of the lower block. NR >= 1. + See DLASD8 for details on DIFL and DIFR. - SQRE (input) INTEGER - = 0: the lower block is an NR-by-NR square matrix. - = 1: the lower block is an NR-by-(NR+1) rectangular matrix. + Z (output) DOUBLE PRECISION array, dimension ( M ) + The first elements of this array contain the components + of the deflation-adjusted updating row vector. - The bidiagonal matrix has row dimension N = NL + NR + 1, and - column dimension M = N + SQRE. + K (output) INTEGER + Contains the dimension of the non-deflated matrix, + This is the order of the related secular equation. 1 <= K <=N. - D (input/output) DOUBLE PRECISION array, dimension ( NL+NR+1 ). - On entry D(1:NL,1:NL) contains the singular values of the - upper block, and D(NL+2:N) contains the singular values - of the lower block. On exit D(1:N) contains the singular values - of the modified matrix. + C (output) DOUBLE PRECISION + C contains garbage if SQRE =0 and the C-value of a Givens + rotation related to the right null space if SQRE = 1. - VF (input/output) DOUBLE PRECISION array, dimension ( M ) - On entry, VF(1:NL+1) contains the first components of all - right singular vectors of the upper block; and VF(NL+2:M) con- - tains the first components of all right singular vectors of the - lower block. On exit, VF contains the first components of all - right singular vectors of the bidiagonal matrix. + S (output) DOUBLE PRECISION + S contains garbage if SQRE =0 and the S-value of a Givens + rotation related to the right null space if SQRE = 1. - VL (input/output) DOUBLE PRECISION array, dimension ( M ) - On entry, VL(1:NL+1) contains the last components of all - right singular vectors of the upper block; and VL(NL+2:M) con- - tains the last components of all right singular vectors of the - lower block. On exit, VL contains the last components of all - right singular vectors of the bidiagonal matrix. + WORK (workspace) DOUBLE PRECISION array, dimension ( 4 * M ) - ALPHA (input/output) DOUBLE PRECISION - Contains the diagonal element associated with the added row. + IWORK (workspace) INTEGER array, dimension ( 3 * N ) - BETA (input/output) DOUBLE PRECISION - Contains the off-diagonal element associated with the added row. + INFO (output) INTEGER + = 0: successful exit. + < 0: if INFO = -i, the i-th argument had an illegal value. + > 0: if INFO = 1, an singular value did not converge + + Further Details + =============== - IDXQ (output) INTEGER array, dimension ( N ) - This contains the permutation which will reintegrate the sub- - problem just solved back into sorted order, i.e. D( IDXQ( I = - 1, N ) ) will be in ascending order. + Based on contributions by + Ming Gu and Huan Ren, Computer Science Division, University of + California at Berkeley, USA - PERM (output) INTEGER array, dimension ( N ) - The permutations (from deflation and sorting) to be applied to - each block. Not referenced if ICOMPQ = 0. - - GIVPTR (output) INTEGER The number of Givens rotations which - took place in this subproblem. Not referenced if ICOMPQ = 0. - - GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 ) Each pair - of numbers indicates a pair of columns to take place in a Givens - rotation. Not referenced if ICOMPQ = 0. - - LDGCOL (input) INTEGER leading dimension of GIVCOL, must be at - least N. - - GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) - Each number indicates the C or S value to be used in the corre- - sponding Givens rotation. Not referenced if ICOMPQ = 0. - - LDGNUM (input) INTEGER The leading dimension of GIVNUM and - POLES, must be at least N. - - POLES (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) - On exit, POLES(1,*) is an array containing the new singular val- - ues obtained from solving the secular equation, and POLES(2,*) - is an array containing the poles in the secular equation. Not - referenced if ICOMPQ = 0. - - DIFL (output) DOUBLE PRECISION array, dimension ( N ) - On exit, DIFL(I) is the distance between I-th updated (unde- - flated) singular value and the I-th (undeflated) old singular - value. - - DIFR (output) DOUBLE PRECISION array, - dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and dimension ( N ) if - ICOMPQ = 0. On exit, DIFR(I, 1) is the distance between I-th - updated (undeflated) singular value and the I+1-th (undeflated) - old singular value. - - If ICOMPQ = 1, DIFR(1:K,2) is an array containing the normaliz- - ing factors for the right singular vector matrix. - - See DLASD8 for details on DIFL and DIFR. - - Z (output) DOUBLE PRECISION array, dimension ( M ) - The first elements of this array contain the components of the - deflation-adjusted updating row vector. - - K (output) INTEGER - Contains the dimension of the non-deflated matrix, This is the - order of the related secular equation. 1 <= K <=N. - - C (output) DOUBLE PRECISION - C contains garbage if SQRE =0 and the C-value of a Givens rota- - tion related to the right null space if SQRE = 1. - - S (output) DOUBLE PRECISION - S contains garbage if SQRE =0 and the S-value of a Givens rota- - tion related to the right null space if SQRE = 1. - - WORK (workspace) DOUBLE PRECISION array, dimension ( 4 * M ) - - IWORK (workspace) INTEGER array, dimension ( 3 * N ) +\end{chunk} - INFO (output) INTEGER - = 0: successful exit. - < 0: if INFO = -i, the i-th argument had an illegal value. - > 0: if INFO = 1, an singular value did not converge +\begin{verbatim} + SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, + $ IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, + $ LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, + $ IWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* June 30, 1999 +* +* .. Scalar Arguments .. + INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, + $ NR, SQRE + DOUBLE PRECISION ALPHA, BETA, C, S +* .. +* .. Array Arguments .. + INTEGER GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ), + $ PERM( * ) + DOUBLE PRECISION D( * ), DIFL( * ), DIFR( * ), + $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ), + $ VF( * ), VL( * ), WORK( * ), Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IDX, IDXC, IDXP, ISIGMA, IVFW, IVLW, IW, M, + $ N, N1, N2 + DOUBLE PRECISION ORGNRM +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLAMRG, DLASCL, DLASD7, DLASD8, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + N = NL + NR + 1 + M = N + SQRE +* + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( NL.LT.1 ) THEN + INFO = -2 + ELSE IF( NR.LT.1 ) THEN + INFO = -3 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -4 + ELSE IF( LDGCOL.LT.N ) THEN + INFO = -14 + ELSE IF( LDGNUM.LT.N ) THEN + INFO = -16 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD6', -INFO ) + RETURN + END IF +* +* The following values are for bookkeeping purposes only. They are +* integer pointers which indicate the portion of the workspace +* used by a particular array in DLASD7 and DLASD8. +* + ISIGMA = 1 + IW = ISIGMA + N + IVFW = IW + M + IVLW = IVFW + M +* + IDX = 1 + IDXC = IDX + N + IDXP = IDXC + N +* +* Scale. +* + ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) ) + D( NL+1 ) = ZERO + DO 10 I = 1, N + IF( ABS( D( I ) ).GT.ORGNRM ) THEN + ORGNRM = ABS( D( I ) ) + END IF + 10 CONTINUE + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO ) + ALPHA = ALPHA / ORGNRM + BETA = BETA / ORGNRM +* +* Sort and Deflate singular values. +* + CALL DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, WORK( IW ), VF, + $ WORK( IVFW ), VL, WORK( IVLW ), ALPHA, BETA, + $ WORK( ISIGMA ), IWORK( IDX ), IWORK( IDXP ), IDXQ, + $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S, + $ INFO ) +* +* Solve Secular Equation, compute DIFL, DIFR, and update VF, VL. +* + CALL DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDGNUM, + $ WORK( ISIGMA ), WORK( IW ), INFO ) +* +* Save the poles if ICOMPQ = 1. +* + IF( ICOMPQ.EQ.1 ) THEN + CALL DCOPY( K, D, 1, POLES( 1, 1 ), 1 ) + CALL DCOPY( K, WORK( ISIGMA ), 1, POLES( 1, 2 ), 1 ) + END IF +* +* Unscale. +* + CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) +* +* Prepare the IDXQ sorting permutation. +* + N1 = K + N2 = N - K + CALL DLAMRG( N1, N2, D, 1, -1, IDXQ ) +* + RETURN +* +* End of DLASD6 +* + END -\end{chunk} +\end{verbatim} \begin{chunk}{LAPACK dlasd6} (let* ((one 1.0) (zero 0.0)) @@ -60857,136 +84887,456 @@ SYNOPSIS VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ), ZW( * ) -PURPOSE - DLASD7 merges the two sets of singular values together into a single - sorted set. Then it tries to deflate the size of the problem. There are - two ways in which deflation can occur: when two or more singular val- - ues are close together or if there is a tiny entry in the Z vector. For - each such occurrence the order of the related secular equation problem - is reduced by one. - - DLASD7 is called from DLASD6. - - -ARGUMENTS - ICOMPQ (input) INTEGER - Specifies whether singular vectors are to be computed in com- - pact form, as follows: - = 0: Compute singular values only. - = 1: Compute singular vectors of upper bidiagonal matrix in - compact form. - - NL (input) INTEGER - The row dimension of the upper block. NL >= 1. - - NR (input) INTEGER - The row dimension of the lower block. NR >= 1. - - SQRE (input) INTEGER - = 0: the lower block is an NR-by-NR square matrix. - = 1: the lower block is an NR-by-(NR+1) rectangular matrix. - - The bidiagonal matrix has N = NL + NR + 1 rows and M = N + SQRE - >= N columns. - - K (output) INTEGER - Contains the dimension of the non-deflated matrix, this is the - order of the related secular equation. 1 <= K <=N. + Purpose + ======= + + DLASD7 merges the two sets of singular values together into a single + sorted set. Then it tries to deflate the size of the problem. There + are two ways in which deflation can occur: when two or more singular + values are close together or if there is a tiny entry in the Z + vector. For each such occurrence the order of the related + secular equation problem is reduced by one. + + DLASD7 is called from DLASD6. + + Arguments + ========= + + ICOMPQ (input) INTEGER + Specifies whether singular vectors are to be computed + in compact form, as follows: + = 0: Compute singular values only. + = 1: Compute singular vectors of upper + bidiagonal matrix in compact form. + + NL (input) INTEGER + The row dimension of the upper block. NL >= 1. + + NR (input) INTEGER + The row dimension of the lower block. NR >= 1. + + SQRE (input) INTEGER + = 0: the lower block is an NR-by-NR square matrix. + = 1: the lower block is an NR-by-(NR+1) rectangular matrix. + + The bidiagonal matrix has + N = NL + NR + 1 rows and + M = N + SQRE >= N columns. + + K (output) INTEGER + Contains the dimension of the non-deflated matrix, this is + the order of the related secular equation. 1 <= K <=N. + + D (input/output) DOUBLE PRECISION array, dimension ( N ) + On entry D contains the singular values of the two submatrices + to be combined. On exit D contains the trailing (N-K) updated + singular values (those which were deflated) sorted into + increasing order. - D (input/output) DOUBLE PRECISION array, dimension ( N ) - On entry D contains the singular values of the two submatrices - to be combined. On exit D contains the trailing (N-K) updated - singular values (those which were deflated) sorted into increas- - ing order. + Z (output) DOUBLE PRECISION array, dimension ( M ) + On exit Z contains the updating row vector in the secular + equation. - Z (output) DOUBLE PRECISION array, dimension ( M ) - On exit Z contains the updating row vector in the secular equa- - tion. + ZW (workspace) DOUBLE PRECISION array, dimension ( M ) + Workspace for Z. - ZW (workspace) DOUBLE PRECISION array, dimension ( M ) - Workspace for Z. + VF (input/output) DOUBLE PRECISION array, dimension ( M ) + On entry, VF(1:NL+1) contains the first components of all + right singular vectors of the upper block; and VF(NL+2:M) + contains the first components of all right singular vectors + of the lower block. On exit, VF contains the first components + of all right singular vectors of the bidiagonal matrix. - VF (input/output) DOUBLE PRECISION array, dimension ( M ) - On entry, VF(1:NL+1) contains the first components of all - right singular vectors of the upper block; and VF(NL+2:M) con- - tains the first components of all right singular vectors of the - lower block. On exit, VF contains the first components of all - right singular vectors of the bidiagonal matrix. + VFW (workspace) DOUBLE PRECISION array, dimension ( M ) + Workspace for VF. - VFW (workspace) DOUBLE PRECISION array, dimension ( M ) - Workspace for VF. + VL (input/output) DOUBLE PRECISION array, dimension ( M ) + On entry, VL(1:NL+1) contains the last components of all + right singular vectors of the upper block; and VL(NL+2:M) + contains the last components of all right singular vectors + of the lower block. On exit, VL contains the last components + of all right singular vectors of the bidiagonal matrix. - VL (input/output) DOUBLE PRECISION array, dimension ( M ) - On entry, VL(1:NL+1) contains the last components of all - right singular vectors of the upper block; and VL(NL+2:M) con- - tains the last components of all right singular vectors of the - lower block. On exit, VL contains the last components of all - right singular vectors of the bidiagonal matrix. + VLW (workspace) DOUBLE PRECISION array, dimension ( M ) + Workspace for VL. - VLW (workspace) DOUBLE PRECISION array, dimension ( M ) - Workspace for VL. + ALPHA (input) DOUBLE PRECISION + Contains the diagonal element associated with the added row. - ALPHA (input) DOUBLE PRECISION - Contains the diagonal element associated with the added row. + BETA (input) DOUBLE PRECISION + Contains the off-diagonal element associated with the added + row. - BETA (input) DOUBLE PRECISION - Contains the off-diagonal element associated with the added row. + DSIGMA (output) DOUBLE PRECISION array, dimension ( N ) + Contains a copy of the diagonal elements (K-1 singular values + and one zero) in the secular equation. - DSIGMA (output) DOUBLE PRECISION array, dimension ( N ) Contains - a copy of the diagonal elements (K-1 singular values and one - zero) in the secular equation. + IDX (workspace) INTEGER array, dimension ( N ) + This will contain the permutation used to sort the contents of + D into ascending order. - IDX (workspace) INTEGER array, dimension ( N ) - This will contain the permutation used to sort the contents of D - into ascending order. + IDXP (workspace) INTEGER array, dimension ( N ) + This will contain the permutation used to place deflated + values of D at the end of the array. On output IDXP(2:K) + points to the nondeflated D-values and IDXP(K+1:N) + points to the deflated singular values. - IDXP (workspace) INTEGER array, dimension ( N ) - This will contain the permutation used to place deflated values - of D at the end of the array. On output IDXP(2:K) - points to the nondeflated D-values and IDXP(K+1:N) points to the - deflated singular values. + IDXQ (input) INTEGER array, dimension ( N ) + This contains the permutation which separately sorts the two + sub-problems in D into ascending order. Note that entries in + the first half of this permutation must first be moved one + position backward; and entries in the second half + must first have NL+1 added to their values. + + PERM (output) INTEGER array, dimension ( N ) + The permutations (from deflation and sorting) to be applied + to each singular block. Not referenced if ICOMPQ = 0. + + GIVPTR (output) INTEGER + The number of Givens rotations which took place in this + subproblem. Not referenced if ICOMPQ = 0. - IDXQ (input) INTEGER array, dimension ( N ) - This contains the permutation which separately sorts the two - sub-problems in D into ascending order. Note that entries in - the first half of this permutation must first be moved one posi- - tion backward; and entries in the second half must first have - NL+1 added to their values. + GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 ) + Each pair of numbers indicates a pair of columns to take place + in a Givens rotation. Not referenced if ICOMPQ = 0. + + LDGCOL (input) INTEGER + The leading dimension of GIVCOL, must be at least N. + + GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) + Each number indicates the C or S value to be used in the + corresponding Givens rotation. Not referenced if ICOMPQ = 0. - PERM (output) INTEGER array, dimension ( N ) - The permutations (from deflation and sorting) to be applied to - each singular block. Not referenced if ICOMPQ = 0. + LDGNUM (input) INTEGER + The leading dimension of GIVNUM, must be at least N. + + C (output) DOUBLE PRECISION + C contains garbage if SQRE =0 and the C-value of a Givens + rotation related to the right null space if SQRE = 1. + + S (output) DOUBLE PRECISION + S contains garbage if SQRE =0 and the S-value of a Givens + rotation related to the right null space if SQRE = 1. + + INFO (output) INTEGER + = 0: successful exit. + < 0: if INFO = -i, the i-th argument had an illegal value. + + Further Details + =============== + + Based on contributions by + Ming Gu and Huan Ren, Computer Science Division, University of + California at Berkeley, USA - GIVPTR (output) INTEGER The number of Givens rotations which - took place in this subproblem. Not referenced if ICOMPQ = 0. - - GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 ) Each pair - of numbers indicates a pair of columns to take place in a Givens - rotation. Not referenced if ICOMPQ = 0. - - LDGCOL (input) INTEGER The leading dimension of GIVCOL, must be - at least N. - - GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) - Each number indicates the C or S value to be used in the corre- - sponding Givens rotation. Not referenced if ICOMPQ = 0. - - LDGNUM (input) INTEGER The leading dimension of GIVNUM, must be - at least N. - - C (output) DOUBLE PRECISION - C contains garbage if SQRE =0 and the C-value of a Givens rota- - tion related to the right null space if SQRE = 1. - - S (output) DOUBLE PRECISION - S contains garbage if SQRE =0 and the S-value of a Givens rota- - tion related to the right null space if SQRE = 1. +\end{chunk} - INFO (output) INTEGER - = 0: successful exit. - < 0: if INFO = -i, the i-th argument had an illegal value. +\begin{verbatim} + SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, + $ VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, + $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, + $ C, S, INFO ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, +* Courant Institute, NAG Ltd., and Rice University +* June 30, 1999 +* +* .. Scalar Arguments .. + INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, + $ NR, SQRE + DOUBLE PRECISION ALPHA, BETA, C, S +* .. +* .. Array Arguments .. + INTEGER GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ), + $ IDXQ( * ), PERM( * ) + DOUBLE PRECISION D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ), + $ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ), + $ ZW( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, EIGHT + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ EIGHT = 8.0D+0 ) +* .. +* .. Local Scalars .. +* + INTEGER I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, N, + $ NLP1, NLP2 + DOUBLE PRECISION EPS, HLFTOL, TAU, TOL, Z1 +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLAMRG, DROT, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + N = NL + NR + 1 + M = N + SQRE +* + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( NL.LT.1 ) THEN + INFO = -2 + ELSE IF( NR.LT.1 ) THEN + INFO = -3 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -4 + ELSE IF( LDGCOL.LT.N ) THEN + INFO = -22 + ELSE IF( LDGNUM.LT.N ) THEN + INFO = -24 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD7', -INFO ) + RETURN + END IF +* + NLP1 = NL + 1 + NLP2 = NL + 2 + IF( ICOMPQ.EQ.1 ) THEN + GIVPTR = 0 + END IF +* +* Generate the first part of the vector Z and move the singular +* values in the first part of D one position backward. +* + Z1 = ALPHA*VL( NLP1 ) + VL( NLP1 ) = ZERO + TAU = VF( NLP1 ) + DO 10 I = NL, 1, -1 + Z( I+1 ) = ALPHA*VL( I ) + VL( I ) = ZERO + VF( I+1 ) = VF( I ) + D( I+1 ) = D( I ) + IDXQ( I+1 ) = IDXQ( I ) + 1 + 10 CONTINUE + VF( 1 ) = TAU +* +* Generate the second part of the vector Z. +* + DO 20 I = NLP2, M + Z( I ) = BETA*VF( I ) + VF( I ) = ZERO + 20 CONTINUE +* +* Sort the singular values into increasing order +* + DO 30 I = NLP2, N + IDXQ( I ) = IDXQ( I ) + NLP1 + 30 CONTINUE +* +* DSIGMA, IDXC, IDXC, and ZW are used as storage space. +* + DO 40 I = 2, N + DSIGMA( I ) = D( IDXQ( I ) ) + ZW( I ) = Z( IDXQ( I ) ) + VFW( I ) = VF( IDXQ( I ) ) + VLW( I ) = VL( IDXQ( I ) ) + 40 CONTINUE +* + CALL DLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) ) +* + DO 50 I = 2, N + IDXI = 1 + IDX( I ) + D( I ) = DSIGMA( IDXI ) + Z( I ) = ZW( IDXI ) + VF( I ) = VFW( IDXI ) + VL( I ) = VLW( IDXI ) + 50 CONTINUE +* +* Calculate the allowable deflation tolerence +* + EPS = DLAMCH( 'Epsilon' ) + TOL = MAX( ABS( ALPHA ), ABS( BETA ) ) + TOL = EIGHT*EIGHT*EPS*MAX( ABS( D( N ) ), TOL ) +* +* There are 2 kinds of deflation -- first a value in the z-vector +* is small, second two (or more) singular values are very close +* together (their difference is small). +* +* If the value in the z-vector is small, we simply permute the +* array so that the corresponding singular value is moved to the +* end. +* +* If two values in the D-vector are close, we perform a two-sided +* rotation designed to make one of the corresponding z-vector +* entries zero, and then permute the array so that the deflated +* singular value is moved to the end. +* +* If there are multiple singular values then the problem deflates. +* Here the number of equal singular values are found. As each equal +* singular value is found, an elementary reflector is computed to +* rotate the corresponding singular subspace so that the +* corresponding components of Z are zero in this new basis. +* + K = 1 + K2 = N + 1 + DO 60 J = 2, N + IF( ABS( Z( J ) ).LE.TOL ) THEN +* +* Deflate due to small z component. +* + K2 = K2 - 1 + IDXP( K2 ) = J + IF( J.EQ.N ) + $ GO TO 100 + ELSE + JPREV = J + GO TO 70 + END IF + 60 CONTINUE + 70 CONTINUE + J = JPREV + 80 CONTINUE + J = J + 1 + IF( J.GT.N ) + $ GO TO 90 + IF( ABS( Z( J ) ).LE.TOL ) THEN +* +* Deflate due to small z component. +* + K2 = K2 - 1 + IDXP( K2 ) = J + ELSE +* +* Check if singular values are close enough to allow deflation. +* + IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN +* +* Deflation is possible. +* + S = Z( JPREV ) + C = Z( J ) +* +* Find sqrt(a**2+b**2) without overflow or +* destructive underflow. +* + TAU = DLAPY2( C, S ) + Z( J ) = TAU + Z( JPREV ) = ZERO + C = C / TAU + S = -S / TAU +* +* Record the appropriate Givens rotation +* + IF( ICOMPQ.EQ.1 ) THEN + GIVPTR = GIVPTR + 1 + IDXJP = IDXQ( IDX( JPREV )+1 ) + IDXJ = IDXQ( IDX( J )+1 ) + IF( IDXJP.LE.NLP1 ) THEN + IDXJP = IDXJP - 1 + END IF + IF( IDXJ.LE.NLP1 ) THEN + IDXJ = IDXJ - 1 + END IF + GIVCOL( GIVPTR, 2 ) = IDXJP + GIVCOL( GIVPTR, 1 ) = IDXJ + GIVNUM( GIVPTR, 2 ) = C + GIVNUM( GIVPTR, 1 ) = S + END IF + CALL DROT( 1, VF( JPREV ), 1, VF( J ), 1, C, S ) + CALL DROT( 1, VL( JPREV ), 1, VL( J ), 1, C, S ) + K2 = K2 - 1 + IDXP( K2 ) = JPREV + JPREV = J + ELSE + K = K + 1 + ZW( K ) = Z( JPREV ) + DSIGMA( K ) = D( JPREV ) + IDXP( K ) = JPREV + JPREV = J + END IF + END IF + GO TO 80 + 90 CONTINUE +* +* Record the last singular value. +* + K = K + 1 + ZW( K ) = Z( JPREV ) + DSIGMA( K ) = D( JPREV ) + IDXP( K ) = JPREV +* + 100 CONTINUE +* +* Sort the singular values into DSIGMA. The singular values which +* were not deflated go into the first K slots of DSIGMA, except +* that DSIGMA(1) is treated separately. +* + DO 110 J = 2, N + JP = IDXP( J ) + DSIGMA( J ) = D( JP ) + VFW( J ) = VF( JP ) + VLW( J ) = VL( JP ) + 110 CONTINUE + IF( ICOMPQ.EQ.1 ) THEN + DO 120 J = 2, N + JP = IDXP( J ) + PERM( J ) = IDXQ( IDX( JP )+1 ) + IF( PERM( J ).LE.NLP1 ) THEN + PERM( J ) = PERM( J ) - 1 + END IF + 120 CONTINUE + END IF +* +* The deflated singular values go back into the last N - K slots of +* D. +* + CALL DCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 ) +* +* Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and +* VL(M). +* + DSIGMA( 1 ) = ZERO + HLFTOL = TOL / TWO + IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL ) + $ DSIGMA( 2 ) = HLFTOL + IF( M.GT.N ) THEN + Z( 1 ) = DLAPY2( Z1, Z( M ) ) + IF( Z( 1 ).LE.TOL ) THEN + C = ONE + S = ZERO + Z( 1 ) = TOL + ELSE + C = Z1 / Z( 1 ) + S = -Z( M ) / Z( 1 ) + END IF + CALL DROT( 1, VF( M ), 1, VF( 1 ), 1, C, S ) + CALL DROT( 1, VL( M ), 1, VL( 1 ), 1, C, S ) + ELSE + IF( ABS( Z1 ).LE.TOL ) THEN + Z( 1 ) = TOL + ELSE + Z( 1 ) = Z1 + END IF + END IF +* +* Restore Z, VF, and VL. +* + CALL DCOPY( K-1, ZW( 2 ), 1, Z( 2 ), 1 ) + CALL DCOPY( N-1, VFW( 2 ), 1, VF( 2 ), 1 ) + CALL DCOPY( N-1, VLW( 2 ), 1, VL( 2 ), 1 ) +* + RETURN +* +* End of DLASD7 +* + END -\end{chunk} +\end{verbatim} \begin{chunk}{LAPACK dlasd7} (let* ((zero 0.0) (one 1.0) (two 2.0) (eight 8.0)) @@ -61395,73 +85745,266 @@ SYNOPSIS DOUBLE PRECISION D( * ), DIFL( * ), DIFR( LDDIFR, * ), DSIGMA( * ), VF( * ), VL( * ), WORK( * ), Z( * ) -PURPOSE - DLASD8 finds the square roots of the roots of the secular equation, as - defined by the values in DSIGMA and Z. It makes the appropriate calls - to DLASD4, and stores, for each element in D, the distance to its two - nearest poles (elements in DSIGMA). It also updates the arrays VF and - VL, the first and last components of all the right singular vectors of - the original bidiagonal matrix. + Purpose + ======= - DLASD8 is called from DLASD6. + DLASD8 finds the square roots of the roots of the secular equation, + as defined by the values in DSIGMA and Z. It makes the appropriate + calls to DLASD4, and stores, for each element in D, the distance + to its two nearest poles (elements in DSIGMA). It also updates + the arrays VF and VL, the first and last components of all the + right singular vectors of the original bidiagonal matrix. + DLASD8 is called from DLASD6. -ARGUMENTS - ICOMPQ (input) INTEGER - Specifies whether singular vectors are to be computed in fac- - tored form in the calling routine: - = 0: Compute singular values only. - = 1: Compute singular vectors in factored form as well. + Arguments + ========= - K (input) INTEGER - The number of terms in the rational function to be solved by - DLASD4. K >= 1. + ICOMPQ (input) INTEGER + Specifies whether singular vectors are to be computed in + factored form in the calling routine: + = 0: Compute singular values only. + = 1: Compute singular vectors in factored form as well. - D (output) DOUBLE PRECISION array, dimension ( K ) - On output, D contains the updated singular values. + K (input) INTEGER + The number of terms in the rational function to be solved + by DLASD4. K >= 1. - Z (input) DOUBLE PRECISION array, dimension ( K ) - The first K elements of this array contain the components of - the deflation-adjusted updating row vector. + D (output) DOUBLE PRECISION array, dimension ( K ) + On output, D contains the updated singular values. - VF (input/output) DOUBLE PRECISION array, dimension ( K ) - On entry, VF contains information passed through DBEDE8. On - exit, VF contains the first K components of the first compo- - nents of all right singular vectors of the bidiagonal matrix. + Z (input) DOUBLE PRECISION array, dimension ( K ) + The first K elements of this array contain the components + of the deflation-adjusted updating row vector. - VL (input/output) DOUBLE PRECISION array, dimension ( K ) - On entry, VL contains information passed through DBEDE8. On - exit, VL contains the first K components of the last components - of all right singular vectors of the bidiagonal matrix. + VF (input/output) DOUBLE PRECISION array, dimension ( K ) + On entry, VF contains information passed through DBEDE8. + On exit, VF contains the first K components of the first + components of all right singular vectors of the bidiagonal + matrix. - DIFL (output) DOUBLE PRECISION array, dimension ( K ) - On exit, DIFL(I) = D(I) - DSIGMA(I). + VL (input/output) DOUBLE PRECISION array, dimension ( K ) + On entry, VL contains information passed through DBEDE8. + On exit, VL contains the first K components of the last + components of all right singular vectors of the bidiagonal + matrix. - DIFR (output) DOUBLE PRECISION array, - dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and dimension ( K ) if - ICOMPQ = 0. On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) - is not defined and will not be referenced. + DIFL (output) DOUBLE PRECISION array, dimension ( K ) + On exit, DIFL(I) = D(I) - DSIGMA(I). - If ICOMPQ = 1, DIFR(1:K,2) is an array containing the normaliz- - ing factors for the right singular vector matrix. + DIFR (output) DOUBLE PRECISION array, + dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and + dimension ( K ) if ICOMPQ = 0. + On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not + defined and will not be referenced. - LDDIFR (input) INTEGER - The leading dimension of DIFR, must be at least K. + If ICOMPQ = 1, DIFR(1:K,2) is an array containing the + normalizing factors for the right singular vector matrix. - DSIGMA (input) DOUBLE PRECISION array, dimension ( K ) - The first K elements of this array contain the old roots of the - deflated updating problem. These are the poles of the secular - equation. + LDDIFR (input) INTEGER + The leading dimension of DIFR, must be at least K. - WORK (workspace) DOUBLE PRECISION array, dimension at least 3 * K + DSIGMA (input) DOUBLE PRECISION array, dimension ( K ) + The first K elements of this array contain the old roots + of the deflated updating problem. These are the poles + of the secular equation. - INFO (output) INTEGER - = 0: successful exit. - < 0: if INFO = -i, the i-th argument had an illegal value. - > 0: if INFO = 1, an singular value did not converge + WORK (workspace) DOUBLE PRECISION array, dimension at least 3 * K + + INFO (output) INTEGER + = 0: successful exit. + < 0: if INFO = -i, the i-th argument had an illegal value. + > 0: if INFO = 1, an singular value did not converge + + Further Details + =============== + + Based on contributions by + Ming Gu and Huan Ren, Computer Science Division, University of + California at Berkeley, USA \end{chunk} +\begin{verbatim} + SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, + $ DSIGMA, WORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, +* Courant Institute, NAG Ltd., and Rice University +* June 30, 1999 +* +* .. Scalar Arguments .. + INTEGER ICOMPQ, INFO, K, LDDIFR +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), DIFL( * ), DIFR( LDDIFR, * ), + $ DSIGMA( * ), VF( * ), VL( * ), WORK( * ), + $ Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IWK1, IWK2, IWK2I, IWK3, IWK3I, J + DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, RHO, TEMP +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLASCL, DLASD4, DLASET, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DDOT, DLAMC3, DNRM2 + EXTERNAL DDOT, DLAMC3, DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SIGN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( K.LT.1 ) THEN + INFO = -2 + ELSE IF( LDDIFR.LT.K ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD8', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( K.EQ.1 ) THEN + D( 1 ) = ABS( Z( 1 ) ) + DIFL( 1 ) = D( 1 ) + IF( ICOMPQ.EQ.1 ) THEN + DIFL( 2 ) = ONE + DIFR( 1, 2 ) = ONE + END IF + RETURN + END IF +* +* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can +* be computed with high relative accuracy (barring over/underflow). +* This is a problem on machines without a guard digit in +* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). +* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), +* which on any of these machines zeros out the bottommost +* bit of DSIGMA(I) if it is 1; this makes the subsequent +* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation +* occurs. On binary machines with a guard digit (almost all +* machines) it does not change DSIGMA(I) at all. On hexadecimal +* and decimal machines with a guard digit, it slightly +* changes the bottommost bits of DSIGMA(I). It does not account +* for hexadecimal or decimal machines without guard digits +* (we know of none). We use a subroutine call to compute +* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating +* this code. +* + DO 10 I = 1, K + DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I ) + 10 CONTINUE +* +* Book keeping. +* + IWK1 = 1 + IWK2 = IWK1 + K + IWK3 = IWK2 + K + IWK2I = IWK2 - 1 + IWK3I = IWK3 - 1 +* +* Normalize Z. +* + RHO = DNRM2( K, Z, 1 ) + CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO ) + RHO = RHO*RHO +* +* Initialize WORK(IWK3). +* + CALL DLASET( 'A', K, 1, ONE, ONE, WORK( IWK3 ), K ) +* +* Compute the updated singular values, the arrays DIFL, DIFR, +* and the updated Z. +* + DO 40 J = 1, K + CALL DLASD4( K, J, DSIGMA, Z, WORK( IWK1 ), RHO, D( J ), + $ WORK( IWK2 ), INFO ) +* +* If the root finder fails, the computation is terminated. +* + IF( INFO.NE.0 ) THEN + RETURN + END IF + WORK( IWK3I+J ) = WORK( IWK3I+J )*WORK( J )*WORK( IWK2I+J ) + DIFL( J ) = -WORK( J ) + DIFR( J, 1 ) = -WORK( J+1 ) + DO 20 I = 1, J - 1 + WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )* + $ WORK( IWK2I+I ) / ( DSIGMA( I )- + $ DSIGMA( J ) ) / ( DSIGMA( I )+ + $ DSIGMA( J ) ) + 20 CONTINUE + DO 30 I = J + 1, K + WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )* + $ WORK( IWK2I+I ) / ( DSIGMA( I )- + $ DSIGMA( J ) ) / ( DSIGMA( I )+ + $ DSIGMA( J ) ) + 30 CONTINUE + 40 CONTINUE +* +* Compute updated Z. +* + DO 50 I = 1, K + Z( I ) = SIGN( SQRT( ABS( WORK( IWK3I+I ) ) ), Z( I ) ) + 50 CONTINUE +* +* Update VF and VL. +* + DO 80 J = 1, K + DIFLJ = DIFL( J ) + DJ = D( J ) + DSIGJ = -DSIGMA( J ) + IF( J.LT.K ) THEN + DIFRJ = -DIFR( J, 1 ) + DSIGJP = -DSIGMA( J+1 ) + END IF + WORK( J ) = -Z( J ) / DIFLJ / ( DSIGMA( J )+DJ ) + DO 60 I = 1, J - 1 + WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJ )-DIFLJ ) + $ / ( DSIGMA( I )+DJ ) + 60 CONTINUE + DO 70 I = J + 1, K + WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJP )+DIFRJ ) + $ / ( DSIGMA( I )+DJ ) + 70 CONTINUE + TEMP = DNRM2( K, WORK, 1 ) + WORK( IWK2I+J ) = DDOT( K, WORK, 1, VF, 1 ) / TEMP + WORK( IWK3I+J ) = DDOT( K, WORK, 1, VL, 1 ) / TEMP + IF( ICOMPQ.EQ.1 ) THEN + DIFR( J, 2 ) = TEMP + END IF + 80 CONTINUE +* + CALL DCOPY( K, WORK( IWK2 ), 1, VF, 1 ) + CALL DCOPY( K, WORK( IWK3 ), 1, VL, 1 ) +* + RETURN +* +* End of DLASD8 +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlasd8} (let* ((one 1.0)) (declare (type (double-float 1.0 1.0) one)) @@ -61847,134 +86390,402 @@ SYNOPSIS * ), E( * ), GIVNUM( LDU, * ), POLES( LDU, * ), S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ), Z( LDU, * ) -PURPOSE - Using a divide and conquer approach, DLASDA computes the singular value - decomposition (SVD) of a real upper bidiagonal N-by-M matrix B with - diagonal D and offdiagonal E, where M = N + SQRE. The algorithm com- - putes the singular values in the SVD B = U * S * VT. The orthogonal - matrices U and VT are optionally computed in compact form. - - A related subroutine, DLASD0, computes the singular values and the sin- - gular vectors in explicit form. - + Purpose + ======= + + Using a divide and conquer approach, DLASDA computes the singular + value decomposition (SVD) of a real upper bidiagonal N-by-M matrix + B with diagonal D and offdiagonal E, where M = N + SQRE. The + algorithm computes the singular values in the SVD B = U * S * VT. + The orthogonal matrices U and VT are optionally computed in + compact form. + + A related subroutine, DLASD0, computes the singular values and + the singular vectors in explicit form. + + Arguments + ========= + + ICOMPQ (input) INTEGER + Specifies whether singular vectors are to be computed + in compact form, as follows + = 0: Compute singular values only. + = 1: Compute singular vectors of upper bidiagonal + matrix in compact form. + + SMLSIZ (input) INTEGER + The maximum size of the subproblems at the bottom of the + computation tree. + + N (input) INTEGER + The row dimension of the upper bidiagonal matrix. This is + also the dimension of the main diagonal array D. + + SQRE (input) INTEGER + Specifies the column dimension of the bidiagonal matrix. + = 0: The bidiagonal matrix has column dimension M = N; + = 1: The bidiagonal matrix has column dimension M = N + 1. + + D (input/output) DOUBLE PRECISION array, dimension ( N ) + On entry D contains the main diagonal of the bidiagonal + matrix. On exit D, if INFO = 0, contains its singular values. + + E (input) DOUBLE PRECISION array, dimension ( M-1 ) + Contains the subdiagonal entries of the bidiagonal matrix. + On exit, E has been destroyed. + + U (output) DOUBLE PRECISION array, + dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced + if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left + singular vector matrices of all subproblems at the bottom + level. + + LDU (input) INTEGER, LDU = > N. + The leading dimension of arrays U, VT, DIFL, DIFR, POLES, + GIVNUM, and Z. + + VT (output) DOUBLE PRECISION array, + dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced + if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right + singular vector matrices of all subproblems at the bottom + level. + + K (output) INTEGER array, + dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0. + If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th + secular equation on the computation tree. + + DIFL (output) DOUBLE PRECISION array, dimension ( LDU, NLVL ), + where NLVL = floor(log_2 (N/SMLSIZ))). + + DIFR (output) DOUBLE PRECISION array, + dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and + dimension ( N ) if ICOMPQ = 0. + If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1) + record distances between singular values on the I-th + level and singular values on the (I -1)-th level, and + DIFR(1:N, 2 * I ) contains the normalizing factors for + the right singular vector matrix. See DLASD8 for details. + + Z (output) DOUBLE PRECISION array, + dimension ( LDU, NLVL ) if ICOMPQ = 1 and + dimension ( N ) if ICOMPQ = 0. + The first K elements of Z(1, I) contain the components of + the deflation-adjusted updating row vector for subproblems + on the I-th level. + + POLES (output) DOUBLE PRECISION array, + dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced + if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and + POLES(1, 2*I) contain the new and old singular values + involved in the secular equations on the I-th level. + + GIVPTR (output) INTEGER array, + dimension ( N ) if ICOMPQ = 1, and not referenced if + ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records + the number of Givens rotations performed on the I-th + problem on the computation tree. + + GIVCOL (output) INTEGER array, + dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not + referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, + GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations + of Givens rotations performed on the I-th level on the + computation tree. + + LDGCOL (input) INTEGER, LDGCOL = > N. + The leading dimension of arrays GIVCOL and PERM. + + PERM (output) INTEGER array, + dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced + if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records + permutations done on the I-th level of the computation tree. + + GIVNUM (output) DOUBLE PRECISION array, + dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not + referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, + GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S- + values of Givens rotations performed on the I-th level on + the computation tree. + + C (output) DOUBLE PRECISION array, + dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. + If ICOMPQ = 1 and the I-th subproblem is not square, on exit, + C( I ) contains the C-value of a Givens rotation related to + the right null space of the I-th subproblem. + + S (output) DOUBLE PRECISION array, dimension ( N ) if + ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1 + and the I-th subproblem is not square, on exit, S( I ) + contains the S-value of a Givens rotation related to + the right null space of the I-th subproblem. + + WORK (workspace) DOUBLE PRECISION array, dimension + (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)). + + IWORK (workspace) INTEGER array. + Dimension must be at least (7 * N). + + INFO (output) INTEGER + = 0: successful exit. + < 0: if INFO = -i, the i-th argument had an illegal value. + > 0: if INFO = 1, an singular value did not converge + + Further Details + =============== + + Based on contributions by + Ming Gu and Huan Ren, Computer Science Division, University of + California at Berkeley, USA -ARGUMENTS - ICOMPQ (input) INTEGER Specifies whether singular vectors are to be - computed in compact form, as follows = 0: Compute singular values only. - = 1: Compute singular vectors of upper bidiagonal matrix in compact - form. - - SMLSIZ (input) INTEGER The maximum size of the subproblems at the bot- - tom of the computation tree. +\end{chunk} - N (input) INTEGER - The row dimension of the upper bidiagonal matrix. This is also - the dimension of the main diagonal array D. - - SQRE (input) INTEGER - Specifies the column dimension of the bidiagonal matrix. = 0: - The bidiagonal matrix has column dimension M = N; - = 1: The bidiagonal matrix has column dimension M = N + 1. - - D (input/output) DOUBLE PRECISION array, dimension ( N ) - On entry D contains the main diagonal of the bidiagonal matrix. - On exit D, if INFO = 0, contains its singular values. - - E (input) DOUBLE PRECISION array, dimension ( M-1 ) - Contains the subdiagonal entries of the bidiagonal matrix. On - exit, E has been destroyed. - - U (output) DOUBLE PRECISION array, - dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced if - ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left singular - vector matrices of all subproblems at the bottom level. - - LDU (input) INTEGER, LDU = > N. - The leading dimension of arrays U, VT, DIFL, DIFR, POLES, - GIVNUM, and Z. - - VT (output) DOUBLE PRECISION array, - dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced if - ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right sin- - gular vector matrices of all subproblems at the bottom level. - - K (output) INTEGER array, - dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0. If - ICOMPQ = 1, on exit, K(I) is the dimension of the I-th secular - equation on the computation tree. - - DIFL (output) DOUBLE PRECISION array, dimension ( LDU, NLVL ), - where NLVL = floor(log_2 (N/SMLSIZ))). - - DIFR (output) DOUBLE PRECISION array, - dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and dimension ( N ) if - ICOMPQ = 0. If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, - 2 * I - 1) record distances between singular values on the I-th - level and singular values on the (I -1)-th level, and DIFR(1:N, - 2 * I ) contains the normalizing factors for the right singular - vector matrix. See DLASD8 for details. - - Z (output) DOUBLE PRECISION array, - dimension ( LDU, NLVL ) if ICOMPQ = 1 and dimension ( N ) if - ICOMPQ = 0. The first K elements of Z(1, I) contain the compo- - nents of the deflation-adjusted updating row vector for subprob- - lems on the I-th level. - - POLES (output) DOUBLE PRECISION array, - dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced if - ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and - POLES(1, 2*I) contain the new and old singular values involved - in the secular equations on the I-th level. - - GIVPTR (output) INTEGER array, dimension ( N ) if ICOMPQ = 1, - and not referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, - GIVPTR( I ) records the number of Givens rotations performed on - the I-th problem on the computation tree. - - GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 * NLVL ) if - ICOMPQ = 1, and not referenced if ICOMPQ = 0. If ICOMPQ = 1, on - exit, for each I, GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record - the locations of Givens rotations performed on the I-th level on - the computation tree. - - LDGCOL (input) INTEGER, LDGCOL = > N. The leading dimension of - arrays GIVCOL and PERM. - - PERM (output) INTEGER array, - dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced if - ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records permuta- - tions done on the I-th level of the computation tree. - - GIVNUM (output) DOUBLE PRECISION array, dimension ( LDU, 2 * - NLVL ) if ICOMPQ = 1, and not referenced if ICOMPQ = 0. If - ICOMPQ = 1, on exit, for each I, GIVNUM(1, 2 *I - 1) and - GIVNUM(1, 2 *I) record the C- and S- values of Givens rotations - performed on the I-th level on the computation tree. - - C (output) DOUBLE PRECISION array, - dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. - If ICOMPQ = 1 and the I-th subproblem is not square, on exit, C( - I ) contains the C-value of a Givens rotation related to the - right null space of the I-th subproblem. - - S (output) DOUBLE PRECISION array, dimension ( N ) if - ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1 and the - I-th subproblem is not square, on exit, S( I ) contains the S- - value of a Givens rotation related to the right null space of - the I-th subproblem. - - WORK (workspace) DOUBLE PRECISION array, dimension - (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)). - - IWORK (workspace) INTEGER array. - Dimension must be at least (7 * N). - - INFO (output) INTEGER - = 0: successful exit. - < 0: if INFO = -i, the i-th argument had an illegal value. - > 0: if INFO = 1, an singular value did not converge +\begin{verbatim} + SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, + $ DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, + $ PERM, GIVNUM, C, S, WORK, IWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1999 +* +* .. Scalar Arguments .. + INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE +* .. +* .. Array Arguments .. + INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), + $ K( * ), PERM( LDGCOL, * ) + DOUBLE PRECISION C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ), + $ E( * ), GIVNUM( LDU, * ), POLES( LDU, * ), + $ S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ), + $ Z( LDU, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, I1, IC, IDXQ, IDXQI, IM1, INODE, ITEMP, IWK, + $ J, LF, LL, LVL, LVL2, M, NCC, ND, NDB1, NDIML, + $ NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, NRU, + $ NWORK1, NWORK2, SMLSZP, SQREI, VF, VFI, VL, VLI + DOUBLE PRECISION ALPHA, BETA +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLASD6, DLASDQ, DLASDT, DLASET, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( SMLSIZ.LT.3 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -4 + ELSE IF( LDU.LT.( N+SQRE ) ) THEN + INFO = -8 + ELSE IF( LDGCOL.LT.N ) THEN + INFO = -17 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASDA', -INFO ) + RETURN + END IF +* + M = N + SQRE +* +* If the input matrix is too small, call DLASDQ to find the SVD. +* + IF( N.LE.SMLSIZ ) THEN + IF( ICOMPQ.EQ.0 ) THEN + CALL DLASDQ( 'U', SQRE, N, 0, 0, 0, D, E, VT, LDU, U, LDU, + $ U, LDU, WORK, INFO ) + ELSE + CALL DLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDU, U, LDU, + $ U, LDU, WORK, INFO ) + END IF + RETURN + END IF +* +* Book-keeping and set up the computation tree. +* + INODE = 1 + NDIML = INODE + N + NDIMR = NDIML + N + IDXQ = NDIMR + N + IWK = IDXQ + N +* + NCC = 0 + NRU = 0 +* + SMLSZP = SMLSIZ + 1 + VF = 1 + VL = VF + M + NWORK1 = VL + M + NWORK2 = NWORK1 + SMLSZP*SMLSZP +* + CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ), + $ IWORK( NDIMR ), SMLSIZ ) +* +* for the nodes on bottom level of the tree, solve +* their subproblems by DLASDQ. +* + NDB1 = ( ND+1 ) / 2 + DO 30 I = NDB1, ND +* +* IC : center row of each node +* NL : number of rows of left subproblem +* NR : number of rows of right subproblem +* NLF: starting row of the left subproblem +* NRF: starting row of the right subproblem +* + I1 = I - 1 + IC = IWORK( INODE+I1 ) + NL = IWORK( NDIML+I1 ) + NLP1 = NL + 1 + NR = IWORK( NDIMR+I1 ) + NLF = IC - NL + NRF = IC + 1 + IDXQI = IDXQ + NLF - 2 + VFI = VF + NLF - 1 + VLI = VL + NLF - 1 + SQREI = 1 + IF( ICOMPQ.EQ.0 ) THEN + CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, WORK( NWORK1 ), + $ SMLSZP ) + CALL DLASDQ( 'U', SQREI, NL, NLP1, NRU, NCC, D( NLF ), + $ E( NLF ), WORK( NWORK1 ), SMLSZP, + $ WORK( NWORK2 ), NL, WORK( NWORK2 ), NL, + $ WORK( NWORK2 ), INFO ) + ITEMP = NWORK1 + NL*SMLSZP + CALL DCOPY( NLP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 ) + CALL DCOPY( NLP1, WORK( ITEMP ), 1, WORK( VLI ), 1 ) + ELSE + CALL DLASET( 'A', NL, NL, ZERO, ONE, U( NLF, 1 ), LDU ) + CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, VT( NLF, 1 ), LDU ) + CALL DLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ), + $ E( NLF ), VT( NLF, 1 ), LDU, U( NLF, 1 ), LDU, + $ U( NLF, 1 ), LDU, WORK( NWORK1 ), INFO ) + CALL DCOPY( NLP1, VT( NLF, 1 ), 1, WORK( VFI ), 1 ) + CALL DCOPY( NLP1, VT( NLF, NLP1 ), 1, WORK( VLI ), 1 ) + END IF + IF( INFO.NE.0 ) THEN + RETURN + END IF + DO 10 J = 1, NL + IWORK( IDXQI+J ) = J + 10 CONTINUE + IF( ( I.EQ.ND ) .AND. ( SQRE.EQ.0 ) ) THEN + SQREI = 0 + ELSE + SQREI = 1 + END IF + IDXQI = IDXQI + NLP1 + VFI = VFI + NLP1 + VLI = VLI + NLP1 + NRP1 = NR + SQREI + IF( ICOMPQ.EQ.0 ) THEN + CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, WORK( NWORK1 ), + $ SMLSZP ) + CALL DLASDQ( 'U', SQREI, NR, NRP1, NRU, NCC, D( NRF ), + $ E( NRF ), WORK( NWORK1 ), SMLSZP, + $ WORK( NWORK2 ), NR, WORK( NWORK2 ), NR, + $ WORK( NWORK2 ), INFO ) + ITEMP = NWORK1 + ( NRP1-1 )*SMLSZP + CALL DCOPY( NRP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 ) + CALL DCOPY( NRP1, WORK( ITEMP ), 1, WORK( VLI ), 1 ) + ELSE + CALL DLASET( 'A', NR, NR, ZERO, ONE, U( NRF, 1 ), LDU ) + CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, VT( NRF, 1 ), LDU ) + CALL DLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ), + $ E( NRF ), VT( NRF, 1 ), LDU, U( NRF, 1 ), LDU, + $ U( NRF, 1 ), LDU, WORK( NWORK1 ), INFO ) + CALL DCOPY( NRP1, VT( NRF, 1 ), 1, WORK( VFI ), 1 ) + CALL DCOPY( NRP1, VT( NRF, NRP1 ), 1, WORK( VLI ), 1 ) + END IF + IF( INFO.NE.0 ) THEN + RETURN + END IF + DO 20 J = 1, NR + IWORK( IDXQI+J ) = J + 20 CONTINUE + 30 CONTINUE +* +* Now conquer each subproblem bottom-up. +* + J = 2**NLVL + DO 50 LVL = NLVL, 1, -1 + LVL2 = LVL*2 - 1 +* +* Find the first node LF and last node LL on +* the current level LVL. +* + IF( LVL.EQ.1 ) THEN + LF = 1 + LL = 1 + ELSE + LF = 2**( LVL-1 ) + LL = 2*LF - 1 + END IF + DO 40 I = LF, LL + IM1 = I - 1 + IC = IWORK( INODE+IM1 ) + NL = IWORK( NDIML+IM1 ) + NR = IWORK( NDIMR+IM1 ) + NLF = IC - NL + NRF = IC + 1 + IF( I.EQ.LL ) THEN + SQREI = SQRE + ELSE + SQREI = 1 + END IF + VFI = VF + NLF - 1 + VLI = VL + NLF - 1 + IDXQI = IDXQ + NLF - 1 + ALPHA = D( IC ) + BETA = E( IC ) + IF( ICOMPQ.EQ.0 ) THEN + CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ), + $ WORK( VFI ), WORK( VLI ), ALPHA, BETA, + $ IWORK( IDXQI ), PERM, GIVPTR( 1 ), GIVCOL, + $ LDGCOL, GIVNUM, LDU, POLES, DIFL, DIFR, Z, + $ K( 1 ), C( 1 ), S( 1 ), WORK( NWORK1 ), + $ IWORK( IWK ), INFO ) + ELSE + J = J - 1 + CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ), + $ WORK( VFI ), WORK( VLI ), ALPHA, BETA, + $ IWORK( IDXQI ), PERM( NLF, LVL ), + $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL, + $ GIVNUM( NLF, LVL2 ), LDU, + $ POLES( NLF, LVL2 ), DIFL( NLF, LVL ), + $ DIFR( NLF, LVL2 ), Z( NLF, LVL ), K( J ), + $ C( J ), S( J ), WORK( NWORK1 ), + $ IWORK( IWK ), INFO ) + END IF + IF( INFO.NE.0 ) THEN + RETURN + END IF + 40 CONTINUE + 50 CONTINUE +* + RETURN +* +* End of DLASDA +* + END -\end{chunk} +\end{verbatim} \begin{chunk}{LAPACK dlasda} (let* ((zero 0.0) (one 1.0)) @@ -62538,108 +87349,328 @@ SYNOPSIS DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), VT( LDVT, * ), WORK( * ) -PURPOSE - DLASDQ computes the singular value decomposition (SVD) of a real (upper - or lower) bidiagonal matrix with diagonal D and offdiagonal E, accumu- - lating the transformations if desired. Letting B denote the input bidi- - agonal matrix, the algorithm computes orthogonal matrices Q and P such - that B = Q * S * P' (P' denotes the transpose of P). The singular val- - ues S are overwritten on D. - - The input matrix U is changed to U * Q if desired. - The input matrix VT is changed to P' * VT if desired. - The input matrix C is changed to Q' * C if desired. - - See "Computing Small Singular Values of Bidiagonal Matrices With Guar- - anteed High Relative Accuracy," by J. Demmel and W. Kahan, LAPACK Work- - ing Note #3, for a detailed description of the algorithm. - - -ARGUMENTS - UPLO (input) CHARACTER*1 - On entry, UPLO specifies whether the input bidiagonal matrix is - upper or lower bidiagonal, and wether it is square are not. UPLO - = 'U' or 'u' B is upper bidiagonal. UPLO = 'L' or 'l' B is - lower bidiagonal. - - SQRE (input) INTEGER - = 0: then the input matrix is N-by-N. - = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and + Purpose + ======= + + DLASDQ computes the singular value decomposition (SVD) of a real + (upper or lower) bidiagonal matrix with diagonal D and offdiagonal + E, accumulating the transformations if desired. Letting B denote + the input bidiagonal matrix, the algorithm computes orthogonal + matrices Q and P such that B = Q * S * P' (P' denotes the transpose + of P). The singular values S are overwritten on D. + + The input matrix U is changed to U * Q if desired. + The input matrix VT is changed to P' * VT if desired. + The input matrix C is changed to Q' * C if desired. + + See "Computing Small Singular Values of Bidiagonal Matrices With + Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, + LAPACK Working Note #3, for a detailed description of the algorithm. + + Arguments + ========= + + UPLO (input) CHARACTER*1 + On entry, UPLO specifies whether the input bidiagonal matrix + is upper or lower bidiagonal, and wether it is square are + not. + UPLO = 'U' or 'u' B is upper bidiagonal. + UPLO = 'L' or 'l' B is lower bidiagonal. + + SQRE (input) INTEGER + = 0: then the input matrix is N-by-N. + = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and (N+1)-by-N if UPLU = 'L'. - The bidiagonal matrix has N = NL + NR + 1 rows and M = N + SQRE - >= N columns. - - N (input) INTEGER - On entry, N specifies the number of rows and columns in the - matrix. N must be at least 0. + The bidiagonal matrix has + N = NL + NR + 1 rows and + M = N + SQRE >= N columns. + + N (input) INTEGER + On entry, N specifies the number of rows and columns + in the matrix. N must be at least 0. + + NCVT (input) INTEGER + On entry, NCVT specifies the number of columns of + the matrix VT. NCVT must be at least 0. + + NRU (input) INTEGER + On entry, NRU specifies the number of rows of + the matrix U. NRU must be at least 0. + + NCC (input) INTEGER + On entry, NCC specifies the number of columns of + the matrix C. NCC must be at least 0. + + D (input/output) DOUBLE PRECISION array, dimension (N) + On entry, D contains the diagonal entries of the + bidiagonal matrix whose SVD is desired. On normal exit, + D contains the singular values in ascending order. + + E (input/output) DOUBLE PRECISION array. + dimension is (N-1) if SQRE = 0 and N if SQRE = 1. + On entry, the entries of E contain the offdiagonal entries + of the bidiagonal matrix whose SVD is desired. On normal + exit, E will contain 0. If the algorithm does not converge, + D and E will contain the diagonal and superdiagonal entries + of a bidiagonal matrix orthogonally equivalent to the one + given as input. + + VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) + On entry, contains a matrix which on exit has been + premultiplied by P', dimension N-by-NCVT if SQRE = 0 + and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0). + + LDVT (input) INTEGER + On entry, LDVT specifies the leading dimension of VT as + declared in the calling (sub) program. LDVT must be at + least 1. If NCVT is nonzero LDVT must also be at least N. + + U (input/output) DOUBLE PRECISION array, dimension (LDU, N) + On entry, contains a matrix which on exit has been + postmultiplied by Q, dimension NRU-by-N if SQRE = 0 + and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0). + + LDU (input) INTEGER + On entry, LDU specifies the leading dimension of U as + declared in the calling (sub) program. LDU must be at + least max( 1, NRU ) . + + C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) + On entry, contains an N-by-NCC matrix which on exit + has been premultiplied by Q' dimension N-by-NCC if SQRE = 0 + and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0). + + LDC (input) INTEGER + On entry, LDC specifies the leading dimension of C as + declared in the calling (sub) program. LDC must be at + least 1. If NCC is nonzero, LDC must also be at least N. + + WORK (workspace) DOUBLE PRECISION array, dimension (4*N) + Workspace. Only referenced if one of NCVT, NRU, or NCC is + nonzero, and if N is at least 2. + + INFO (output) INTEGER + On exit, a value of 0 indicates a successful exit. + If INFO < 0, argument number -INFO is illegal. + If INFO > 0, the algorithm did not converge, and INFO + specifies how many superdiagonals did not converge. + + Further Details + =============== + + Based on contributions by + Ming Gu and Huan Ren, Computer Science Division, University of + California at Berkeley, USA - NCVT (input) INTEGER - On entry, NCVT specifies the number of columns of the matrix VT. - NCVT must be at least 0. - - NRU (input) INTEGER - On entry, NRU specifies the number of rows of the matrix U. NRU - must be at least 0. - - NCC (input) INTEGER - On entry, NCC specifies the number of columns of the matrix C. - NCC must be at least 0. - - D (input/output) DOUBLE PRECISION array, dimension (N) - On entry, D contains the diagonal entries of the bidiagonal - matrix whose SVD is desired. On normal exit, D contains the sin- - gular values in ascending order. - - E (input/output) DOUBLE PRECISION array. - dimension is (N-1) if SQRE = 0 and N if SQRE = 1. On entry, the - entries of E contain the offdiagonal entries of the bidiagonal - matrix whose SVD is desired. On normal exit, E will contain 0. If - the algorithm does not converge, D and E will contain the diago- - nal and superdiagonal entries of a bidiagonal matrix orthogonally - equivalent to the one given as input. - - VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) - On entry, contains a matrix which on exit has been premultiplied - by P', dimension N-by-NCVT if SQRE = 0 and (N+1)-by-NCVT if SQRE - = 1 (not referenced if NCVT=0). - - LDVT (input) INTEGER - On entry, LDVT specifies the leading dimension of VT as declared - in the calling (sub) program. LDVT must be at least 1. If NCVT is - nonzero LDVT must also be at least N. - - U (input/output) DOUBLE PRECISION array, dimension (LDU, N) - On entry, contains a matrix which on exit has been postmulti- - plied by Q, dimension NRU-by-N if SQRE = 0 and NRU-by-(N+1) if - SQRE = 1 (not referenced if NRU=0). - - LDU (input) INTEGER - On entry, LDU specifies the leading dimension of U as declared - in the calling (sub) program. LDU must be at least max( 1, NRU ) - . - - C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) - On entry, contains an N-by-NCC matrix which on exit has been pre- - multiplied by Q' dimension N-by-NCC if SQRE = 0 and (N+1)-by-NCC - if SQRE = 1 (not referenced if NCC=0). - - LDC (input) INTEGER - On entry, LDC specifies the leading dimension of C as declared - in the calling (sub) program. LDC must be at least 1. If NCC is - nonzero, LDC must also be at least N. - - WORK (workspace) DOUBLE PRECISION array, dimension (4*N) - Workspace. Only referenced if one of NCVT, NRU, or NCC is - nonzero, and if N is at least 2. +\end{chunk} - INFO (output) INTEGER - On exit, a value of 0 indicates a successful exit. If INFO < 0, - argument number -INFO is illegal. If INFO > 0, the algorithm did - not converge, and INFO specifies how many superdiagonals did not - converge. +\begin{verbatim} + SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, + $ U, LDU, C, LDC, WORK, INFO ) +* +* -- 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, 1999 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), + $ VT( LDVT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ROTATE + INTEGER I, ISUB, IUPLO, J, NP1, SQRE1 + DOUBLE PRECISION CS, R, SMIN, SN +* .. +* .. External Subroutines .. + EXTERNAL DBDSQR, DLARTG, DLASR, DSWAP, XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IUPLO = 0 + IF( LSAME( UPLO, 'U' ) ) + $ IUPLO = 1 + IF( LSAME( UPLO, 'L' ) ) + $ IUPLO = 2 + IF( IUPLO.EQ.0 ) THEN + INFO = -1 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NCVT.LT.0 ) THEN + INFO = -4 + ELSE IF( NRU.LT.0 ) THEN + INFO = -5 + ELSE IF( NCC.LT.0 ) THEN + INFO = -6 + ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR. + $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN + INFO = -10 + ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN + INFO = -12 + ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR. + $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN + INFO = -14 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASDQ', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) + $ RETURN +* +* ROTATE is true if any singular vectors desired, false otherwise +* + ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 ) + NP1 = N + 1 + SQRE1 = SQRE +* +* If matrix non-square upper bidiagonal, rotate to be lower +* bidiagonal. The rotations are on the right. +* + IF( ( IUPLO.EQ.1 ) .AND. ( SQRE1.EQ.1 ) ) THEN + DO 10 I = 1, N - 1 + CALL DLARTG( D( I ), E( I ), CS, SN, R ) + D( I ) = R + E( I ) = SN*D( I+1 ) + D( I+1 ) = CS*D( I+1 ) + IF( ROTATE ) THEN + WORK( I ) = CS + WORK( N+I ) = SN + END IF + 10 CONTINUE + CALL DLARTG( D( N ), E( N ), CS, SN, R ) + D( N ) = R + E( N ) = ZERO + IF( ROTATE ) THEN + WORK( N ) = CS + WORK( N+N ) = SN + END IF + IUPLO = 2 + SQRE1 = 0 +* +* Update singular vectors if desired. +* + IF( NCVT.GT.0 ) + $ CALL DLASR( 'L', 'V', 'F', NP1, NCVT, WORK( 1 ), + $ WORK( NP1 ), VT, LDVT ) + END IF +* +* If matrix lower bidiagonal, rotate to be upper bidiagonal +* by applying Givens rotations on the left. +* + IF( IUPLO.EQ.2 ) THEN + DO 20 I = 1, N - 1 + CALL DLARTG( D( I ), E( I ), CS, SN, R ) + D( I ) = R + E( I ) = SN*D( I+1 ) + D( I+1 ) = CS*D( I+1 ) + IF( ROTATE ) THEN + WORK( I ) = CS + WORK( N+I ) = SN + END IF + 20 CONTINUE +* +* If matrix (N+1)-by-N lower bidiagonal, one additional +* rotation is needed. +* + IF( SQRE1.EQ.1 ) THEN + CALL DLARTG( D( N ), E( N ), CS, SN, R ) + D( N ) = R + IF( ROTATE ) THEN + WORK( N ) = CS + WORK( N+N ) = SN + END IF + END IF +* +* Update singular vectors if desired. +* + IF( NRU.GT.0 ) THEN + IF( SQRE1.EQ.0 ) THEN + CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), + $ WORK( NP1 ), U, LDU ) + ELSE + CALL DLASR( 'R', 'V', 'F', NRU, NP1, WORK( 1 ), + $ WORK( NP1 ), U, LDU ) + END IF + END IF + IF( NCC.GT.0 ) THEN + IF( SQRE1.EQ.0 ) THEN + CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), + $ WORK( NP1 ), C, LDC ) + ELSE + CALL DLASR( 'L', 'V', 'F', NP1, NCC, WORK( 1 ), + $ WORK( NP1 ), C, LDC ) + END IF + END IF + END IF +* +* Call DBDSQR to compute the SVD of the reduced real +* N-by-N upper bidiagonal matrix. +* + CALL DBDSQR( 'U', N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, + $ LDC, WORK, INFO ) +* +* Sort the singular values into ascending order (insertion sort on +* singular values, but only one transposition per singular vector) +* + DO 40 I = 1, N +* +* Scan for smallest D(I). +* + ISUB = I + SMIN = D( I ) + DO 30 J = I + 1, N + IF( D( J ).LT.SMIN ) THEN + ISUB = J + SMIN = D( J ) + END IF + 30 CONTINUE + IF( ISUB.NE.I ) THEN +* +* Swap singular values and vectors. +* + D( ISUB ) = D( I ) + D( I ) = SMIN + IF( NCVT.GT.0 ) + $ CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( I, 1 ), LDVT ) + IF( NRU.GT.0 ) + $ CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, I ), 1 ) + IF( NCC.GT.0 ) + $ CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( I, 1 ), LDC ) + END IF + 40 CONTINUE +* + RETURN +* +* End of DLASDQ +* + END -\end{chunk} +\end{verbatim} \begin{chunk}{LAPACK dlasdq} (let* ((zero 0.0)) @@ -62952,36 +87983,118 @@ SYNOPSIS INTEGER INODE( * ), NDIML( * ), NDIMR( * ) -PURPOSE - DLASDT creates a tree of subproblems for bidiagonal divide and conquer. + Purpose + ======= + DLASDT creates a tree of subproblems for bidiagonal divide and + conquer. -ARGUMENTS - N (input) INTEGER - On entry, the number of diagonal elements of the bidiagonal - matrix. + Arguments + ========= + + N (input) INTEGER + On entry, the number of diagonal elements of the + bidiagonal matrix. + + LVL (output) INTEGER + On exit, the number of levels on the computation tree. - LVL (output) INTEGER - On exit, the number of levels on the computation tree. + ND (output) INTEGER + On exit, the number of nodes on the tree. - ND (output) INTEGER - On exit, the number of nodes on the tree. + INODE (output) INTEGER array, dimension ( N ) + On exit, centers of subproblems. - INODE (output) INTEGER array, dimension ( N ) - On exit, centers of subproblems. + NDIML (output) INTEGER array, dimension ( N ) + On exit, row dimensions of left children. - NDIML (output) INTEGER array, dimension ( N ) - On exit, row dimensions of left children. + NDIMR (output) INTEGER array, dimension ( N ) + On exit, row dimensions of right children. - NDIMR (output) INTEGER array, dimension ( N ) - On exit, row dimensions of right children. + MSUB (input) INTEGER. + On entry, the maximum row dimension each subproblem at the + bottom of the tree can be of. - MSUB (input) INTEGER. - On entry, the maximum row dimension each subproblem at the bot- - tom of the tree can be of. + Further Details + =============== + + Based on contributions by + Ming Gu and Huan Ren, Computer Science Division, University of + California at Berkeley, USA \end{chunk} +\begin{verbatim} + SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB ) +* +* -- 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 .. + INTEGER LVL, MSUB, N, ND +* .. +* .. Array Arguments .. + INTEGER INODE( * ), NDIML( * ), NDIMR( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IL, IR, LLST, MAXN, NCRNT, NLVL + DOUBLE PRECISION TEMP +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, INT, LOG, MAX +* .. +* .. Executable Statements .. +* +* Find the number of levels on the tree. +* + MAXN = MAX( 1, N ) + TEMP = LOG( DBLE( MAXN ) / DBLE( MSUB+1 ) ) / LOG( TWO ) + LVL = INT( TEMP ) + 1 +* + I = N / 2 + INODE( 1 ) = I + 1 + NDIML( 1 ) = I + NDIMR( 1 ) = N - I - 1 + IL = 0 + IR = 1 + LLST = 1 + DO 20 NLVL = 1, LVL - 1 +* +* Constructing the tree at (NLVL+1)-st level. The number of +* nodes created on this level is LLST * 2. +* + DO 10 I = 0, LLST - 1 + IL = IL + 2 + IR = IR + 2 + NCRNT = LLST + I + NDIML( IL ) = NDIML( NCRNT ) / 2 + NDIMR( IL ) = NDIML( NCRNT ) - NDIML( IL ) - 1 + INODE( IL ) = INODE( NCRNT ) - NDIMR( IL ) - 1 + NDIML( IR ) = NDIMR( NCRNT ) / 2 + NDIMR( IR ) = NDIMR( NCRNT ) - NDIML( IR ) - 1 + INODE( IR ) = INODE( NCRNT ) + NDIML( IR ) + 1 + 10 CONTINUE + LLST = LLST*2 + 20 CONTINUE + ND = LLST*2 - 1 +* + RETURN +* +* End of DLASDT +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlasdt} (let* ((two 2.0)) (declare (type (double-float 2.0 2.0) two)) @@ -63129,45 +88242,127 @@ SYNOPSIS DOUBLE PRECISION A( LDA, * ) -PURPOSE - DLASET initializes an m-by-n matrix A to BETA on the diagonal and ALPHA - on the offdiagonals. + Purpose + ======= + DLASET initializes an m-by-n matrix A to BETA on the diagonal and + ALPHA on the offdiagonals. -ARGUMENTS - UPLO (input) 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. + Arguments + ========= - M (input) INTEGER - The number of rows of the matrix A. M >= 0. + UPLO (input) 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. - N (input) INTEGER - The number of columns of the matrix A. N >= 0. + M (input) INTEGER + The number of rows of the matrix A. M >= 0. - ALPHA (input) DOUBLE PRECISION - The constant to which the offdiagonal elements are to be set. + N (input) INTEGER + The number of columns of the matrix A. N >= 0. - BETA (input) DOUBLE PRECISION - The constant to which the diagonal elements are to be set. + ALPHA (input) DOUBLE PRECISION + The constant to which the offdiagonal elements are to be set. - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On exit, the leading m-by-n submatrix of A is set as follows: + BETA (input) DOUBLE PRECISION + The constant to which the diagonal elements are to be set. - 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, + A (input/output) DOUBLE PRECISION array, dimension (LDA,N) + On exit, the leading m-by-n submatrix of A is set as follows: - and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). + 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, - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,M). + and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). + + LDA (input) INTEGER + The leading dimension of the array A. LDA >= max(1,M). \end{chunk} +\begin{verbatim} + SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) +* +* -- 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 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 + +\end{verbatim} + \begin{chunk}{LAPACK dlaset} (defun dlaset (uplo m n alpha beta a lda) (declare (type (simple-array double-float (*)) a) @@ -63270,47 +88465,161 @@ SYNOPSIS DOUBLE PRECISION D( * ), E( * ), WORK( * ) -PURPOSE - 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 + Purpose + ======= - "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, + 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 - and the present implementation is described in "An implementation of - the dqds Algorithm (Positive Case)", LAPACK Working Note. + "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. -ARGUMENTS - N (input) INTEGER - The number of rows and columns in the matrix. N >= 0. + Arguments + ========= - D (input/output) 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 sin- - gular values in decreasing order. + N (input) INTEGER + The number of rows and columns in the matrix. N >= 0. - E (input/output) 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 over- - written. + D (input/output) 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. - WORK (workspace) DOUBLE PRECISION array, dimension (4*N) + E (input/output) 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. - INFO (output) 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 30*N - iterations (in inner while loop) = 3, termination criterion of - outer while loop not met (program created more than N unreduced - blocks) + WORK (workspace) DOUBLE PRECISION array, dimension (4*N) + + INFO (output) 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 30*N + iterations (in inner while loop) + = 3, termination criterion of outer while loop not met + (program created more than N unreduced blocks) \end{chunk} +\begin{verbatim} + SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) +* +* -- LAPACK routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1999 +* +* .. 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 DLAS2, 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 ) + END IF +* + RETURN +* +* End of DLASQ1 +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlasq1} (let* ((zero 0.0)) (declare (type (double-float 0.0 0.0) zero)) @@ -63463,50 +88772,447 @@ SYNOPSIS DOUBLE PRECISION Z( * ) -PURPOSE - 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 han- - dling of infinities and NaNs, and false otherwise. This variable is - passed to DLAZQ3. + Purpose + ======= + + 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. + + Arguments + ========= + + N (input) INTEGER + The number of rows and columns in the matrix. N >= 0. + + Z (workspace) 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. + + INFO (output) 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 30*N + iterations (in inner while loop) + = 3, termination criterion of outer while loop not met + (program created more than N unreduced blocks) + + Further Details + =============== + 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). +\end{chunk} -ARGUMENTS - N (input) INTEGER - The number of rows and columns in the matrix. N >= 0. - - Z (workspace) 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. - - INFO (output) 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, cur- - rent 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) - -FURTHER DETAILS - The shifts are accumulated in SIGMA. Iteration count is in ITER. Ping- - pong is controlled by PP (alternates between 0 and 1). +\begin{verbatim} + SUBROUTINE DLASQ2( N, Z, INFO ) +* +* -- LAPACK routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1999 +* +* .. 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, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K, + $ N0, NBIG, NDIV, NFAIL, PP, SPLT + DOUBLE PRECISION D, DESIG, DMIN, E, EMAX, EMIN, EPS, OLDEMN, + $ QMAX, QMIN, S, SAFMIN, SIGMA, T, TEMP, TOL, + $ TOL2, TRACE, ZMAX +* .. +* .. External Subroutines .. + EXTERNAL DLASQ3, DLASRT, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC 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 +* + ITER = 2 + NFAIL = 0 + NDIV = 2*( N0-I0 ) +* + DO 140 IWHILA = 1, N + 1 + IF( N0.LT.1 ) + $ GO TO 150 +* +* 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 +* +* Store EMIN for passing to DLASQ3. +* + Z( 4*N0-1 ) = EMIN +* +* 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 = 0 +* + NBIG = 30*( N0-I0+1 ) + DO 120 IWHILB = 1, NBIG + IF( I0.GT.N0 ) + $ GO TO 130 +* +* While submatrix unfinished take a good dqds step. +* + CALL DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, + $ ITER, NDIV, IEEE ) +* + 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 110 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 + 110 CONTINUE + Z( 4*N0-1 ) = EMIN + Z( 4*N0 ) = OLDEMN + I0 = SPLT + 1 + END IF + END IF +* + 120 CONTINUE +* + INFO = 2 + RETURN +* +* end IWHILB +* + 130 CONTINUE +* + 140 CONTINUE +* + INFO = 3 + RETURN +* +* end IWHILA +* + 150 CONTINUE +* +* Move q's to the front. +* + DO 160 K = 2, N + Z( K ) = Z( 4*K-3 ) + 160 CONTINUE +* +* Sort and compute sum of eigenvalues. +* + CALL DLASRT( 'D', N, Z, IINFO ) +* + E = ZERO + DO 170 K = N, 1, -1 + E = E + Z( K ) + 170 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 -\end{chunk} +\end{verbatim} \begin{chunk}{LAPACK dlasq2} (let* ((cbias 1.5) @@ -64419,54 +90125,310 @@ SYNOPSIS DOUBLE PRECISION Z( * ) -PURPOSE - DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds. In - case of failure it changes shifts, and tries again until output is pos- - itive. + Purpose + ======= + 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. -ARGUMENTS - I0 (input) INTEGER - First index. + Arguments + ========= - N0 (input) INTEGER - Last index. + I0 (input) INTEGER + First index. - Z (input) DOUBLE PRECISION array, dimension ( 4*N ) - Z holds the qd array. + N0 (input) INTEGER + Last index. - PP (input) INTEGER - PP=0 for ping, PP=1 for pong. + Z (input) DOUBLE PRECISION array, dimension ( 4*N ) + Z holds the qd array. - DMIN (output) DOUBLE PRECISION - Minimum value of d. + PP (input) INTEGER + PP=0 for ping, PP=1 for pong. - SIGMA (output) DOUBLE PRECISION - Sum of shifts used in current segment. + DMIN (output) DOUBLE PRECISION + Minimum value of d. - DESIG (input/output) DOUBLE PRECISION - Lower order part of SIGMA + SIGMA (output) DOUBLE PRECISION + Sum of shifts used in current segment. - QMAX (input) DOUBLE PRECISION - Maximum value of q. + DESIG (input/output) DOUBLE PRECISION + Lower order part of SIGMA - NFAIL (output) INTEGER - Number of times shift was too big. + QMAX (input) DOUBLE PRECISION + Maximum value of q. - ITER (output) INTEGER - Number of iterations. + NFAIL (output) INTEGER + Number of times shift was too big. - NDIV (output) INTEGER - Number of divisions. + ITER (output) INTEGER + Number of iterations. - TTYPE (output) INTEGER - Shift type. + NDIV (output) INTEGER + Number of divisions. - IEEE (input) LOGICAL - Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). + TTYPE (output) INTEGER + Shift type. + + IEEE (input) LOGICAL + Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). \end{chunk} +\begin{verbatim} + SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, + $ ITER, NDIV, IEEE ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* May 17, 2000 +* +* .. Scalar Arguments .. + LOGICAL IEEE + INTEGER I0, ITER, N0, NDIV, NFAIL, PP + DOUBLE PRECISION DESIG, DMIN, QMAX, SIGMA +* .. +* .. 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 DMIN1, DMIN2, DN, DN1, DN2, EPS, S, SAFMIN, T, + $ TAU, TEMP, TOL, TOL2 +* .. +* .. External Subroutines .. + EXTERNAL DLASQ4, DLASQ5, DLASQ6 +* .. +* .. External Function .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MIN, SQRT +* .. +* .. Save statement .. + SAVE TTYPE + SAVE DMIN1, DMIN2, DN, DN1, DN2, TAU +* .. +* .. Data statement .. + DATA TTYPE / 0 / + DATA DMIN1 / ZERO /, DMIN2 / ZERO /, DN / ZERO /, + $ DN1 / ZERO /, DN2 / ZERO /, TAU / ZERO / +* .. +* .. Executable Statements .. +* + N0IN = N0 + EPS = DLAMCH( 'Precision' ) + SAFMIN = DLAMCH( 'Safe minimum' ) + 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 +* +* 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 +* + 70 CONTINUE +* + 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 DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, + $ DN2, TAU, TTYPE ) +* +* 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 DLASQ3 +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlasq3} (let* ((cbias 1.5) (zero 0.0) @@ -65108,51 +91070,342 @@ SYNOPSIS DOUBLE PRECISION Z( * ) -PURPOSE - DLASQ4 computes an approximation TAU to the smallest eigenvalue using - values of d from the previous transform. + Purpose + ======= + + DLASQ4 computes an approximation TAU to the smallest eigenvalue + using values of d from the previous transform. + + I0 (input) INTEGER + First index. - I0 (input) INTEGER - First index. + N0 (input) INTEGER + Last index. - N0 (input) INTEGER - Last index. + Z (input) DOUBLE PRECISION array, dimension ( 4*N ) + Z holds the qd array. - Z (input) DOUBLE PRECISION array, dimension ( 4*N ) - Z holds the qd array. + PP (input) INTEGER + PP=0 for ping, PP=1 for pong. - PP (input) INTEGER - PP=0 for ping, PP=1 for pong. + NOIN (input) INTEGER + The value of N0 at start of EIGTEST. - N0IN (input) INTEGER - The value of N0 at start of EIGTEST. + DMIN (input) DOUBLE PRECISION + Minimum value of d. - DMIN (input) DOUBLE PRECISION - Minimum value of d. + DMIN1 (input) DOUBLE PRECISION + Minimum value of d, excluding D( N0 ). - 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 ). - DMIN2 (input) DOUBLE PRECISION - Minimum value of d, excluding D( N0 ) and D( N0-1 ). + DN (input) DOUBLE PRECISION + d(N) - DN (input) DOUBLE PRECISION - d(N) + DN1 (input) DOUBLE PRECISION + d(N-1) - DN1 (input) DOUBLE PRECISION - d(N-1) + DN2 (input) DOUBLE PRECISION + d(N-2) - DN2 (input) DOUBLE PRECISION - d(N-2) + TAU (output) DOUBLE PRECISION + This is the shift. - TAU (output) DOUBLE PRECISION - This is the shift. + TTYPE (output) INTEGER + Shift type. - TTYPE (output) INTEGER - Shift type. + Further Details + =============== + CNST1 = 9/16 \end{chunk} +\begin{verbatim} + SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, + $ DN1, DN2, TAU, TTYPE ) +* +* -- 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, 1999 +* +* .. Scalar Arguments .. + INTEGER I0, N0, N0IN, PP, TTYPE + DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, 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, G, GAM, GAP1, GAP2, S +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Save statement .. + SAVE G +* .. +* .. Data statement .. + DATA G / ZERO / +* .. +* .. 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 + +\end{verbatim} + \begin{chunk}{LAPACK dlasq4} (let* ((cnst1 0.563) (cnst2 1.01) @@ -65714,51 +91967,208 @@ SYNOPSIS DOUBLE PRECISION Z( * ) -PURPOSE - DLASQ5 computes one dqds transform in ping-pong form, one version for - IEEE machines another for non IEEE machines. + Purpose + ======= + DLASQ5 computes one dqds transform in ping-pong form, one + version for IEEE machines another for non IEEE machines. -ARGUMENTS - I0 (input) INTEGER - First index. + Arguments + ========= - N0 (input) INTEGER - Last index. + I0 (input) INTEGER + First index. - Z (input) DOUBLE PRECISION array, dimension ( 4*N ) - Z holds the qd array. EMIN is stored in Z(4*N0) to avoid an extra - argument. + N0 (input) INTEGER + Last index. - PP (input) INTEGER - PP=0 for ping, PP=1 for pong. + Z (input) DOUBLE PRECISION array, dimension ( 4*N ) + Z holds the qd array. EMIN is stored in Z(4*N0) to avoid + an extra argument. - TAU (input) DOUBLE PRECISION - This is the shift. + PP (input) INTEGER + PP=0 for ping, PP=1 for pong. - DMIN (output) DOUBLE PRECISION - Minimum value of d. + TAU (input) DOUBLE PRECISION + This is the shift. - DMIN1 (output) DOUBLE PRECISION Minimum value of d, excluding D( - N0 ). + DMIN (output) DOUBLE PRECISION + Minimum value of d. - DMIN2 (output) DOUBLE PRECISION Minimum value of d, excluding D( - N0 ) and D( N0-1 ). + DMIN1 (output) DOUBLE PRECISION + Minimum value of d, excluding D( N0 ). - DN (output) DOUBLE PRECISION - d(N0), the last value of d. + DMIN2 (output) DOUBLE PRECISION + Minimum value of d, excluding D( N0 ) and D( N0-1 ). - DNM1 (output) DOUBLE PRECISION - d(N0-1). + DN (output) DOUBLE PRECISION + d(N0), the last value of d. - DNM2 (output) DOUBLE PRECISION - d(N0-2). + DNM1 (output) DOUBLE PRECISION + d(N0-1). - IEEE (input) LOGICAL - Flag for IEEE or non IEEE arithmetic. + DNM2 (output) DOUBLE PRECISION + d(N0-2). + + IEEE (input) LOGICAL + Flag for IEEE or non IEEE arithmetic. \end{chunk} +\begin{verbatim} + SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, + $ DNM1, DNM2, IEEE ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* May 17, 2000 +* +* .. Scalar Arguments .. + LOGICAL IEEE + INTEGER I0, N0, PP + DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameter .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + INTEGER J4, J4P2 + DOUBLE PRECISION D, EMIN, TEMP +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* + IF( ( N0-I0-1 ).LE.0 ) + $ RETURN +* + 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 +* + Z( J4+2 ) = DN + Z( 4*N0-PP ) = EMIN + RETURN +* +* End of DLASQ5 +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlasq5} (let* ((zero 0.0)) (declare (type (double-float 0.0 0.0) zero)) @@ -66205,45 +92615,188 @@ SYNOPSIS DOUBLE PRECISION Z( * ) -PURPOSE - DLASQ6 computes one dqd (shift equal to zero) transform in ping-pong - form, with protection against underflow and overflow. + Purpose + ======= + DLASQ6 computes one dqd (shift equal to zero) transform in + ping-pong form, with protection against underflow and overflow. -ARGUMENTS - I0 (input) INTEGER - First index. + Arguments + ========= + + I0 (input) INTEGER + First index. - N0 (input) INTEGER - Last index. + N0 (input) INTEGER + Last index. - Z (input) DOUBLE PRECISION array, dimension ( 4*N ) - Z holds the qd array. EMIN is stored in Z(4*N0) to avoid an extra - argument. + Z (input) DOUBLE PRECISION array, dimension ( 4*N ) + Z holds the qd array. EMIN is stored in Z(4*N0) to avoid + an extra argument. - PP (input) INTEGER - PP=0 for ping, PP=1 for pong. + PP (input) INTEGER + PP=0 for ping, PP=1 for pong. - DMIN (output) DOUBLE PRECISION - Minimum value of d. + DMIN (output) DOUBLE PRECISION + Minimum value of d. - DMIN1 (output) DOUBLE PRECISION Minimum value of d, excluding D( - N0 ). + DMIN1 (output) DOUBLE PRECISION + Minimum value of d, excluding D( N0 ). - DMIN2 (output) DOUBLE PRECISION Minimum value of d, excluding D( - N0 ) and D( N0-1 ). + DMIN2 (output) DOUBLE PRECISION + Minimum value of d, excluding D( N0 ) and D( N0-1 ). - DN (output) DOUBLE PRECISION - d(N0), the last value of d. + DN (output) DOUBLE PRECISION + d(N0), the last value of d. - DNM1 (output) DOUBLE PRECISION - d(N0-1). + DNM1 (output) DOUBLE PRECISION + d(N0-1). - DNM2 (output) DOUBLE PRECISION - d(N0-2). + DNM2 (output) DOUBLE PRECISION + d(N0-2). \end{chunk} +\begin{verbatim} + SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, + $ DNM1, DNM2 ) +* +* -- 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, 1999 +* +* .. 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 + +\end{verbatim} + \begin{chunk}{LAPACK dlasq6} (let* ((zero 0.0)) (declare (type (double-float 0.0 0.0) zero)) @@ -66659,123 +93212,336 @@ SYNOPSIS DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) -PURPOSE - 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 + Purpose + ======= - and when SIDE = 'R', the transformation takes the form + DLASR performs the transformation - A := A*P**T + A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) - 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. + A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) - When DIRECT = 'F' (Forward sequence), then + where A is an m by n real matrix and P is an orthogonal matrix, + consisting of a sequence of plane rotations determined by the + parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l' + and z = n when SIDE = 'R' or 'r' ): - P = P(z-1) * ... * P(2) * P(1) + When DIRECT = 'F' or 'f' ( Forward sequence ) then - and when DIRECT = 'B' (Backward sequence), then + P = P( z - 1 )*...*P( 2 )*P( 1 ), - P = P(1) * P(2) * ... * P(z-1) + and when DIRECT = 'B' or 'b' ( Backward sequence ) then - where P(k) is a plane rotation matrix defined by the 2-by-2 rotation + P = P( 1 )*P( 2 )*...*P( z - 1 ), - R(k) = ( c(k) s(k) ) - = ( -s(k) c(k) ). + where P( k ) is a plane rotation matrix for the following planes: - When PIVOT = 'V' (Variable pivot), the rotation is performed for the - plane (k,k+1), i.e., P(k) has the form + when PIVOT = 'V' or 'v' ( Variable pivot ), + the plane ( k, k + 1 ) - P(k) = ( 1 ) - ( ... ) - ( 1 ) - ( c(k) s(k) ) - ( -s(k) c(k) ) - ( 1 ) - ( ... ) - ( 1 ) + when PIVOT = 'T' or 't' ( Top pivot ), + the plane ( 1, k + 1 ) - where R(k) appears as a rank-2 modification to the identity matrix in - rows and columns k and k+1. + when PIVOT = 'B' or 'b' ( Bottom pivot ), + the plane ( k, z ) - When PIVOT = 'T' (Top pivot), the rotation is performed for the plane - (1,k+1), so P(k) has the form + c( k ) and s( k ) must contain the cosine and sine that define the + matrix P( k ). The two by two plane rotation part of the matrix + P( k ), R( k ), is assumed to be of the form - P(k) = ( c(k) s(k) ) - ( 1 ) - ( ... ) - ( 1 ) - ( -s(k) c(k) ) - ( 1 ) - ( ... ) - ( 1 ) + R( k ) = ( c( k ) s( k ) ). + ( -s( k ) c( k ) ) - where R(k) appears in rows and columns 1 and k+1. + This version vectorises across rows of the array A when SIDE = 'L'. - Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is performed - for the plane (k,z), giving P(k) the form + Arguments + ========= - P(k) = ( 1 ) - ( ... ) - ( 1 ) - ( c(k) s(k) ) - ( 1 ) - ( ... ) - ( 1 ) - ( -s(k) c(k) ) + SIDE (input) 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' - where R(k) appears in rows and columns k and z. The rotations are per- - formed without ever forming P(k) explicitly. + DIRECT (input) 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 ) + PIVOT (input) 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) -ARGUMENTS - SIDE (input) 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 + M (input) INTEGER + The number of rows of the matrix A. If m <= 1, an immediate + return is effected. - PIVOT (input) 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) + N (input) INTEGER + The number of columns of the matrix A. If n <= 1, an + immediate return is effected. - DIRECT (input) 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) + C, S (input) DOUBLE PRECISION arrays, dimension + (M-1) if SIDE = 'L' + (N-1) if SIDE = 'R' + c(k) and s(k) contain the cosine and sine that define the + matrix P(k). The two by two plane rotation part of the + matrix P(k), R(k), is assumed to be of the form + R( k ) = ( c( k ) s( k ) ). + ( -s( k ) c( k ) ) - M (input) INTEGER - The number of rows of the matrix A. If m <= 1, an immediate - return is effected. - - N (input) INTEGER - The number of columns of the matrix A. If n <= 1, an im